module Web.Fn (
FnRequest
, defaultFnRequest
, RequestContext(..)
, toWAI
, Req
, Route
, route
, fallthrough
, (==>)
, (!=>)
, (//)
, (/?)
, path
, end
, anything
, segment
, method
, FromParam(..)
, ParamError(..)
, param
, paramMany
, paramOpt
, File(..)
, file
, files
, staticServe
, sendFile
, okText
, okHtml
, errText
, errHtml
, notFoundText
, notFoundHtml
, redirect
, redirectReferer
) where
import qualified Blaze.ByteString.Builder.Char.Utf8 as B
import Control.Applicative ((<$>))
import Control.Arrow (second)
import Control.Concurrent.MVar
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LB
import Data.Either (lefts, rights)
import qualified Data.HashMap.Strict as HM
import Data.Maybe (fromJust)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Text.Read (decimal, double)
import Network.HTTP.Types
import Network.Wai
import Network.Wai.Parse (FileInfo (..), Param,
lbsBackEnd,
parseRequestBody)
import qualified Network.Wai.Parse as Parse
import System.Directory (doesFileExist)
import System.FilePath (takeExtension)
data Store b a = Store b (b -> a)
instance Functor (Store b) where
fmap f (Store b h) = Store b (f . h)
type Route ctxt = ctxt -> Req -> IO (Maybe (IO (Maybe Response)))
type PostMVar = Maybe (MVar (Maybe ([Param], [Parse.File LB.ByteString])))
type FnRequest = (Request, PostMVar)
defaultFnRequest :: FnRequest
defaultFnRequest = (defaultRequest, Nothing)
class RequestContext ctxt where
requestLens :: Functor f => (FnRequest -> f FnRequest) -> ctxt -> f ctxt
requestLens f c = setRequest c <$> f (getRequest c)
getRequest :: ctxt -> FnRequest
getRequest c =
let (Store r _) = requestLens (`Store` id) c
in r
setRequest :: ctxt -> FnRequest -> ctxt
setRequest c r =
let (Store _ b) = requestLens (`Store` id) c
in b r
instance RequestContext FnRequest where
getRequest = id
setRequest _ = id
toWAI :: RequestContext ctxt => ctxt -> (ctxt -> IO Response) -> Application
toWAI ctxt f req cont =
do mv <- newMVar Nothing
f (setRequest ctxt (req, Just mv)) >>= cont
route :: RequestContext ctxt =>
ctxt ->
[Route ctxt] ->
IO (Maybe Response)
route ctxt pths =
do let (r,post) = getRequest ctxt
m = either (const GET) id (parseMethod (requestMethod r))
req = (filter (/= "") (pathInfo r), queryString r, m, post)
route' req pths
where route' _ [] = return Nothing
route' req (x:xs) =
do mact <- x ctxt req
case mact of
Nothing -> route' req xs
Just action ->
do resp <- action
case resp of
Nothing -> route' req xs
Just response -> return (Just response)
fallthrough :: IO (Maybe Response) -> IO Response -> IO Response
fallthrough a ft =
do response <- a
case response of
Nothing -> ft
Just r -> return r
mimeMap :: HM.HashMap String ByteString
mimeMap = HM.fromList [
( ".asc" , "text/plain" ),
( ".asf" , "video/x-ms-asf" ),
( ".asx" , "video/x-ms-asf" ),
( ".avi" , "video/x-msvideo" ),
( ".bz2" , "application/x-bzip" ),
( ".c" , "text/plain" ),
( ".class" , "application/octet-stream" ),
( ".conf" , "text/plain" ),
( ".cpp" , "text/plain" ),
( ".css" , "text/css" ),
( ".cxx" , "text/plain" ),
( ".dtd" , "text/xml" ),
( ".dvi" , "application/x-dvi" ),
( ".gif" , "image/gif" ),
( ".gz" , "application/x-gzip" ),
( ".hs" , "text/plain" ),
( ".htm" , "text/html" ),
( ".html" , "text/html" ),
( ".ico" , "image/x-icon" ),
( ".jar" , "application/x-java-archive" ),
( ".jpeg" , "image/jpeg" ),
( ".jpg" , "image/jpeg" ),
( ".js" , "text/javascript" ),
( ".json" , "application/json" ),
( ".log" , "text/plain" ),
( ".m3u" , "audio/x-mpegurl" ),
( ".mov" , "video/quicktime" ),
( ".mp3" , "audio/mpeg" ),
( ".mpeg" , "video/mpeg" ),
( ".mpg" , "video/mpeg" ),
( ".ogg" , "application/ogg" ),
( ".pac" , "application/x-ns-proxy-autoconfig" ),
( ".pdf" , "application/pdf" ),
( ".png" , "image/png" ),
( ".ps" , "application/postscript" ),
( ".qt" , "video/quicktime" ),
( ".sig" , "application/pgp-signature" ),
( ".spl" , "application/futuresplash" ),
( ".svg" , "image/svg+xml" ),
( ".swf" , "application/x-shockwave-flash" ),
( ".tar" , "application/x-tar" ),
( ".tar.bz2" , "application/x-bzip-compressed-tar" ),
( ".tar.gz" , "application/x-tgz" ),
( ".tbz" , "application/x-bzip-compressed-tar" ),
( ".text" , "text/plain" ),
( ".tgz" , "application/x-tgz" ),
( ".torrent" , "application/x-bittorrent" ),
( ".ttf" , "application/x-font-truetype" ),
( ".txt" , "text/plain" ),
( ".wav" , "audio/x-wav" ),
( ".wax" , "audio/x-ms-wax" ),
( ".wma" , "audio/x-ms-wma" ),
( ".wmv" , "video/x-ms-wmv" ),
( ".xbm" , "image/x-xbitmap" ),
( ".xml" , "text/xml" ),
( ".xpm" , "image/x-xpixmap" ),
( ".xwd" , "image/x-xwindowdump" ),
( ".zip" , "application/zip" ) ]
staticServe :: RequestContext ctxt => Text -> ctxt -> IO (Maybe Response)
staticServe d ctxt = do
let pth = T.intercalate "/" $ d : pathInfo (fst . getRequest $ ctxt)
if "/" `T.isPrefixOf` pth || ".." `T.isInfixOf` pth
then return Nothing
else sendFile (T.unpack pth)
sendFile :: FilePath -> IO (Maybe Response)
sendFile pth =
do exists <- doesFileExist pth
if exists
then do let ext = takeExtension pth
contentType = case HM.lookup ext mimeMap of
Nothing -> []
Just t -> [(hContentType, t)]
return $ Just $ responseFile status200
contentType
pth
Nothing
else return Nothing
type Req = ([Text], Query, StdMethod, PostMVar)
(==>) :: RequestContext ctxt =>
(Req -> IO (Maybe (Req, k -> a))) ->
(ctxt -> k) ->
ctxt ->
Req ->
IO (Maybe a)
(match ==> handle) ctxt req =
do rsp <- match req
case rsp of
Nothing -> return Nothing
Just ((pathInfo',_,_,_), k) ->
let (request, mv) = getRequest ctxt in
return $ Just (k $ handle (setRequest ctxt (request { pathInfo = pathInfo' }, mv)))
(!=>) :: RequestContext ctxt =>
(Req -> IO (Maybe (Req, k -> a))) ->
(ctxt -> k) ->
ctxt ->
Req ->
IO (Maybe a)
(match !=> handle) ctxt req =
do let (request, Just mv) = getRequest ctxt
modifyMVar_ mv (\r -> case r of
Nothing -> Just <$> parseRequestBody lbsBackEnd request
Just _ -> return r)
rsp <- match req
case rsp of
Nothing -> return Nothing
Just ((pathInfo',_,_,_), k) ->
do return $ Just (k $ handle (setRequest ctxt (request { pathInfo = pathInfo' }, Just mv)))
(//) :: (r -> IO (Maybe (r, k -> k'))) ->
(r -> IO (Maybe (r, k' -> a))) ->
r -> IO (Maybe (r, k -> a))
(match1 // match2) req = do
r1 <- match1 req
case r1 of
Nothing -> return Nothing
Just (req', k) ->
do r2 <- match2 req'
return $ case r2 of
Nothing -> Nothing
Just (req'', k') -> Just (req'', k' . k)
(/?) :: (r -> IO (Maybe (r, k -> k'))) ->
(r -> IO (Maybe (r, k' -> a))) ->
r -> IO (Maybe (r, k -> a))
(/?) = (//)
path :: Text -> Req -> IO (Maybe (Req, a -> a))
path s req =
return $ case req of
(y:ys,q,m,x) | y == s -> Just ((ys, q, m, x), id)
_ -> Nothing
end :: Req -> IO (Maybe (Req, a -> a))
end req =
return $ case req of
([],_,_,_) -> Just (req, id)
_ -> Nothing
anything :: Req -> IO (Maybe (Req, a -> a))
anything req = return $ Just (req, id)
segment :: FromParam p => Req -> IO (Maybe (Req, (p -> a) -> a))
segment req =
return $ case req of
(y:ys,q,m,x) -> case fromParam [y] of
Left _ -> Nothing
Right p -> Just ((ys, q, m, x), \k -> k p)
_ -> Nothing
method :: StdMethod -> Req -> IO (Maybe (Req, a -> a))
method m r@(_,_,m',_) | m == m' = return $ Just (r, id)
method _ _ = return Nothing
data ParamError = ParamMissing | ParamTooMany | ParamUnparsable | ParamOtherError Text deriving (Eq, Show)
class FromParam a where
fromParam :: [Text] -> Either ParamError a
instance FromParam Text where
fromParam [x] = Right x
fromParam [] = Left ParamMissing
fromParam _ = Left ParamTooMany
instance FromParam Int where
fromParam [t] = case decimal t of
Left _ -> Left ParamUnparsable
Right m | snd m /= "" ->
Left ParamUnparsable
Right (v, _) -> Right v
fromParam [] = Left ParamMissing
fromParam _ = Left ParamTooMany
instance FromParam Double where
fromParam [t] = case double t of
Left _ -> Left ParamUnparsable
Right m | snd m /= "" ->
Left ParamUnparsable
Right (v, _) -> Right v
fromParam [] = Left ParamMissing
fromParam _ = Left ParamTooMany
instance FromParam a => FromParam [a] where
fromParam ps = let res = map (fromParam . (:[])) ps in
case lefts res of
[] -> Right $ rights res
_ -> Left $ ParamOtherError "Couldn't parse all parameters."
instance FromParam a => FromParam (Maybe a) where
fromParam [x] = Just <$> fromParam [x]
fromParam [] = Right Nothing
fromParam _ = Left ParamTooMany
findParamMatches :: FromParam p => Text -> [(ByteString, Maybe ByteString)] -> Either ParamError p
findParamMatches n ps = fromParam .
map (maybe "" T.decodeUtf8 . snd) .
filter ((== T.encodeUtf8 n) . fst) $
ps
getMVarParams mv = case mv of
Just mv' -> do v <- readMVar mv'
return $ case v of
Nothing -> []
Just (ps',_) -> ps'
Nothing -> return []
param :: FromParam p => Text -> Req -> IO (Maybe (Req, (p -> a) -> a))
param n req =
do let (_,q,_,mv) = req
ps <- getMVarParams mv
return $ case findParamMatches n (q ++ map (second Just) ps) of
Right y -> Just (req, \k -> k y)
Left _ -> Nothing
paramMany :: FromParam p => Text -> Req -> IO (Maybe (Req, ([p] -> a) -> a))
paramMany n req =
do let (_,q,_,mv) = req
ps <- getMVarParams mv
return $ case findParamMatches n (q ++ map (second Just) ps) of
Left _ -> Nothing
Right ys -> Just (req, \k -> k ys)
paramOpt :: FromParam p =>
Text ->
Req ->
IO (Maybe (Req, (Either ParamError p -> a) -> a))
paramOpt n req =
do let (_,q,_,mv) = req
ps <- getMVarParams mv
return $ Just (req, \k -> k (findParamMatches n (q ++ map (second Just) ps)))
data File = File { fileName :: Text
, fileContentType :: Text
, fileContent :: LB.ByteString
}
getMVarFiles mv = case mv of
Nothing -> error $ "Fn: tried to read a 'file' or 'files', but FnRequest wasn't initialized with MVar."
Just mv' -> do
v <- readMVar mv'
case v of
Nothing -> error $ "Fn: tried to read a 'file' or 'files' from the request without parsing the body with '!=>'"
Just (_,fs') -> return fs'
file :: Text -> Req -> IO (Maybe (Req, (File -> a) -> a))
file n req =
do let (_,_,_,mv) = req
fs <- getMVarFiles mv
return $ case filter ((== T.encodeUtf8 n) . fst) fs of
[(_, FileInfo nm ct c)] -> Just (req, \k -> k (File (T.decodeUtf8 nm)
(T.decodeUtf8 ct)
c))
_ -> Nothing
files :: Req -> IO (Maybe (Req, ([(Text, File)] -> a) -> a))
files req =
do let (_,_,_,Just mv) = req
v <- readMVar mv
let fs' = case v of
Nothing -> error $ "Fn: tried to read a 'file' from the request without parsing the body with '!=>'"
Just (_,fs) -> fs
let fs = map (\(n, FileInfo nm ct c) ->
(T.decodeUtf8 n, File (T.decodeUtf8 nm)
(T.decodeUtf8 ct)
c))
fs'
return $ Just (req, \k -> k fs)
returnText :: Text -> Status -> ByteString -> IO (Maybe Response)
returnText text status content =
return $ Just $
responseBuilder status
[(hContentType, content)]
(B.fromText text)
plainText :: ByteString
plainText = "text/plain; charset=utf-8"
html :: ByteString
html = "text/html; charset=utf-8"
okText :: Text -> IO (Maybe Response)
okText t = returnText t status200 plainText
okHtml :: Text -> IO (Maybe Response)
okHtml t = returnText t status200 html
errText :: Text -> IO (Maybe Response)
errText t = returnText t status500 plainText
errHtml :: Text -> IO (Maybe Response)
errHtml t = returnText t status500 html
notFoundText :: Text -> IO Response
notFoundText t = fromJust <$> returnText t status404 plainText
notFoundHtml :: Text -> IO Response
notFoundHtml t = fromJust <$> returnText t status404 html
redirect :: Text -> IO (Maybe Response)
redirect target =
return $ Just $
responseBuilder status303
[(hLocation, T.encodeUtf8 target)]
(B.fromText "")
redirectReferer :: RequestContext ctxt => ctxt -> IO (Maybe Response)
redirectReferer ctxt =
let rs = requestHeaders $ fst $ getRequest ctxt in
case lookup hReferer rs of
Nothing -> redirect "/"
Just r -> redirect (T.decodeUtf8 r)