module WASH.CGI.CGIOutput where
import IO
import Maybe
import Monad
import System
import WASH.Utility.Auxiliary
import WASH.Utility.BulkIO (rawHandleCopy)
import qualified WASH.CGI.Debug as Debug
import qualified WASH.Utility.RFC2279 as RFC2279
import qualified WASH.Utility.Shell as Shell
import WASH.CGI.CGIConfig
import WASH.CGI.CGITypes
import WASH.CGI.HTMLWrapper hiding (head, div, span, map)
import WASH.HTML.HTMLTemplates
itell :: Handle -> WithHTML x IO () -> IO a
itell h hma = do elem <- build_document hma
cgiPut h elem
exitWith ExitSuccess
class CGIOutput a where
cgiPut' :: Handle -> a -> IO ()
cgiPutList :: Handle -> [a] -> IO ()
cgiPutList h xs = cgiPutList h xs
cgiPut :: CGIOutput a => Handle -> a -> IO ()
cgiPut h x =
do cgiPut' h x
instance CGIOutput a => CGIOutput [a] where
cgiPut' h xs = cgiPutList h xs
instance CGIOutput ELEMENT_ where
cgiPut' h x = hPutElement h x
instance CGIOutput Char where
cgiPut' h ch = cgiPutList h [ch]
cgiPutList h x = hPutListChar h x
instance CGIOutput FileReference where
cgiPut' h x = hPutFileReference h x
instance CGIOutput ResponseFileReference where
cgiPut' h x = hPutResponseFileReference h x
instance CGIOutput Status where
cgiPut' h x = hPutStatus h x
instance CGIOutput Location where
cgiPut' h x = hPutLocation h x
instance CGIOutput FreeForm where
cgiPut' h x = hPutFreeForm h x
hPutElement h elem =
do hPutStrLn h "Content-Type: text/html; charset=utf-8"
hPutStrLn h ""
hPutStr h $ RFC2279.encode $ show elem
let new h = hPutStrLn h (showTemplatified elem "")
old h = hPutStrLn h $ RFC2279.encode $ show elem
Debug.logOutput "OLD" old
hPutListChar h str =
do hPutStrLn h "Content-Type: text/plain; charset=utf-8"
hPutStrLn h ""
hPutStr h $ RFC2279.encode str
hPutFileReference h fr =
do hPutStr h "Content-Type: "
hPutStrLn h (fileReferenceContentType fr)
hPutStrLn h ""
hFlush h
hin <- openFile (fileReferenceName fr) ReadMode
rawHandleCopy hin h
hClose hin
hPutResponseFileReference h (ResponseFileReference fname) =
do hFlush h
hin <- openFile fname ReadMode
rawHandleCopy hin h
hClose hin
hPutStatus h (Status status reason_phrase elems) =
do hPutStr h "Status: "
hPutStr h status_str
hPutStr h " "
hPutStrLn h reason_phrase
case elems of
Nothing -> hPutStrLn h ""
Just _ -> itell h message
where status_str = show status
ttl = "Error: " ++ status_str ++ ' ' : reason_phrase
message = standardPage ttl (fromJust elems)
hPutLocation h (Location url) =
do hPutStr h "Location: "
hPutStrLn h (unURL url)
hPutStrLn h ""
hPutFreeForm h (FreeForm fileName contentType rawContents) =
do hPutStr h "Content-Type: "
hPutStr h contentType
when (not (null fileName)) $
do hPutStr h " ;name=\""
hPutStr h fileName
hPutStr h "\""
hPutStrLn h ""
hPutStrLn h ""
hPutStr h rawContents