webserver 0.5.1.0 → 0.6.0.0

raw patch · 5 files changed

+205/−92 lines, 5 filesdep +directorydep +stmPVP ok

version bump matches the API change (PVP)

Dependencies added: directory, stm

API changes (from Hackage documentation)

Files

• Network/Web/Params.hs +29/−44
• Network/Web/Server.hs +1/−0
• Network/Web/Server/Basic.hs +116/−42
• Network/Web/Server/Params.hs +56/−4
• webserver.cabal +3/−2

@@ -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'.

@@ -1,6 +1,7 @@ {-|   HTTP server library. -}+{-# OPTIONS -Wall #-} module Network.Web.Server (connection, WebServer, WebConfig(..)) where  import Control.Applicative

@@ -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

@@ -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

@@ -1,5 +1,5 @@ Name:                   webserver-Version:                0.5.1.0+Version:                0.6.0.0 Author:                 Kazu Yamamoto <kazu@iij.ad.jp> Maintainer:             John W. Lato <jwlato@gmail.com> 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