mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 13:09:33 -06:00
0e87a88f4b
* Introducing the module CGI, re-exporting a subset of the cgi package. It might complete replace the cgi package in the future. * Introducing the module CGIUtils, containing functions from FastCGIUtils that have nothing to do with fastcgi. Some low level hackery with unsafePerformIO and global variables was left in FastCGIUtils, but it is actually not used, neither for gf -server nor exec/pgf-fcgi.hs.
104 lines
3.3 KiB
Haskell
104 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) where
|
|
|
|
import Control.Exception(Exception(..),SomeException(..),throw)
|
|
import Data.Dynamic(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"
|
|
outputStrict ct $ UTF8.encodeString 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 = outputStrict "text/html; charset=utf-8" . UTF8.encodeString
|
|
|
|
outputPlain :: String -> CGI CGIResult
|
|
outputPlain = outputStrict "text/plain; charset=utf-8" . 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
|