{-# LANGUAGE DeriveDataTypeable, CPP #-}
-- | CGI utility functions for output, error handling and logging
module CGIUtils (throwCGIError, handleCGIErrors,
                 stderrToFile,logError,
                 outputJSONP,outputEncodedJSONP,
                 outputPNG,outputBinary,outputBinary',
                 outputHTML,outputPlain,outputText) where

import Control.Exception(Exception(..),SomeException(..),throw)
import Data.Typeable(Typeable,cast)
import Prelude hiding (catch)
import System.IO(hPutStrLn,stderr)
#ifndef mingw32_HOST_OS
import System.Posix
#endif

import CGI(CGI,CGIResult,setHeader,output,outputFPS,outputError,
           getInput)

import Text.JSON
import qualified Codec.Binary.UTF8.String as UTF8 (encodeString)
import qualified Data.ByteString.Lazy as BS
import Control.Monad.Catch (MonadThrow(throwM))
import Network.CGI.Monad (catchCGI)
import Control.Monad.Catch (MonadCatch(catch))

-- * Logging

#ifndef mingw32_HOST_OS
logError :: String -> IO ()
logError :: String -> IO ()
logError String
s = Handle -> String -> IO ()
hPutStrLn Handle
stderr String
s

stderrToFile :: FilePath -> IO ()
stderrToFile :: String -> IO ()
stderrToFile String
file =
    do let mode :: FileMode
mode = FileMode
ownerReadModeFileMode -> FileMode -> FileMode
<>FileMode
ownerWriteModeFileMode -> FileMode -> FileMode
<>FileMode
groupReadModeFileMode -> FileMode -> FileMode
<>FileMode
otherReadMode
           <> :: FileMode -> FileMode -> FileMode
(<>) = FileMode -> FileMode -> FileMode
unionFileModes
           flags :: OpenFileFlags
flags = OpenFileFlags
defaultFileFlags { append :: Bool
append = Bool
True }
       Fd
fileFd <- String -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd
openFd String
file OpenMode
WriteOnly (FileMode -> Maybe FileMode
forall a. a -> Maybe a
Just FileMode
mode) OpenFileFlags
flags
       Fd -> Fd -> IO Fd
dupTo Fd
fileFd Fd
stdError
       () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#else
logError :: String -> IO ()
logError s = return ()

stderrToFile :: FilePath -> IO ()
stderrToFile s = return ()
#endif

-- * General CGI Error exception mechanism

data CGIError = CGIError { CGIError -> Int
cgiErrorCode :: Int, CGIError -> String
cgiErrorMessage :: String, CGIError -> [String]
cgiErrorText :: [String] }
                deriving (Int -> CGIError -> ShowS
[CGIError] -> ShowS
CGIError -> String
(Int -> CGIError -> ShowS)
-> (CGIError -> String) -> ([CGIError] -> ShowS) -> Show CGIError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CGIError] -> ShowS
$cshowList :: [CGIError] -> ShowS
show :: CGIError -> String
$cshow :: CGIError -> String
showsPrec :: Int -> CGIError -> ShowS
$cshowsPrec :: Int -> CGIError -> ShowS
Show,Typeable)

instance Exception CGIError where
  toException :: CGIError -> SomeException
toException CGIError
e = CGIError -> SomeException
forall e. Exception e => e -> SomeException
SomeException CGIError
e
  fromException :: SomeException -> Maybe CGIError
fromException (SomeException e
e) = e -> Maybe CGIError
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
e

throwCGIError :: Int -> String -> [String] -> CGI a
throwCGIError :: Int -> String -> [String] -> CGI a
throwCGIError Int
c String
m [String]
t = SomeException -> CGI a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (SomeException -> CGI a) -> SomeException -> CGI a
forall a b. (a -> b) -> a -> b
$ CGIError -> SomeException
forall e. Exception e => e -> SomeException
toException (CGIError -> SomeException) -> CGIError -> SomeException
forall a b. (a -> b) -> a -> b
$ Int -> String -> [String] -> CGIError
CGIError Int
c String
m [String]
t

handleCGIErrors :: CGI CGIResult -> CGI CGIResult
handleCGIErrors :: CGI CGIResult -> CGI CGIResult
handleCGIErrors CGI CGIResult
x =
    CGI CGIResult
