HSP.hs

module HAppS.Server.HSP where

import HAppS.Server
import HSP

import System.Plugins
import Control.Monad.Trans

import qualified Data.ByteString.Char8 as P
import qualified Data.ByteString.Lazy.Char8 as L

hspArgs =
        [ "-fglasgow-exts"
        , "-fallow-overlapping-instances"
        , "-fallow-undecidable-instances"
        , "-F", "-pgmFtrhsx"
        , "-fno-warn-overlapping-patterns"
        ]
debugPrintLn x = liftIO $ putStrLn x

instance ToMessage XML where
    toContentType _ = P.pack "text/html"
    toMessage = L.pack . renderXML

runHSPWeb :: Conf -> IO ()
runHSPWeb conf
    = simpleHTTP conf
      [ withRequest $ \rq ->
        do let file = tail (rqURL rq)
           mkStatus <- liftIO $ makeAll file hspArgs
           case mkStatus of
                 MakeFailure errs  ->
                     do debugPrintLn $ "Failure: " ++ unlines errs
                        error (show errs)
                 MakeSuccess mkcode obj -> do
                   case mkcode of
                     ReComp -> debugPrintLn $ "Success!"
                     NotReq -> debugPrintLn $ "Not required!"
                   debugPrintLn $ "Loading page at: " ++ obj ++ " ... "
                   ldStatus <- liftIO $ load obj [] [] "page"
                   case ldStatus of
                     LoadFailure errs  ->
                         do debugPrintLn $ "Failure: " ++ unlines errs
                            error (show errs)
                     LoadSuccess mod page ->
                         do debugPrintLn $ "Success!"
                            liftIO $ evalHSP page :: Web XML

      ]