happs-hsp (empty) → 0.1

raw patch · 3 files changed

+63/−0 lines, 3 filesdep +HAppS-Serverdep +basedep +bytestringsetup-changed

Dependencies added: HAppS-Server, base, bytestring, hsp, mtl, plugins

Files

• Setup.hs +2/−0
• happs-hsp.cabal +9/−0
• src/HAppS/Server/HSP.hs +52/−0

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,9 @@+Name:		happs-hsp+Version:	0.1+Build-Type:	Simple+Build-Depends:	base, mtl, bytestring, plugins, HAppS-Server, hsp+LICENSE:	BSD3+Hs-Source-Dirs: src++Exposed-Modules:+  HAppS.Server.HSP

@@ -0,0 +1,52 @@+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++      ]+++