{-# LANGUAGE OverloadedStrings #-} {-| Creating basic 'WebServer'. Created 'WebServer' can handle GET \/ HEAD \/ POST; OK, Not Found, Not Modified, Moved Permanently, etc; partial getting; language negotication; CGI, chunked data for CGI output; -} {-# 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 import Network.Web.Server import Network.Web.Server.CGI import Network.Web.Server.Lang import Network.Web.Server.Params 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; partial getting; language negotication; CGI, chunked data for CGI output; If http:\/\/example.com\/path does not exist but http:\/\/example.com\/path\/ exists, the created 'WebServer' redirects it. http:\/\/example.com\/path\/ is mapped to \/somewhere\/path\/ by 'mapper' and index.html and index.html.en automatically added and try to read by 'obtain'. If Accept-Language is "xx" and "yy" in order, index.html.xx, index.html.yy, index.html and index.html.en are tried. The created 'WebServer' does not dynamically make index.html for a directory even if index.html does not exist for security reasons. -} basicServer :: BasicConfig -> WebServer basicServer cnf mreq = case mreq of Nothing -> adjust <$> pure responseBadRequest Just req -> case reqMethod req of GET -> adjust <$> processGET cnf req HEAD -> adjust <$> processHEAD cnf req POST -> adjust <$> processPOST cnf req _ -> adjust <$> pure responseNotImplement where adjust = addServer . addPeerToLog addServer = insertField FkServer (serverName cnf) addPeerToLog rsp = rsp { rspLogMsg = logmsg} peer = peerAddr (tcpInfo cnf) logmsg = "[" ++ peer ++ "] " ++ maybe "" uri mreq uri req = "\"" ++ (S.unpack . toURLwoPort . reqURI) req ++ "\"" ---------------------------------------------------------------- runAnyIO :: [IO (Maybe a)] -> IO a runAnyIO [] = error "runAnyIO" runAnyIO (a:as) = do mrsp <- a case mrsp of Nothing -> runAnyIO as Just rsp -> return rsp runAnyMaybeIO :: [IO (Maybe a)] -> IO (Maybe a) runAnyMaybeIO [] = return Nothing runAnyMaybeIO (a:as) = do mx <- a case mx of Nothing -> runAnyMaybeIO as Just _ -> return mx processGET :: BasicConfig -> Request -> IO Response processGET cnf req = do 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 langs = map ('.':) (languages req) ++ ["",".en"] runAnyIO [ tryHead cnf req langs , tryRedirect cnf req langs , notFound ] -- always Just processPOST :: BasicConfig -> Request -> IO Response processPOST = tryPost languages :: Request -> [String] languages req = maybe [] (parseLang . S.unpack) $ lookupField FkAcceptLanguage req ---------------------------------------------------------------- ifModifiedSince :: Request -> Maybe UTCTime ifModifiedSince = lookupAndParseDate FkIfModifiedSince ifUnmodifiedSince :: Request -> Maybe UTCTime ifUnmodifiedSince = lookupAndParseDate FkIfUnmodifiedSince ifRange :: Request -> Maybe UTCTime ifRange = lookupAndParseDate FkIfRange lookupAndParseDate :: FieldKey -> Request -> Maybe UTCTime lookupAndParseDate key req = lookupField key req >>= parseDate 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 | ".html" `isSuffixOf` file = runAnyMaybeIO $ map (tryGetFile' cnf req file) langs | otherwise = tryGetFile' cnf req file "" tryGetFile' :: BasicConfig -> Request -> FilePath -> String -> IO (Maybe Response) 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 = 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 return . Just $ response OK val size ct modified Just st@(PartialContent skip len) -> do val <- obtain cnf file' $ Just (skip,len) let rangeSpec = S.pack $ printf "bytes %d-%d/*" skip (skip+len-1) return . Just $ insertField FkContentRange rangeSpec $ response st val len ct modified Just st -> return . Just $ response st L.empty 0 ct modified _ -> return Nothing -- never reached ifmodified :: Request -> Integer -> UTCTime -> Maybe Status ifmodified req size mtime = do date <- ifModifiedSince req if date /= mtime then unconditional req size mtime else Just NotModified -- xxx rspBody should be Nothing ifunmodified :: Request -> Integer -> UTCTime -> Maybe Status ifunmodified req size mtime = do date <- ifUnmodifiedSince req if date == mtime then unconditional req size mtime else Just PreconditionFailed ifrange :: Request -> Integer -> UTCTime -> Maybe Status ifrange req size mtime = do date <- ifRange req rng <- lookupField FkRange req if date == mtime then Just OK else range size rng unconditional :: Request -> Integer -> UTCTime -> Maybe Status unconditional req size _ = maybe (Just OK) (range size) $ lookupField FkRange req range :: Integer -> S.ByteString -> Maybe Status range size rng = case skipAndSize (S.unpack rng) size of Nothing -> Just RequestedRangeNotSatisfiable Just (skip,len) -> Just (PartialContent skip len) ---------------------------------------------------------------- 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) tryHeadFile cnf file langs | ".html" `isSuffixOf` file = runAnyMaybeIO $ map (tryHeadFile' cnf file) langs | otherwise = tryHeadFile' cnf file "" tryHeadFile' :: BasicConfig -> FilePath -> String -> IO (Maybe Response) tryHeadFile' cnf file lang = do let ext = takeExtension file ct = selectContentType ext file' = file ++ lang minfo <- info cnf file' case minfo of Nothing -> return Nothing Just (size,mt) -> return $ Just (responseOK ct size (utcToDate mt)) ---------------------------------------------------------------- redirectURI :: URI -> Maybe URI redirectURI uri = let path = uriPath uri in if "/" `S.isSuffixOf` path then Nothing else Just uri { uriPath = path `S.append` "/" } 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) tryRedirectFile cnf ruri file lang = do let file' = file ++ lang minfo <- info cnf file' case minfo of Nothing -> return Nothing Just _ -> return $ Just (responseRedirect ruri) ---------------------------------------------------------------- tryPost :: BasicConfig -> Request -> IO Response tryPost cnf req = case mapper cnf req of PathCGI cgi -> fromMaybe undefined <$> tryGetCGI cnf req cgi Handler resp-> resp _ -> return responseBadRequest ---------------------------------------------------------------- notFound :: IO (Maybe Response) notFound = return $ Just responseNotFound ---------------------------------------------------------------- response :: Status -> L.ByteString -> Integer -> CT -> HttpDate -> Response response st val len ct modified = makeResponse2 st (Just val) (Just len) kvs where kvs = [(FkContentType,ct),(FkLastModified,modified)] ---------------------------------------------------------------- responseOK :: CT -> Integer -> HttpDate -> Response responseOK ct size modified = makeResponse2 OK (Just L.empty) (Just size) kvs where kvs = [(FkContentType,ct),(FkLastModified,modified)] responseRedirect :: URI -> Response responseRedirect rurl = makeResponse MovedPermanently [(FkLocation, toURL rurl)] responseNotFound :: Response responseNotFound = makeResponse NotFound [] ---------------------------------------------------------------- responseBadRequest :: Response responseBadRequest = makeResponse BadRequest [] responseNotImplement :: Response responseNotImplement = makeResponse NotImplemented []