module Network.Web.Server.Basic (basicServer,
module Network.Web.Server.Params) where
import Control.Applicative
import Control.Monad
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
import Data.List
import Data.Time
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
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 uri = reqURI req
langs = map ('.':) (languages req) ++ ["",".en"]
runAnyIO [ tryGet cnf req uri langs
, tryRedirect cnf uri langs
, notFound ]
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
, notFound ]
processPOST :: BasicConfig -> Request -> IO Response
processPOST = tryPost
languages :: Request -> [String]
languages req = maybe [] (parseLang . S.unpack) $ lookupField FkAcceptLanguage req
(>>|) :: 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
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 -> URI -> [String] -> IO (Maybe Response)
tryGet cnf req uri langs = tryGet' $ mapper cnf uri
where
tryGet' None = return Nothing
tryGet' (File file) = tryGetFile cnf req file langs
tryGet' (PathCGI cgi) = tryGetCGI cnf req cgi
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 = do
let file' = file ++ lang
info cnf file' |>| \(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
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)
return . Just $ 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 -> URI -> [String] -> IO (Maybe Response)
tryHead cnf uri langs = tryHead' (mapper cnf uri)
where
tryHead' None = return Nothing
tryHead' (PathCGI _) = 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 (_,mt) -> return $ Just (responseOK ct (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 -> URI -> [String] -> IO (Maybe Response)
tryRedirect cnf uri langs =
redirectURI uri >>| \ruri -> tryRedirect' (mapper cnf ruri) ruri
where
tryRedirect' None _ = return Nothing
tryRedirect' (PathCGI _) _ = 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 (reqURI req) of
PathCGI cgi -> do
mres <- tryGetCGI cnf req cgi
case mres of
Nothing -> undefined
Just res -> return res
_ -> 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 -> HttpDate -> Response
responseOK ct modified = makeResponse2 OK (Just L.empty) (Just 0) 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 []