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
serveHTTP :: Maybe FilePath
-> Int
-> S.ByteString
-> (Request -> Path)
-> 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 ()
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 ]
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 ]
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+len1)
return . Just $ insertField FkContentRange rangeSpec $ response st val len ct modified
Just st ->
return . Just $ response st L.empty 0 ct modified
_ -> return Nothing
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
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 []