#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)
#endif
module Data.IterIO.HttpRoute
(HttpRoute(..)
, runHttpRoute, addHeader
, routeConst, routeFn, routeReq
, routeMethod, routeHost, routeTop
, HttpMap, routeMap, routeAlwaysMap, routeName, routePath, routeVar
, mimeTypesI, dirRedir, routeFileSys, FileSystemCalls(..), routeGenFileSys
) where
import Control.Monad
import Control.Monad.Trans
import Data.Char (toLower)
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid
import Data.Time (UTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import System.FilePath
import System.IO
import System.IO.Error (isDoesNotExistError)
import System.Posix.Files
import System.Posix.IO
import System.Posix.Types
import Data.IterIO
import Data.IterIO.Http
import Data.IterIO.Parse
newtype HttpRoute m s =
HttpRoute (HttpReq s -> Maybe (Iter L.ByteString m (HttpResp m)))
runHttpRoute :: (Monad m) =>
HttpRoute m s -> HttpReq s -> Iter L.ByteString m (HttpResp m)
runHttpRoute (HttpRoute route) rq = fromMaybe (return $ resp404 rq) $ route rq
instance Monoid (HttpRoute m s) where
mempty = HttpRoute $ const Nothing
mappend (HttpRoute a) (HttpRoute b) =
HttpRoute $ \req -> a req `mplus` b req
popPath :: Bool -> HttpReq s -> HttpReq s
popPath isParm req =
case reqPathLst req of
h:t -> req { reqPathLst = t
, reqPathCtx = reqPathCtx req ++ [h]
, reqPathParams = if isParm then h : reqPathParams req
else reqPathParams req
}
_ -> error "Data.IterIO.Http.popPath: empty path"
addHeader :: (Monad m) =>
(S8.ByteString, S8.ByteString) -> HttpRoute m s -> HttpRoute m s
addHeader h (HttpRoute r) = HttpRoute $ \req -> liftM (liftM addit) (r req)
where addit resp = resp { respHeaders = h : respHeaders resp }
routeConst :: (Monad m) => HttpResp m -> HttpRoute m s
routeConst resp = HttpRoute $ const $ Just $ return resp
routeFn :: (HttpReq s -> Iter L.ByteString m (HttpResp m)) -> HttpRoute m s
routeFn fn = HttpRoute $ Just . fn
routeReq :: (HttpReq s -> HttpRoute m s) -> HttpRoute m s
routeReq fn = HttpRoute $ \req ->
let (HttpRoute route) = fn req
in route req
routeTop :: HttpRoute m s -> HttpRoute m s
routeTop (HttpRoute route) = HttpRoute $ \req ->
if null $ reqPathLst req then route req
else Nothing
routeHost :: String
-> HttpRoute m s
-> HttpRoute m s
routeHost host (HttpRoute route) = HttpRoute check
where shost = S8.pack $ map toLower host
check req | reqHost req /= shost = Nothing
| otherwise = route req
routeMethod :: String
-> HttpRoute m s
-> HttpRoute m s
routeMethod method (HttpRoute route) = HttpRoute check
where smethod = S8.pack method
check req | reqMethod req /= smethod = Nothing
| otherwise = route req
type HttpMap m s = [(String, HttpRoute m s)]
routeMap :: HttpMap m s -> HttpRoute m s
routeMap lst = HttpRoute check
where
check req = case reqPathLst req of
h:_ -> maybe Nothing
(\(HttpRoute route) -> route $ popPath False req)
(Map.lookup h rmap)
_ -> Nothing
packfirst (a, b) = (S8.pack a, b)
rmap = Map.fromListWithKey nocombine $ map packfirst lst
nocombine k _ _ = error $ "routeMap: duplicate key for " ++ S8.unpack k
routeAlwaysMap :: (Monad m) => HttpMap m s -> HttpRoute m s
routeAlwaysMap lst = routeMap lst `mappend` routeFn (return . resp404)
routeName :: String -> HttpRoute m s -> HttpRoute m s
routeName name (HttpRoute route) = HttpRoute check
where sname = S8.pack name
headok (h:_) | h == sname = True
headok _ = False
check req | headok (reqPathLst req) = route $ popPath False req
check _ = Nothing
routePath :: String -> HttpRoute m s -> HttpRoute m s
routePath path route = foldr routeName route dirs
where dirs = case splitDirectories path of
"/":t -> t
t -> t
routeVar :: HttpRoute m s -> HttpRoute m s
routeVar (HttpRoute route) = HttpRoute check
where check req = case reqPathLst req of
_:_ -> route $ popPath True req
_ -> Nothing
mimeTypesI :: (Monad m) =>
String
-> Iter S8.ByteString m (String -> S8.ByteString)
mimeTypesI deftype = do
mmap <- Map.fromList <$> concatI ((mimeLine <|> nil) <* eol)
return $ \suffix -> maybe (S8.pack deftype) id $ Map.lookup suffix mmap
where
mimeLine = do
typ <- word
many $ do space; ext <- word; return (S8.unpack ext, typ)
word = while1I $ \c -> c > eord ' ' && c <= eord '~'
space = skipWhile1I $ \c -> c == eord ' ' || c == eord '\t'
comment = char '#' >> skipWhileI (/= eord '\n')
eol = do
optionalI space
optionalI comment
optionalI (char '\r'); char '\n'
data FileSystemCalls h m = FileSystemCalls {
fs_stat :: !(FilePath -> Iter L.ByteString m FileStatus)
, fs_open :: !(FilePath -> Iter L.ByteString m h)
, fs_close :: !(h -> Iter L.ByteString m ())
, fs_fstat :: !(h -> Iter L.ByteString m FileStatus)
, fs_enum :: !(h -> Iter L.ByteString m
(Onum L.ByteString m (IterR L.ByteString m ())))
}
defaultFileSystemCalls :: (MonadIO m) => FileSystemCalls Fd m
defaultFileSystemCalls = FileSystemCalls { fs_stat = liftIO . getFileStatus
, fs_open = liftIO . pathToFd
, fs_close = liftIO . closeFd
, fs_fstat = liftIO . getFdStatus
, fs_enum = liftIO . fdToOnum
}
where pathToFd path = openFd path ReadOnly Nothing defaultFileFlags
fdToOnum fd = do h <- fdToHandle fd
return $ enumHandle h `inumFinally` liftIO (hClose h)
dirRedir :: (Monad m) => FilePath -> FilePath -> HttpRoute m s
dirRedir index _path = routeFn $ \req -> return $
resp301 $ S8.unpack (reqNormalPath req) ++ '/':index
modTimeUTC :: FileStatus -> UTCTime
modTimeUTC = posixSecondsToUTCTime . realToFrac . modificationTime
routeFileSys :: (MonadIO m) =>
(String -> S8.ByteString)
-> (FilePath -> HttpRoute m s)
-> FilePath
-> HttpRoute m s
routeFileSys = routeGenFileSys defaultFileSystemCalls
routeGenFileSys :: (Monad m) =>
FileSystemCalls h m
-> (String -> S8.ByteString)
-> (FilePath -> HttpRoute m s)
-> FilePath
-> HttpRoute m s
routeGenFileSys fs typemap index dir0 = HttpRoute $ Just . check
where
dir = if null dir0 then "." else dir0
checkErr req e _ | isDoesNotExistError e = return $ resp404 req
| otherwise = return $ resp500 (show e)
check req = flip catchI (checkErr req) $ do
let path = dir ++ concatMap (('/' :) . S8.unpack) (reqPathLst req)
st <- fs_stat fs path
case () of
_ | isRegularFile st -> doFile req path st
| not (isDirectory st) -> return $ resp404 req
| otherwise -> runHttpRoute
(index path `mappend` routeConst (resp403 req)) req
doFile req path st
| reqMethod req == S8.pack "GET"
&& maybe True (< (modTimeUTC st)) (reqIfModifiedSince req) = do
fd <- fs_open fs path
st' <- fs_fstat fs fd `onExceptionI` fs_close fs fd
if isRegularFile st'
then do body <- fs_enum fs fd `onExceptionI` fs_close fs fd
return $ resp { respHeaders = mkHeaders req st'
, respBody = body }
else do fs_close fs fd
check req
| reqMethod req == S8.pack "GET" =
return $ resp { respStatus = stat304 }
| reqMethod req == S8.pack "HEAD" =
return $ resp { respStatus = stat200 }
| otherwise = return $ resp405 req
where resp = defaultHttpResp { respChunk = False
, respHeaders = mkHeaders req st }
mkHeaders req st =
[ (S8.pack "Last-Modified", S8.pack . http_fmt_time $ modTimeUTC st)
, (S8.pack "Content-Length", S8.pack . show $ fileSize st)
, (S8.pack "Content-Type", typemap (fileExt req)) ]
fileExt req =
drop 1 $ takeExtension $ case reqPathLst req of
[] -> dir
l -> S8.unpack $ last l