diff --git a/demo/Main.hs b/demo/Main.hs new file mode 100644 --- /dev/null +++ b/demo/Main.hs @@ -0,0 +1,10 @@ +module Main where + +import qualified Network.MoHWS.Server as Server +import qualified Network.MoHWS.Initialization as Init +import qualified Network.MoHWS.Initialization.Standard as Std +import qualified Data.ByteString.Lazy.Char8 as B + +main :: IO () +main = + Server.main (Std.init :: Init.T B.ByteString Std.Extension) diff --git a/demo/MainDynamic.hs b/demo/MainDynamic.hs new file mode 100644 --- /dev/null +++ b/demo/MainDynamic.hs @@ -0,0 +1,69 @@ +module Main where + +import qualified Network.MoHWS.Server as Server + +import qualified Network.MoHWS.Module.Description as ModuleDesc +import qualified Network.MoHWS.Stream as Stream +import qualified Network.MoHWS.Initialization as Init +import qualified Data.Accessor.Basic as Accessor +import qualified Data.ByteString.Lazy.Char8 as B + +import qualified Network.MoHWS.Part.UserDirectory as UserDir +import qualified Network.MoHWS.Part.VirtualHost as VirtualHost +import qualified Network.MoHWS.Part.AddSlash as AddSlash +import qualified Network.MoHWS.Part.Index as Index +import qualified Network.MoHWS.Part.CGI as CGI +import qualified Network.MoHWS.Part.DynHS as DynHS +import qualified Network.MoHWS.Part.File as File +import qualified Network.MoHWS.Part.Listing as Listing + +import Prelude hiding (init, ) + + +data Extension = + Extension { + userDir :: UserDir.Configuration, + virtualHost :: VirtualHost.Configuration, + addSlash :: AddSlash.Configuration, + index :: Index.Configuration, + cgi :: CGI.Configuration, + file :: File.Configuration, + listing :: Listing.Configuration + } + +lift :: + (partExt -> fullExt -> fullExt) -> (fullExt -> partExt) -> + ModuleDesc.T body partExt -> ModuleDesc.T body fullExt +lift set get = + ModuleDesc.lift (Accessor.fromSetGet set get) + +modules :: (Stream.C body) => [ModuleDesc.T body Extension] +modules = + lift (\x ext -> ext{userDir = x}) userDir UserDir.desc : + lift (\x ext -> ext{virtualHost = x}) virtualHost VirtualHost.desc : + lift (\x ext -> ext{addSlash = x}) addSlash AddSlash.desc : + lift (\x ext -> ext{index = x}) index Index.desc : + lift (\x ext -> ext{cgi = x}) cgi CGI.desc : + DynHS.desc : + lift (\x ext -> ext{file = x}) file File.desc : + lift (\x ext -> ext{listing = x}) listing Listing.desc : + [] + +init :: (Stream.C body) => Init.T body Extension +init = + Init.Cons { + Init.moduleList = modules, + Init.configurationExtensionDefault = + Extension + (error "uninitialized userDir extension") + (error "uninitialized virtualHost extension") + (error "uninitialized addSlash extension") + (error "uninitialized index extension") + (error "uninitialized cgi extension") + (error "uninitialized file extension") + (error "uninitialized listing extension") + } + +main :: IO () +main = + Server.main (init :: Init.T B.ByteString Extension) diff --git a/demo/Network/MoHWS/Part/DynHS.hs b/demo/Network/MoHWS/Part/DynHS.hs new file mode 100644 --- /dev/null +++ b/demo/Network/MoHWS/Part/DynHS.hs @@ -0,0 +1,103 @@ +-- Copyright 2006 Bjorn Bringert +module Network.MoHWS.Part.DynHS where + +import Network.MoHWS.Part.DynHS.GHCUtil + (Session, initGHC, setLogAction, withCleanUp, getFileValue, ) + +import qualified Network.MoHWS.Module.Description as ModuleDesc +import qualified Network.MoHWS.Module as Module +import qualified Network.MoHWS.HTTP.Header as Header +import qualified Network.MoHWS.HTTP.Response as Response +import qualified Network.MoHWS.Server.Request as ServerRequest +import qualified Network.MoHWS.Server.Context as ServerContext +import qualified Network.MoHWS.Stream as Stream +import Network.MoHWS.Server.Request (serverFilename, ) +import Network.MoHWS.Logger.Error (debug, logError, ) + +import Network.MoHWS.Configuration as Config + +import Control.Exception as Exception +import Control.Monad.Trans.Maybe (MaybeT(MaybeT), ) +import Control.Monad (liftM, mzero, ) +import Data.List (isSuffixOf, ) +import Data.Tuple.HT (mapFst, ) + + +-- FIXME: keep this in config +packageDirectory :: FilePath +packageDirectory = "/usr/lib/ghc-6.8.2" -- last working version was 6.6 + + +desc :: (Stream.C body) => ModuleDesc.T body ext +desc = + ModuleDesc.empty { + ModuleDesc.name = "dynhs", + ModuleDesc.load = loadDynHS + } + +loadDynHS :: (Stream.C body) => + ServerContext.T ext -> IO (Module.T body) +loadDynHS st = + do s <- initGHC packageDirectory + dynhsLoadConfig s st + return $ + Module.empty { + Module.handleRequest = dynhsHandleRequest s st + } + +dynhsLoadConfig :: Session -> ServerContext.T ext -> IO () +dynhsLoadConfig s st = setLogAction s (logError st) + +dynhsHandleRequest :: (Stream.C body) => + Session -> ServerContext.T ext -> ServerRequest.T body -> MaybeT IO (Response.T body) +dynhsHandleRequest s st sreq = + if ".hs" `isSuffixOf` serverFilename sreq + then dynhsHandleRequest2 s st sreq + else mzero + +dynhsHandleRequest2 :: (Stream.C body) => + Session -> ServerContext.T ext -> ServerRequest.T body -> MaybeT IO (Response.T body) +dynhsHandleRequest2 s st sreq = + MaybeT $ withCleanUp s $ +-- FIXME: lots of fake stuff here + do debug st $ "DynHS: Loading " ++ show (serverFilename sreq) + e_cgiMain <- logGHCErrors s st (getCgiMain s (serverFilename sreq)) + case e_cgiMain of + Left resp -> return $ Just resp + Right cgiMain -> + do debug st $ "DynHS: Loaded successfully: " ++ show (serverFilename sreq) + liftM Just $ runCgiMain st sreq cgiMain + +type CGIMain = [(String,String)] -> [(String,String)] -> IO ([(String,String)], String) + +getCgiMain :: Session -> FilePath -> IO CGIMain +getCgiMain s file = getFileValue s file "cgiMain" + +runCgiMain :: (Stream.C body) => + ServerContext.T ext -> ServerRequest.T body -> CGIMain -> IO (Response.T body) +runCgiMain st _sreq cgiMain = + -- FIXME: lots of fake stuff here + do let env = [] + inputs = [] + (hs,content) <- cgiMain env inputs + let headers = + Header.group $ + map (uncurry Header.make . mapFst Header.makeName) hs + let code = 200 + descr = "OK" + return $ + Response.Cons code descr headers [] True $ + Response.bodyWithSizeFromString $ + Stream.fromString (Config.chunkSize (ServerContext.config st)) content + +-- GHC utilities + +logGHCErrors :: (Stream.C body) => + Session -> ServerContext.T ext -> IO a -> IO (Either (Response.T body) a) +logGHCErrors _s st f = + liftM Right f + `Exception.catch` + (\e -> do logError st (show e) + -- FIXME: include error message in response + return $ Left $ Response.makeInternalServerError (ServerContext.config st)) + diff --git a/demo/Network/MoHWS/Part/DynHS/CGI.hs b/demo/Network/MoHWS/Part/DynHS/CGI.hs new file mode 100644 --- /dev/null +++ b/demo/Network/MoHWS/Part/DynHS/CGI.hs @@ -0,0 +1,48 @@ +module Network.MoHWS.Part.DynHS.CGI where + +import Network.MoHWS.Part.CGI (mkCGIEnv, mkCGIResponse, ) + +import qualified Network.MoHWS.HTTP.Response as Response +import qualified Network.MoHWS.HTTP.Request as Request +import qualified Network.MoHWS.Server.Request as ServerRequest +import qualified Network.MoHWS.Server.Context as ServerContext +import ServerRequest (clientRequest, ) + +import qualified Data.ByteString.Lazy.Char8 as BS +import Data.ByteString.Lazy.Char8 (ByteString) +import qualified Data.Map as Map +import Data.Maybe (isJust) + +import Network.CGI.Monad (CGI, runCGIT, ) +import Network.CGI.Protocol + + +hwsRunCGI :: ServerContext.T ext -> ServerRequest.T -> CGI CGIResult -> IO (Response.T String) +hwsRunCGI st sreq cgi = + do let path_info = "" -- FIXME: do the path walk + env <- mkCGIEnv st sreq path_info + let input = BS.pack $ Request.body $ clientRequest sreq + (hs,body) <- runCGI_ env input (runCGIT cgi) + mkCGIResponse hs (BS.unpack body) + +-- | Run a CGI action. This is what runCGIEnvFPS really should look like. +runCGI_ :: Monad m => + [(String,String)] -- ^ CGI environment variables. + -> ByteString -- ^ Request body. + -> (CGIRequest -> m (Header.Group, CGIResult)) -- ^ CGI action. + -> m (Header.Group, ByteString) -- ^ (Response.T String) (headers and content). +runCGI_ vars inp f + = do (hs,outp) <- f $ CGIRequest { + cgiVars = Map.fromList vars, + cgiInputs = decodeInput vars inp, + cgiRequestBody = inp + } + return $ case outp of + CGIOutput c -> (hs',c) + where hs' = if isJust (lookup ct hs) + then hs else hs ++ [(ct,defaultContentType)] + ct = HeaderName "Content-type" + CGINothing -> (hs, BS.empty) + +defaultContentType :: String +defaultContentType = "text/html; charset=ISO-8859-1" diff --git a/demo/Network/MoHWS/Part/DynHS/GHCUtil.hs b/demo/Network/MoHWS/Part/DynHS/GHCUtil.hs new file mode 100644 --- /dev/null +++ b/demo/Network/MoHWS/Part/DynHS/GHCUtil.hs @@ -0,0 +1,98 @@ +module Network.MoHWS.Part.DynHS.GHCUtil + (Session, + initGHC, + setLogAction, + withCleanUp, + getFileValue, + -- * Error logging + Severity(..), SrcSpan, PprStyle, Message, + mkLocMessage + ) where + +-- GHC API stuff +import DynFlags (initDynFlags, defaultDynFlags, ) +import ErrUtils (Message, mkLocMessage, ) +import GHC +import HscMain (newHscEnv, ) +import HscTypes (Session(..), ) +import Outputable (PprStyle, ) +import SrcLoc (SrcSpan, ) +import SysTools (initSysTools, ) + +import Data.Dynamic (Typeable, fromDynamic, ) +import Data.IORef (newIORef, ) + + +initGHC :: FilePath -> IO Session +initGHC pkgDir = + do s <- newSession' CompManager (Just pkgDir) + modifySessionDynFlags s (\dflags -> dflags{ hscTarget = HscInterpreted }) + return s + + + +-- Like newSession, but does not install signal handlers +newSession' :: GhcMode -> Maybe FilePath -> IO Session +newSession' mode mb_top_dir = do + dflags0 <- initSysTools mb_top_dir defaultDynFlags + dflags <- initDynFlags dflags0 + env <- newHscEnv dflags{ ghcMode=mode } + ref <- newIORef env + return (Session ref) + +setLogAction :: Session -> (String -> IO ()) -> IO () +setLogAction s f = + modifySessionDynFlags s (\dflags -> dflags { log_action = mkLogAction f }) + +mkLogAction :: (String -> IO ()) + -> Severity -> SrcSpan -> PprStyle -> Message -> IO () +mkLogAction f severity srcSpan style msg = + case severity of + SevInfo -> f (show (msg style)) + SevFatal -> f (show (msg style)) + _ -> f (show ((mkLocMessage srcSpan msg) style)) + + +modifySessionDynFlags :: Session -> (DynFlags -> DynFlags) -> IO () +modifySessionDynFlags s f = + do dflags <- getSessionDynFlags s + setSessionDynFlags s (f dflags) + return () + +withCleanUp :: Session -> IO a -> IO a +withCleanUp s f = + do dflags <- getSessionDynFlags s + defaultCleanupHandler dflags f + +loadFile :: Session -> FilePath -> IO GHC.Module +loadFile s file = + do let t = Target (TargetFile file Nothing) Nothing + setTargets s [t] + success <- load s LoadAllTargets + case success of + Succeeded -> do m <- fileModule s file + setContext s [] [m] + return m + Failed -> fail $ "Failed to load " ++ show file + +fileModule :: Session -> FilePath -> IO GHC.Module +fileModule s f = + do gr <- getModuleGraph s + case [ms_mod ms | ms <- gr, ml_hs_file (ms_location ms) == Just f] of + [m] -> return m + _ -> fail $ "File " ++ f ++ " does not correspond to a module" + +getValue :: Typeable a => Session -> String -> IO a +getValue s x = + do mdyn <- dynCompileExpr s x + case mdyn of + Nothing -> fail $ "dynCompileExpr " ++ show x ++ " failed" + Just dyn -> case fromDynamic dyn of + Nothing -> fail $ "Type error: " ++ x + ++ " is an " ++ show dyn + Just y -> return y + +getFileValue :: Typeable a => Session -> FilePath -> String -> IO a +getFileValue s file x = + do loadFile s file + getValue s x diff --git a/mohws.cabal b/mohws.cabal --- a/mohws.cabal +++ b/mohws.cabal @@ -1,9 +1,10 @@ +Cabal-Version: 2.2 Name: mohws -Version: 0.2.1.6 +Version: 0.2.1.7 Author: Simon Marlow, Bjorn Bringert Copyright: Simon Marlow, Bjorn Bringert Maintainer: Henning Thielemann -License: BSD3 +License: BSD-3-Clause License-file: LICENSE Category: Web Synopsis: Modular Haskell Web Server @@ -13,7 +14,6 @@ Homepage: http://code.haskell.org/mohws/ Tested-with: GHC==6.8.2 Build-Type: Simple -Cabal-Version: >=1.6 Data-Files: README @@ -28,7 +28,7 @@ Source-Repository this Type: darcs Location: http://code.haskell.org/mohws/ - Tag: 0.2.1.6 + Tag: 0.2.1.7 Flag dynamic description: Build server with dynamically loaded plugins @@ -53,9 +53,11 @@ explicit-exception >=0.1 && <0.2, data-accessor >=0.2 && <0.3, directory >=1.0 && <1.4, + fail >=4.9 && <4.10, -- base-4.3 need for Exception.mask base >=4.3 && <5 + Default-Language: Haskell98 Hs-Source-dirs: src GHC-Options: -Wall Exposed-Modules: @@ -98,13 +100,16 @@ Network.MoHWS.ParserUtility Network.MoHWS.Server.Environment Network.MoHWS.ByteString - -- it's needed for linking parallelweb, but it hurts haddock Paths_mohws + Autogen-Modules: + Paths_mohws Executable hws Main-is: Main.hs - Hs-Source-dirs: src + Hs-Source-dirs: demo + Default-Language: Haskell98 Ghc-Options: -threaded -Wall + Build-Depends: mohws, bytestring, base Executable hws-dyn If flag(dynamic) @@ -112,9 +117,11 @@ -- ghc package needed for GHCUtil in DynHS Else Buildable: False - Main-is: MainDynamic.hs - Hs-Source-dirs: src + Default-Language: Haskell98 Ghc-Options: -threaded -Wall + Build-Depends: mohws, bytestring, base + Main-is: MainDynamic.hs + Hs-Source-dirs: demo Other-Modules: Network.MoHWS.Part.DynHS Network.MoHWS.Part.DynHS.CGI diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Main where - -import qualified Network.MoHWS.Server as Server -import qualified Network.MoHWS.Initialization as Init -import qualified Network.MoHWS.Initialization.Standard as Std -import qualified Data.ByteString.Lazy.Char8 as B - -main :: IO () -main = - Server.main (Std.init :: Init.T B.ByteString Std.Extension) diff --git a/src/MainDynamic.hs b/src/MainDynamic.hs deleted file mode 100644 --- a/src/MainDynamic.hs +++ /dev/null @@ -1,69 +0,0 @@ -module Main where - -import qualified Network.MoHWS.Server as Server - -import qualified Network.MoHWS.Module.Description as ModuleDesc -import qualified Network.MoHWS.Stream as Stream -import qualified Network.MoHWS.Initialization as Init -import qualified Data.Accessor.Basic as Accessor -import qualified Data.ByteString.Lazy.Char8 as B - -import qualified Network.MoHWS.Part.UserDirectory as UserDir -import qualified Network.MoHWS.Part.VirtualHost as VirtualHost -import qualified Network.MoHWS.Part.AddSlash as AddSlash -import qualified Network.MoHWS.Part.Index as Index -import qualified Network.MoHWS.Part.CGI as CGI -import qualified Network.MoHWS.Part.DynHS as DynHS -import qualified Network.MoHWS.Part.File as File -import qualified Network.MoHWS.Part.Listing as Listing - -import Prelude hiding (init, ) - - -data Extension = - Extension { - userDir :: UserDir.Configuration, - virtualHost :: VirtualHost.Configuration, - addSlash :: AddSlash.Configuration, - index :: Index.Configuration, - cgi :: CGI.Configuration, - file :: File.Configuration, - listing :: Listing.Configuration - } - -lift :: - (partExt -> fullExt -> fullExt) -> (fullExt -> partExt) -> - ModuleDesc.T body partExt -> ModuleDesc.T body fullExt -lift set get = - ModuleDesc.lift (Accessor.fromSetGet set get) - -modules :: (Stream.C body) => [ModuleDesc.T body Extension] -modules = - lift (\x ext -> ext{userDir = x}) userDir UserDir.desc : - lift (\x ext -> ext{virtualHost = x}) virtualHost VirtualHost.desc : - lift (\x ext -> ext{addSlash = x}) addSlash AddSlash.desc : - lift (\x ext -> ext{index = x}) index Index.desc : - lift (\x ext -> ext{cgi = x}) cgi CGI.desc : - DynHS.desc : - lift (\x ext -> ext{file = x}) file File.desc : - lift (\x ext -> ext{listing = x}) listing Listing.desc : - [] - -init :: (Stream.C body) => Init.T body Extension -init = - Init.Cons { - Init.moduleList = modules, - Init.configurationExtensionDefault = - Extension - (error "uninitialized userDir extension") - (error "uninitialized virtualHost extension") - (error "uninitialized addSlash extension") - (error "uninitialized index extension") - (error "uninitialized cgi extension") - (error "uninitialized file extension") - (error "uninitialized listing extension") - } - -main :: IO () -main = - Server.main (init :: Init.T B.ByteString Extension) diff --git a/src/Network/MoHWS/Part/DynHS.hs b/src/Network/MoHWS/Part/DynHS.hs deleted file mode 100644 --- a/src/Network/MoHWS/Part/DynHS.hs +++ /dev/null @@ -1,103 +0,0 @@ --- Copyright 2006 Bjorn Bringert -module Network.MoHWS.Part.DynHS where - -import Network.MoHWS.Part.DynHS.GHCUtil - (Session, initGHC, setLogAction, withCleanUp, getFileValue, ) - -import qualified Network.MoHWS.Module.Description as ModuleDesc -import qualified Network.MoHWS.Module as Module -import qualified Network.MoHWS.HTTP.Header as Header -import qualified Network.MoHWS.HTTP.Response as Response -import qualified Network.MoHWS.Server.Request as ServerRequest -import qualified Network.MoHWS.Server.Context as ServerContext -import qualified Network.MoHWS.Stream as Stream -import Network.MoHWS.Server.Request (serverFilename, ) -import Network.MoHWS.Logger.Error (debug, logError, ) - -import Network.MoHWS.Configuration as Config - -import Control.Exception as Exception -import Control.Monad.Trans.Maybe (MaybeT(MaybeT), ) -import Control.Monad (liftM, mzero, ) -import Data.List (isSuffixOf, ) -import Data.Tuple.HT (mapFst, ) - - --- FIXME: keep this in config -packageDirectory :: FilePath -packageDirectory = "/usr/lib/ghc-6.8.2" -- last working version was 6.6 - - -desc :: (Stream.C body) => ModuleDesc.T body ext -desc = - ModuleDesc.empty { - ModuleDesc.name = "dynhs", - ModuleDesc.load = loadDynHS - } - -loadDynHS :: (Stream.C body) => - ServerContext.T ext -> IO (Module.T body) -loadDynHS st = - do s <- initGHC packageDirectory - dynhsLoadConfig s st - return $ - Module.empty { - Module.handleRequest = dynhsHandleRequest s st - } - -dynhsLoadConfig :: Session -> ServerContext.T ext -> IO () -dynhsLoadConfig s st = setLogAction s (logError st) - -dynhsHandleRequest :: (Stream.C body) => - Session -> ServerContext.T ext -> ServerRequest.T body -> MaybeT IO (Response.T body) -dynhsHandleRequest s st sreq = - if ".hs" `isSuffixOf` serverFilename sreq - then dynhsHandleRequest2 s st sreq - else mzero - -dynhsHandleRequest2 :: (Stream.C body) => - Session -> ServerContext.T ext -> ServerRequest.T body -> MaybeT IO (Response.T body) -dynhsHandleRequest2 s st sreq = - MaybeT $ withCleanUp s $ --- FIXME: lots of fake stuff here - do debug st $ "DynHS: Loading " ++ show (serverFilename sreq) - e_cgiMain <- logGHCErrors s st (getCgiMain s (serverFilename sreq)) - case e_cgiMain of - Left resp -> return $ Just resp - Right cgiMain -> - do debug st $ "DynHS: Loaded successfully: " ++ show (serverFilename sreq) - liftM Just $ runCgiMain st sreq cgiMain - -type CGIMain = [(String,String)] -> [(String,String)] -> IO ([(String,String)], String) - -getCgiMain :: Session -> FilePath -> IO CGIMain -getCgiMain s file = getFileValue s file "cgiMain" - -runCgiMain :: (Stream.C body) => - ServerContext.T ext -> ServerRequest.T body -> CGIMain -> IO (Response.T body) -runCgiMain st _sreq cgiMain = - -- FIXME: lots of fake stuff here - do let env = [] - inputs = [] - (hs,content) <- cgiMain env inputs - let headers = - Header.group $ - map (uncurry Header.make . mapFst Header.makeName) hs - let code = 200 - descr = "OK" - return $ - Response.Cons code descr headers [] True $ - Response.bodyWithSizeFromString $ - Stream.fromString (Config.chunkSize (ServerContext.config st)) content - --- GHC utilities - -logGHCErrors :: (Stream.C body) => - Session -> ServerContext.T ext -> IO a -> IO (Either (Response.T body) a) -logGHCErrors _s st f = - liftM Right f - `Exception.catch` - (\e -> do logError st (show e) - -- FIXME: include error message in response - return $ Left $ Response.makeInternalServerError (ServerContext.config st)) - diff --git a/src/Network/MoHWS/Part/DynHS/CGI.hs b/src/Network/MoHWS/Part/DynHS/CGI.hs deleted file mode 100644 --- a/src/Network/MoHWS/Part/DynHS/CGI.hs +++ /dev/null @@ -1,48 +0,0 @@ -module Network.MoHWS.Part.DynHS.CGI where - -import Network.MoHWS.Part.CGI (mkCGIEnv, mkCGIResponse, ) - -import qualified Network.MoHWS.HTTP.Response as Response -import qualified Network.MoHWS.HTTP.Request as Request -import qualified Network.MoHWS.Server.Request as ServerRequest -import qualified Network.MoHWS.Server.Context as ServerContext -import ServerRequest (clientRequest, ) - -import qualified Data.ByteString.Lazy.Char8 as BS -import Data.ByteString.Lazy.Char8 (ByteString) -import qualified Data.Map as Map -import Data.Maybe (isJust) - -import Network.CGI.Monad (CGI, runCGIT, ) -import Network.CGI.Protocol - - -hwsRunCGI :: ServerContext.T ext -> ServerRequest.T -> CGI CGIResult -> IO (Response.T String) -hwsRunCGI st sreq cgi = - do let path_info = "" -- FIXME: do the path walk - env <- mkCGIEnv st sreq path_info - let input = BS.pack $ Request.body $ clientRequest sreq - (hs,body) <- runCGI_ env input (runCGIT cgi) - mkCGIResponse hs (BS.unpack body) - --- | Run a CGI action. This is what runCGIEnvFPS really should look like. -runCGI_ :: Monad m => - [(String,String)] -- ^ CGI environment variables. - -> ByteString -- ^ Request body. - -> (CGIRequest -> m (Header.Group, CGIResult)) -- ^ CGI action. - -> m (Header.Group, ByteString) -- ^ (Response.T String) (headers and content). -runCGI_ vars inp f - = do (hs,outp) <- f $ CGIRequest { - cgiVars = Map.fromList vars, - cgiInputs = decodeInput vars inp, - cgiRequestBody = inp - } - return $ case outp of - CGIOutput c -> (hs',c) - where hs' = if isJust (lookup ct hs) - then hs else hs ++ [(ct,defaultContentType)] - ct = HeaderName "Content-type" - CGINothing -> (hs, BS.empty) - -defaultContentType :: String -defaultContentType = "text/html; charset=ISO-8859-1" diff --git a/src/Network/MoHWS/Part/DynHS/GHCUtil.hs b/src/Network/MoHWS/Part/DynHS/GHCUtil.hs deleted file mode 100644 --- a/src/Network/MoHWS/Part/DynHS/GHCUtil.hs +++ /dev/null @@ -1,98 +0,0 @@ -module Network.MoHWS.Part.DynHS.GHCUtil - (Session, - initGHC, - setLogAction, - withCleanUp, - getFileValue, - -- * Error logging - Severity(..), SrcSpan, PprStyle, Message, - mkLocMessage - ) where - --- GHC API stuff -import DynFlags (initDynFlags, defaultDynFlags, ) -import ErrUtils (Message, mkLocMessage, ) -import GHC -import HscMain (newHscEnv, ) -import HscTypes (Session(..), ) -import Outputable (PprStyle, ) -import SrcLoc (SrcSpan, ) -import SysTools (initSysTools, ) - -import Data.Dynamic (Typeable, fromDynamic, ) -import Data.IORef (newIORef, ) - - -initGHC :: FilePath -> IO Session -initGHC pkgDir = - do s <- newSession' CompManager (Just pkgDir) - modifySessionDynFlags s (\dflags -> dflags{ hscTarget = HscInterpreted }) - return s - - - --- Like newSession, but does not install signal handlers -newSession' :: GhcMode -> Maybe FilePath -> IO Session -newSession' mode mb_top_dir = do - dflags0 <- initSysTools mb_top_dir defaultDynFlags - dflags <- initDynFlags dflags0 - env <- newHscEnv dflags{ ghcMode=mode } - ref <- newIORef env - return (Session ref) - -setLogAction :: Session -> (String -> IO ()) -> IO () -setLogAction s f = - modifySessionDynFlags s (\dflags -> dflags { log_action = mkLogAction f }) - -mkLogAction :: (String -> IO ()) - -> Severity -> SrcSpan -> PprStyle -> Message -> IO () -mkLogAction f severity srcSpan style msg = - case severity of - SevInfo -> f (show (msg style)) - SevFatal -> f (show (msg style)) - _ -> f (show ((mkLocMessage srcSpan msg) style)) - - -modifySessionDynFlags :: Session -> (DynFlags -> DynFlags) -> IO () -modifySessionDynFlags s f = - do dflags <- getSessionDynFlags s - setSessionDynFlags s (f dflags) - return () - -withCleanUp :: Session -> IO a -> IO a -withCleanUp s f = - do dflags <- getSessionDynFlags s - defaultCleanupHandler dflags f - -loadFile :: Session -> FilePath -> IO GHC.Module -loadFile s file = - do let t = Target (TargetFile file Nothing) Nothing - setTargets s [t] - success <- load s LoadAllTargets - case success of - Succeeded -> do m <- fileModule s file - setContext s [] [m] - return m - Failed -> fail $ "Failed to load " ++ show file - -fileModule :: Session -> FilePath -> IO GHC.Module -fileModule s f = - do gr <- getModuleGraph s - case [ms_mod ms | ms <- gr, ml_hs_file (ms_location ms) == Just f] of - [m] -> return m - _ -> fail $ "File " ++ f ++ " does not correspond to a module" - -getValue :: Typeable a => Session -> String -> IO a -getValue s x = - do mdyn <- dynCompileExpr s x - case mdyn of - Nothing -> fail $ "dynCompileExpr " ++ show x ++ " failed" - Just dyn -> case fromDynamic dyn of - Nothing -> fail $ "Type error: " ++ x - ++ " is an " ++ show dyn - Just y -> return y - -getFileValue :: Typeable a => Session -> FilePath -> String -> IO a -getFileValue s file x = - do loadFile s file - getValue s x diff --git a/src/Network/MoHWS/Utility.hs b/src/Network/MoHWS/Utility.hs --- a/src/Network/MoHWS/Utility.hs +++ b/src/Network/MoHWS/Utility.hs @@ -38,6 +38,7 @@ import Control.Concurrent (newEmptyMVar, takeMVar, ) import Control.Monad (liftM, ) import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT, ) +import Control.Monad.Fail (MonadFail) import Data.Maybe.HT (toMaybe, ) import Data.Maybe (fromMaybe, ) import Data.Tuple.HT (mapSnd, ) @@ -76,10 +77,10 @@ ----------------------------------------------------------------------------- -- String utils -readM :: (Read a, Monad m) => String -> m a +readM :: (Read a, MonadFail m) => String -> m a readM s = readSM reads s -readSM :: Monad m => ReadS a -> String -> m a +readSM :: (MonadFail m) => ReadS a -> String -> m a readSM f s = case f s of [] -> fail $ "No parse of " ++ show s