mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
106 lines
3.3 KiB
Haskell
106 lines
3.3 KiB
Haskell
{-# 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,catchCGI,throwCGI)
|
|
|
|
import Text.JSON
|
|
import qualified Codec.Binary.UTF8.String as UTF8 (encodeString)
|
|
import qualified Data.ByteString.Lazy as BS
|
|
|
|
-- * Logging
|
|
|
|
#ifndef mingw32_HOST_OS
|
|
logError :: String -> IO ()
|
|
logError s = hPutStrLn stderr s
|
|
|
|
stderrToFile :: FilePath -> IO ()
|
|
stderrToFile file =
|
|
do let mode = ownerReadMode<>ownerWriteMode<>groupReadMode<>otherReadMode
|
|
(<>) = unionFileModes
|
|
flags = defaultFileFlags { append = True }
|
|
fileFd <- openFd file WriteOnly (Just mode) flags
|
|
dupTo fileFd stdError
|
|
return ()
|
|
#else
|
|
logError :: String -> IO ()
|
|
logError s = return ()
|
|
|
|
stderrToFile :: FilePath -> IO ()
|
|
stderrToFile s = return ()
|
|
#endif
|
|
|
|
-- * General CGI Error exception mechanism
|
|
|
|
data CGIError = CGIError { cgiErrorCode :: Int, cgiErrorMessage :: String, cgiErrorText :: [String] }
|
|
deriving (Show,Typeable)
|
|
|
|
instance Exception CGIError where
|
|
toException e = SomeException e
|
|
fromException (SomeException e) = cast e
|
|
|
|
throwCGIError :: Int -> String -> [String] -> CGI a
|
|
throwCGIError c m t = throwCGI $ toException $ CGIError c m t
|
|
|
|
handleCGIErrors :: CGI CGIResult -> CGI CGIResult
|
|
handleCGIErrors x =
|
|
x `catchCGI` \e -> case fromException e of
|
|
Nothing -> throw e
|
|
Just (CGIError c m t) -> do setXO; outputError c m t
|
|
|
|
-- * General CGI and JSON stuff
|
|
|
|
outputJSONP :: JSON a => a -> CGI CGIResult
|
|
outputJSONP = outputEncodedJSONP . encode
|
|
|
|
outputEncodedJSONP :: String -> CGI CGIResult
|
|
outputEncodedJSONP json =
|
|
do mc <- getInput "jsonp"
|
|
let (ty,str) = case mc of
|
|
Nothing -> ("json",json)
|
|
Just c -> ("javascript",c ++ "(" ++ json ++ ")")
|
|
ct = "application/"++ty++"; charset=utf-8"
|
|
outputText ct str
|
|
|
|
outputPNG :: BS.ByteString -> CGI CGIResult
|
|
outputPNG = outputBinary' "image/png"
|
|
|
|
outputBinary :: BS.ByteString -> CGI CGIResult
|
|
outputBinary = outputBinary' "application/binary"
|
|
|
|
outputBinary' :: String -> BS.ByteString -> CGI CGIResult
|
|
outputBinary' ct x = do
|
|
setHeader "Content-Type" ct
|
|
setXO
|
|
outputFPS x
|
|
|
|
outputHTML :: String -> CGI CGIResult
|
|
outputHTML = outputText "text/html; charset=utf-8"
|
|
|
|
outputPlain :: String -> CGI CGIResult
|
|
outputPlain = outputText "text/plain; charset=utf-8"
|
|
|
|
outputText ct = outputStrict ct . UTF8.encodeString
|
|
|
|
outputStrict :: String -> String -> CGI CGIResult
|
|
outputStrict ct x | x == x = do setHeader "Content-Type" ct
|
|
setXO
|
|
output x
|
|
| otherwise = fail "I am the pope."
|
|
|
|
setXO = setHeader "Access-Control-Allow-Origin" "*"
|
|
-- https://developer.mozilla.org/en-US/docs/HTTP/Access_control_CORS
|