x CGI CGIResult -> (SomeException -> CGI CGIResult) -> CGI CGIResult
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \SomeException
e -> case SomeException -> Maybe CGIError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
                         Maybe CGIError
Nothing -> SomeException -> CGI CGIResult
forall a e. Exception e => e -> a
throw SomeException
e
                         Just (CGIError Int
c String
m [String]
t) -> do CGIT IO ()
setXO; Int -> String -> [String] -> CGI CGIResult
forall (m :: * -> *).
(MonadCGI m, MonadIO m) =>
Int -> String -> [String] -> m CGIResult
outputError Int
c String
m [String]
t

-- * General CGI and JSON stuff

outputJSONP :: JSON a => a -> CGI CGIResult
outputJSONP :: a -> CGI CGIResult
outputJSONP = String -> CGI CGIResult
outputEncodedJSONP (String -> CGI CGIResult) -> (a -> String) -> a -> CGI CGIResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. JSON a => a -> String
encode

outputEncodedJSONP :: String -> CGI CGIResult
outputEncodedJSONP :: String -> CGI CGIResult
outputEncodedJSONP String
json = 
    do Maybe String
mc <- String -> CGIT IO (Maybe String)
forall (m :: * -> *). MonadCGI m => String -> m (Maybe String)
getInput String
"jsonp"
       let (String
ty,String
str) = case Maybe String
mc of
                        Maybe String
Nothing -> (String
"json",String
json)
                        Just String
c  -> (String
"javascript",String
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
json String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")")
           ct :: String
ct = String
"application/"String -> ShowS
forall a. [a] -> [a] -> [a]
++String
tyString -> ShowS
forall a. [a] -> [a] -> [a]
++String
"; charset=utf-8"
       String -> String -> CGI CGIResult
outputText String
ct String
str

outputPNG :: BS.ByteString -> CGI CGIResult
outputPNG :: ByteString -> CGI CGIResult
outputPNG = String -> ByteString -> CGI CGIResult
outputBinary' String
"image/png"

outputBinary :: BS.ByteString -> CGI CGIResult
outputBinary :: ByteString -> CGI CGIResult
outputBinary = String -> ByteString -> CGI CGIResult
outputBinary' String
"application/binary"

outputBinary' :: String -> BS.ByteString -> CGI CGIResult
outputBinary' :: String -> ByteString -> CGI CGIResult
outputBinary' String
ct ByteString
x = do
       String -> String -> CGIT IO ()
forall (m :: * -> *). MonadCGI m => String -> String -> m ()
setHeader String
"Content-Type" String
ct
       CGIT IO ()
setXO
       ByteString -> CGI CGIResult
forall (m :: * -> *). MonadCGI m => ByteString -> m CGIResult
outputFPS ByteString
x

outputHTML :: String -> CGI CGIResult
outputHTML :: String -> CGI CGIResult
outputHTML = String -> String -> CGI CGIResult
outputText String
"text/html; charset=utf-8"

outputPlain :: String -> CGI CGIResult
outputPlain :: String -> CGI CGIResult
outputPlain = String -> String -> CGI CGIResult
outputText String
"text/plain; charset=utf-8"

outputText :: String -> String -> CGI CGIResult
outputText String
ct = String -> String -> CGI CGIResult
outputStrict String
ct (String -> CGI CGIResult) -> ShowS -> String -> CGI CGIResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
UTF8.encodeString

outputStrict :: String -> String -> CGI CGIResult
outputStrict :: String -> String -> CGI CGIResult
outputStrict String
ct String
x | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
x = do String -> String -> CGIT IO ()
forall (m :: * -> *). MonadCGI m => String -> String -> m ()
setHeader String
"Content-Type" String
ct
                                CGIT IO ()
setXO
                                String -> CGI CGIResult
forall (m :: * -> *). MonadCGI m => String -> m CGIResult
output String
x
                  | Bool
otherwise = String -> CGI CGIResult
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"I am the pope."

setXO :: CGIT IO ()
setXO = String -> String -> CGIT IO ()
forall (m :: * -> *). MonadCGI m => String -> String -> m ()
setHeader String
"Access-Control-Allow-Origin" String
"*"
     -- https://developer.mozilla.org/en-US/docs/HTTP/Access_control_CORS