mohws 0.2.1.6 → 0.2.1.7
raw patch · 12 files changed
+346/−338 lines, 12 filesdep +faildep +mohwsdep ~basedep ~bytestringPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: fail, mohws
Dependency ranges changed: base, bytestring
API changes (from Hackage documentation)
- Network.MoHWS.HTTP.Response: bodyFromString :: (C body) => body -> Body body
+ Network.MoHWS.HTTP.Response: bodyFromString :: C body => body -> Body body
- Network.MoHWS.HTTP.Response: bodyWithSizeFromString :: (C body) => body -> Body body
+ Network.MoHWS.HTTP.Response: bodyWithSizeFromString :: C body => body -> Body body
- Network.MoHWS.HTTP.Response: generateErrorPage :: (C body) => Int -> T ext -> Body body
+ Network.MoHWS.HTTP.Response: generateErrorPage :: C body => Int -> T ext -> Body body
- Network.MoHWS.HTTP.Response: hasBody :: (C body) => Body body -> Bool
+ Network.MoHWS.HTTP.Response: hasBody :: C body => Body body -> Bool
- Network.MoHWS.HTTP.Response: makeAccepted :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeAccepted :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeBadGateway :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeBadGateway :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeBadRequest :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeBadRequest :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeConflict :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeConflict :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeCont :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeCont :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeCreated :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeCreated :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeError :: (C body) => Int -> T ext -> T body
+ Network.MoHWS.HTTP.Response: makeError :: C body => Int -> T ext -> T body
- Network.MoHWS.HTTP.Response: makeExpectationFailed :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeExpectationFailed :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeForbidden :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeForbidden :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeFound :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeFound :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeGatewayTimeOut :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeGatewayTimeOut :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeGone :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeGone :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeInternalServerError :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeInternalServerError :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeLengthRequired :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeLengthRequired :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeMethodNotAllowed :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeMethodNotAllowed :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeMultipleChoices :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeMultipleChoices :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeNoContent :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeNoContent :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeNonAuthoritiveInformation :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeNonAuthoritiveInformation :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeNotAcceptable :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeNotAcceptable :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeNotFound :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeNotFound :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeNotImplemented :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeNotImplemented :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeNotModified :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeNotModified :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makePartialContent :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makePartialContent :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makePaymentRequired :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makePaymentRequired :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makePreconditionFailed :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makePreconditionFailed :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeProxyAuthenticationRequired :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeProxyAuthenticationRequired :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeRequestEntityTooLarge :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeRequestEntityTooLarge :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeRequestTimeOut :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeRequestTimeOut :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeRequestURITooLarge :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeRequestURITooLarge :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeRequestedRangeNotSatisfiable :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeRequestedRangeNotSatisfiable :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeResetContent :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeResetContent :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeSeeOther :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeSeeOther :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeServiceUnavailable :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeServiceUnavailable :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeSwitchingProtocols :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeSwitchingProtocols :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeTemporaryRedirect :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeTemporaryRedirect :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeUnauthorized :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeUnauthorized :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeUnsupportedMediaType :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeUnsupportedMediaType :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeUseProxy :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeUseProxy :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: makeVersionNotSupported :: (C body) => T ext -> T body
+ Network.MoHWS.HTTP.Response: makeVersionNotSupported :: C body => T ext -> T body
- Network.MoHWS.HTTP.Response: sendBody :: (C body) => Handle -> Body body -> IO ()
+ Network.MoHWS.HTTP.Response: sendBody :: C body => Handle -> Body body -> IO ()
- Network.MoHWS.HTTP.Response: sendBodyChunked :: (C body) => Int -> Handle -> Body body -> IO ()
+ Network.MoHWS.HTTP.Response: sendBodyChunked :: C body => Int -> Handle -> Body body -> IO ()
- Network.MoHWS.Initialization.Standard: init :: (C body) => T body Extension
+ Network.MoHWS.Initialization.Standard: init :: C body => T body Extension
- Network.MoHWS.Logger.Error: abort :: (HasHandle h) => h -> String -> MaybeT IO a
+ Network.MoHWS.Logger.Error: abort :: HasHandle h => h -> String -> MaybeT IO a
- Network.MoHWS.Logger.Error: debugOnAbort :: (HasHandle h) => h -> String -> MaybeT IO a -> MaybeT IO a
+ Network.MoHWS.Logger.Error: debugOnAbort :: HasHandle h => h -> String -> MaybeT IO a -> MaybeT IO a
- Network.MoHWS.Logger.Error: logDebug :: (HasHandle h) => h -> String -> IO ()
+ Network.MoHWS.Logger.Error: logDebug :: HasHandle h => h -> String -> IO ()
- Network.MoHWS.Logger.Error: logError :: (HasHandle h) => h -> String -> IO ()
+ Network.MoHWS.Logger.Error: logError :: HasHandle h => h -> String -> IO ()
- Network.MoHWS.Logger.Error: logInfo :: (HasHandle h) => h -> String -> IO ()
+ Network.MoHWS.Logger.Error: logInfo :: HasHandle h => h -> String -> IO ()
- Network.MoHWS.Module: Cons :: HostName -> Bool -> String -> String -> MaybeT IO FilePath -> T body -> IO (T body) -> T body -> MaybeT IO (T body) -> T body
+ Network.MoHWS.Module: Cons :: (HostName -> Bool) -> (String -> String -> MaybeT IO FilePath) -> (T body -> IO (T body)) -> (T body -> MaybeT IO (T body)) -> T body
- Network.MoHWS.Module.Description: Cons :: String -> T ext -> IO (T body) -> T () ext -> ext -> ext -> T body ext
+ Network.MoHWS.Module.Description: Cons :: String -> (T ext -> IO (T body)) -> T () ext -> (ext -> ext) -> T body ext
- Network.MoHWS.Part.AddSlash: desc :: (C body) => T body Configuration
+ Network.MoHWS.Part.AddSlash: desc :: C body => T body Configuration
- Network.MoHWS.Part.CGI: desc :: (C body) => T body Configuration
+ Network.MoHWS.Part.CGI: desc :: C body => T body Configuration
- Network.MoHWS.Part.File: desc :: (C body) => T body Configuration
+ Network.MoHWS.Part.File: desc :: C body => T body Configuration
- Network.MoHWS.Part.Listing: desc :: (C body) => T body Configuration
+ Network.MoHWS.Part.Listing: desc :: C body => T body Configuration
- Network.MoHWS.Server: main :: (C body) => T body ext -> IO ()
+ Network.MoHWS.Server: main :: C body => T body ext -> IO ()
- Network.MoHWS.Server: mainWithOptions :: (C body) => T body ext -> T -> IO ()
+ Network.MoHWS.Server: mainWithOptions :: C body => T body ext -> T -> IO ()
Files
- demo/Main.hs +10/−0
- demo/MainDynamic.hs +69/−0
- demo/Network/MoHWS/Part/DynHS.hs +103/−0
- demo/Network/MoHWS/Part/DynHS/CGI.hs +48/−0
- demo/Network/MoHWS/Part/DynHS/GHCUtil.hs +98/−0
- mohws.cabal +15/−8
- src/Main.hs +0/−10
- src/MainDynamic.hs +0/−69
- src/Network/MoHWS/Part/DynHS.hs +0/−103
- src/Network/MoHWS/Part/DynHS/CGI.hs +0/−48
- src/Network/MoHWS/Part/DynHS/GHCUtil.hs +0/−98
- src/Network/MoHWS/Utility.hs +3/−2
+ demo/Main.hs view
@@ -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)
+ demo/MainDynamic.hs view
@@ -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)
+ demo/Network/MoHWS/Part/DynHS.hs view
@@ -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))+
+ demo/Network/MoHWS/Part/DynHS/CGI.hs view
@@ -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"
+ demo/Network/MoHWS/Part/DynHS/GHCUtil.hs view
@@ -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
mohws.cabal view
@@ -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 <bjorn@bringert.net> Copyright: Simon Marlow, Bjorn Bringert Maintainer: Henning Thielemann <webserver@henning-thielemann.de>-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
− src/Main.hs
@@ -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)
− src/MainDynamic.hs
@@ -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)
− src/Network/MoHWS/Part/DynHS.hs
@@ -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))-
− src/Network/MoHWS/Part/DynHS/CGI.hs
@@ -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"
− src/Network/MoHWS/Part/DynHS/GHCUtil.hs
@@ -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
src/Network/MoHWS/Utility.hs view
@@ -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