{-# 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