diff --git a/Network/Web/Params.hs b/Network/Web/Params.hs --- a/Network/Web/Params.hs +++ b/Network/Web/Params.hs @@ -143,7 +143,8 @@ {-| Field key of HTTP header. -} -data FieldKey = FkAcceptLanguage +data FieldKey = FkAccept + | FkAcceptLanguage | FkCacheControl | FkConnection | FkContentLength @@ -165,47 +166,29 @@ | FkOther S.ByteString deriving (Eq,Show,Ord) -fieldKeyList :: [FieldKey] -fieldKeyList = [ FkAcceptLanguage - , FkCacheControl - , FkConnection - , FkContentLength - , FkContentRange - , FkContentType - , FkCookie - , FkDate - , FkHost - , FkIfModifiedSince - , FkIfRange - , FkIfUnmodifiedSince - , FkLastModified - , FkLocation - , FkRange - , FkServer - , FkSetCookie2 - , FkStatus - , FkTransferEncoding ] - -fieldStringList :: [S.ByteString] -fieldStringList = [ "Accept-Language" - , "Cache-Control" - , "Connection" - , "Content-Length" - , "Content-Range" - , "Content-Type" - , "Cookie" - , "Date" - , "Host" - , "If-Modified-Since" - , "If-Range" - , "If-Unmodified-Since" - , "Last-Modified" - , "Location" - , "Range" - , "Server" - , "Set-Cookie2" - , "Status" - , "Transfer-Encoding" ] +fieldKeyStringList :: [(FieldKey, S.ByteString)] +fieldKeyStringList = + [ (FkAccept , "Accept") + , (FkAcceptLanguage , "Accept-Language") + , (FkCacheControl , "Cache-Control") + , (FkConnection , "Connection") + , (FkContentLength , "Content-Length") + , (FkContentRange , "Content-Range") + , (FkContentType , "Content-Type") + , (FkCookie , "Cookie") + , (FkDate , "Date") + , (FkHost , "Host") + , (FkIfModifiedSince , "If-Modified-Since") + , (FkIfRange , "If-Range") + , (FkIfUnmodifiedSince , "If-Unmodified-Since") + , (FkLastModified , "Last-Modified") + , (FkLocation , "Location") + , (FkRange , "Range") + , (FkServer , "Server") + , (FkSetCookie2 , "Set-Cookie2") + , (FkStatus , "Status") + , (FkTransferEncoding , "Transfer-Encoding" ) + ] {-| Field value of HTTP header. @@ -213,10 +196,12 @@ type FieldValue = S.ByteString stringFieldKey :: M.Map FieldValue FieldKey -stringFieldKey = M.fromList (zip fieldStringList fieldKeyList) +stringFieldKey = M.fromList (map swap fieldKeyStringList) + where + swap (a,b) = (b,a) fieldKeyString :: M.Map FieldKey FieldValue -fieldKeyString = M.fromList (zip fieldKeyList fieldStringList) +fieldKeyString = M.fromList fieldKeyStringList {-| Converting field key to 'FieldKey'. diff --git a/Network/Web/Server.hs b/Network/Web/Server.hs --- a/Network/Web/Server.hs +++ b/Network/Web/Server.hs @@ -1,6 +1,7 @@ {-| HTTP server library. -} +{-# OPTIONS -Wall #-} module Network.Web.Server (connection, WebServer, WebConfig(..)) where import Control.Applicative diff --git a/Network/Web/Server/Basic.hs b/Network/Web/Server/Basic.hs --- a/Network/Web/Server/Basic.hs +++ b/Network/Web/Server/Basic.hs @@ -8,16 +8,24 @@ CGI, chunked data for CGI output; -} -module Network.Web.Server.Basic (basicServer, +{-# OPTIONS -Wall #-} +module Network.Web.Server.Basic (serveHTTP, + basicServer, module Network.Web.Server.Params) where import Control.Applicative +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TChan +import Control.Exception (bracket) import Control.Monad import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import Data.List import Data.Maybe import Data.Time +import Network (withSocketsDo, PortID(..), sClose, listenOn) import Network.TCPInfo import Network.Web.Date import Network.Web.HTTP @@ -28,12 +36,89 @@ import Network.Web.Server.Range import Network.Web.URI import System.FilePath +import System.IO (openFile, IOMode(..), BufferMode(..), hPutStrLn, hSetBuffering, hClose, stderr) +import System.Directory (createDirectoryIfMissing) import Text.Printf + ---------------------------------------------------------------- {-| + Run an HTTP server, using a default BasicConfig. +-} +serveHTTP :: Maybe FilePath -- ^ Directory to write logfiles, "access.log" and "error.log". Will be created if it doesn't exist. + -- if Nothing, errors will be written to stderr + -> Int -- ^ HTTP port + -> S.ByteString -- ^ Server name + -> (Request -> Path) -- ^ site mapping function + -> IO () +serveHTTP m'logPath httpPort servName sitemap = do + (accHandler,errHandler,logwait) <- case m'logPath of + Nothing -> return (const (return ()), hPutStrLn stderr, return ()) + Just logPath -> do + createDirectoryIfMissing True logPath + acclogchan <- newTChanIO + accsync <- newEmptyMVar + errlogchan <- newTChanIO + errsync <- newEmptyMVar + let errlog = logPath "error.log" + acclog = logPath "access.log" + logwait = do + atomically $ writeTChan acclogchan Nothing + atomically $ writeTChan errlogchan Nothing + mapM_ takeMVar [accsync, errsync] + doAcc = atomically . writeTChan acclogchan . Just + doErr = atomically . writeTChan errlogchan . Just + + _ <- forkIO $ logger acclog acclogchan accsync + _ <- forkIO $ logger errlog errlogchan errsync + return (doAcc, doErr, logwait) + + let cfg = WebConfig { + closedHook = const $ return () + , accessHook = accHandler + , errorHook = errHandler + , fatalErrorHook = errHandler + , connectionTimer = 2 + } + topHandler tcpi = basicServer $ defaultConfig { + serverName = servName + , tcpInfo = tcpi + , mapper = sitemap + } + runserver = withSocketsDo $ do + sock <- listenOn (PortNumber $ fromIntegral httpPort) + void $ mainLoop sock + sClose sock + mainLoop sock = do + conn <- accept sock + void $ forkIO (runConn conn) + mainLoop sock + runConn (hndl,tcpi) = do + connection hndl (topHandler tcpi) cfg + runserver + logwait + +logger :: FilePath -> TChan (Maybe String) -> MVar () -> IO () +logger path chan sync = bracket opener closer go + where + opener = do + h <- openFile path AppendMode + hSetBuffering h LineBuffering + return h + closer h = do + hClose h + putMVar sync () + go h = do + val <- atomically $ readTChan chan + case val of + Just msg -> hPutStrLn h msg >> go h + Nothing -> hClose h >> putMVar sync () + +---------------------------------------------------------------- + +{-| Creating 'WebServer' with 'BasicConfig'. The created 'WebServer' can handle GET \/ HEAD \/ POST; OK, Not Found, Not Modified, Moved Permanently, etc; @@ -86,18 +171,16 @@ processGET :: BasicConfig -> Request -> IO Response processGET cnf req = do - let uri = reqURI req - langs = map ('.':) (languages req) ++ ["",".en"] - runAnyIO [ tryGet cnf req uri langs - , tryRedirect cnf uri langs + let langs = map ('.':) (languages req) ++ ["",".en"] + runAnyIO [ tryGet cnf req langs + , tryRedirect cnf req langs , notFound ] -- always Just processHEAD :: BasicConfig -> Request -> IO Response processHEAD cnf req = do - let uri = reqURI req - langs = map ('.':) (languages req) ++ ["",".en"] - runAnyIO [ tryHead cnf uri langs - , tryRedirect cnf uri langs + let langs = map ('.':) (languages req) ++ ["",".en"] + runAnyIO [ tryHead cnf req langs + , tryRedirect cnf req langs , notFound ] -- always Just processPOST :: BasicConfig -> Request -> IO Response @@ -108,24 +191,6 @@ ---------------------------------------------------------------- -(>>|) :: Maybe a -> (a -> IO (Maybe b)) -> IO (Maybe b) -v >>| act = - case v of - Nothing -> return Nothing - Just x -> act x - -(|>|) :: IO (Maybe a) -> (a -> IO (Maybe b)) -> IO (Maybe b) -a |>| act = do - v <- a - case v of - Nothing -> return Nothing - Just x -> act x - -(|||) :: Maybe Status -> Maybe Status -> Maybe Status -(|||) = mplus - ----------------------------------------------------------------- - ifModifiedSince :: Request -> Maybe UTCTime ifModifiedSince = lookupAndParseDate FkIfModifiedSince @@ -138,12 +203,13 @@ lookupAndParseDate :: FieldKey -> Request -> Maybe UTCTime lookupAndParseDate key req = lookupField key req >>= parseDate -tryGet :: BasicConfig -> Request -> URI -> [String] -> IO (Maybe Response) -tryGet cnf req uri langs = tryGet' $ mapper cnf uri +tryGet :: BasicConfig -> Request -> [String] -> IO (Maybe Response) +tryGet cnf req langs = tryGet' $ mapper cnf req where tryGet' None = return Nothing tryGet' (File file) = tryGetFile cnf req file langs tryGet' (PathCGI cgi) = tryGetCGI cnf req cgi + tryGet' (Handler hlr) = Just <$> hlr tryGetFile :: BasicConfig -> Request -> FilePath -> [String] -> IO (Maybe Response) tryGetFile cnf req file langs @@ -151,16 +217,19 @@ | otherwise = tryGetFile' cnf req file "" tryGetFile' :: BasicConfig -> Request -> FilePath -> String -> IO (Maybe Response) -tryGetFile' cnf req file lang = do - let file' = file ++ lang - info cnf file' |>| \(size, mtime) -> do +tryGetFile' cnf req file lang = info cnf file' >>= maybe (return Nothing) get + where + file' = file ++ lang + get (size, mtime) = do let ext = takeExtension file ct = selectContentType ext modified = utcToDate mtime - mst = ifmodified req size mtime - ||| ifunmodified req size mtime - ||| ifrange req size mtime - ||| unconditional req size mtime + mst = msum + [ ifmodified req size mtime + , ifunmodified req size mtime + , ifrange req size mtime + , unconditional req size mtime + ] case mst of Just OK -> do val <- obtain cnf file' Nothing @@ -206,11 +275,12 @@ ---------------------------------------------------------------- -tryHead :: BasicConfig -> URI -> [String] -> IO (Maybe Response) -tryHead cnf uri langs = tryHead' (mapper cnf uri) +tryHead :: BasicConfig -> Request -> [String] -> IO (Maybe Response) +tryHead cnf req langs = tryHead' (mapper cnf req) where tryHead' None = return Nothing tryHead' (PathCGI _) = return Nothing + tryHead' (Handler _) = return Nothing tryHead' (File file) = tryHeadFile cnf file langs tryHeadFile :: BasicConfig -> FilePath -> [String] -> IO (Maybe Response) @@ -237,12 +307,16 @@ then Nothing else Just uri { uriPath = path `S.append` "/" } -tryRedirect :: BasicConfig -> URI -> [String] -> IO (Maybe Response) -tryRedirect cnf uri langs = - redirectURI uri >>| \ruri -> tryRedirect' (mapper cnf ruri) ruri +tryRedirect :: BasicConfig -> Request -> [String] -> IO (Maybe Response) +tryRedirect cnf req langs = maybe (return Nothing) + (\ruri -> tryRedirect' (mapper cnf $ rreq ruri) ruri) + (redirectURI uri) where + uri = reqURI req + rreq ruri = req {reqURI = ruri} tryRedirect' None _ = return Nothing tryRedirect' (PathCGI _) _ = return Nothing + tryRedirect' (Handler _) _ = return Nothing tryRedirect' (File file) ruri = runAnyMaybeIO $ map (tryRedirectFile cnf ruri file) langs tryRedirectFile :: BasicConfig -> URI -> FilePath -> String -> IO (Maybe Response) @@ -256,7 +330,7 @@ ---------------------------------------------------------------- tryPost :: BasicConfig -> Request -> IO Response -tryPost cnf req = case mapper cnf (reqURI req) of +tryPost cnf req = case mapper cnf req of -- never reached to undefined PathCGI cgi -> fromMaybe undefined <$> tryGetCGI cnf req cgi _ -> return responseBadRequest diff --git a/Network/Web/Server/Params.hs b/Network/Web/Server/Params.hs --- a/Network/Web/Server/Params.hs +++ b/Network/Web/Server/Params.hs @@ -1,17 +1,23 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS -Wall #-} module Network.Web.Server.Params where +import Control.Applicative ((<$>)) import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import Data.Time +import Data.Time.Clock.POSIX import Network.TCPInfo -import Network.Web.URI +import Network.Web.HTTP +import System.Posix.Files {-| The configuration for the basic web server. -} data BasicConfig = BasicConfig { -- | A mapper from 'URI' to 'Path'. - mapper :: URI -> Path + mapper :: Request -> Path -- | Resource obtaining function. The second argument is -- (offset of the resource, and length from the offset). , obtain :: FilePath -> Maybe (Integer,Integer) -> IO L.ByteString @@ -25,6 +31,19 @@ } {-| + Default 'BasicConfig', with 'obtain', 'info', and 'serverName' filled in. + It is necessary to override the 'mapper' and 'tcpInfo' fields +-} +defaultConfig :: BasicConfig +defaultConfig = BasicConfig + { mapper = error "BasicConfig: no mapper defined" + , obtain = defaultObtain + , info = defaultInfo + , serverName = "BasicConfig: no server name" + , tcpInfo = error "BasicConfig: no TCPInfo" + } + +{-| Control information of how to handle 'URI'. -} data Path = @@ -34,13 +53,26 @@ | File FilePath -- | 'URI' is converted into CGI. | PathCGI CGI - deriving (Eq,Show) + -- | 'URI' is converted into a handler callback + | Handler (IO Response) +instance Eq Path where + (File fp1) == (File fp2) = fp1 == fp2 + (PathCGI cgi1) == (PathCGI cgi2) = cgi1 == cgi2 + None == None = True + _ == _ = False + +instance Show Path where + show None = "None" + show (File fp) = "File " ++ show fp + show (PathCGI cgi) = "PathCGI (" ++ show cgi ++ ")" + show (Handler _) = "Handler" + {-| Internal information of CGI converted from 'URI'. -} data CGI = CGI { - -- | A porgram path to be executed. + -- | A program path to be executed. progPath :: FilePath -- | A script name. , scriptName :: String @@ -49,3 +81,23 @@ -- | A query string. , queryString :: String } deriving (Eq,Show) + +-- | Get the size and modification time of a file, if possible. +defaultInfo :: FilePath -> IO (Maybe (Integer, UTCTime)) +defaultInfo fp = do + exists <- fileExist fp + if exists + then do + status <- getFileStatus fp + let size = fromIntegral $ fileSize status + mt = posixSecondsToUTCTime . realToFrac $ modificationTime status + return $ Just (size,mt) + else return Nothing + +-- | Obtain a data slice from a file as a lazy bytestring. +defaultObtain :: FilePath -> Maybe (Integer,Integer) -> IO L.ByteString +defaultObtain fp Nothing = L.readFile fp +defaultObtain fp (Just (offset,numBytes)) = L.take nb . L.drop ofs <$> L.readFile fp + where + nb = fromIntegral numBytes + ofs = fromIntegral offset diff --git a/webserver.cabal b/webserver.cabal --- a/webserver.cabal +++ b/webserver.cabal @@ -1,5 +1,5 @@ Name: webserver -Version: 0.5.1.0 +Version: 0.6.0.0 Author: Kazu Yamamoto Maintainer: John W. Lato License: BSD3 @@ -25,7 +25,8 @@ Network.Web.Server.Params Network.Web.Server.Range Build-Depends: base >= 4 && < 5, parsec >= 3, - network, bytestring, containers, old-locale, + network, directory, bytestring, containers, old-locale, + stm, filepath, time, unix, process, c10k Source-Repository head Type: git