module Web.Routes.Nested
( module Web.Routes.Nested.FileExtListener
, module Web.Routes.Nested.VerbListener
, module Web.Routes.Nested.Types
, HandlerT (..)
, ActionT
, handle
, notFound
, route
) where
import Web.Routes.Nested.Types
import Web.Routes.Nested.FileExtListener
import Web.Routes.Nested.FileExtListener.Types (FileExt (..))
import Web.Routes.Nested.VerbListener
import Network.HTTP.Types
import Network.HTTP.Media
import Network.Wai
import Control.Applicative
import Control.Monad.IO.Class
import Control.Monad.Trans
import Control.Monad.Writer
import Control.Monad.Reader
import Data.Trie.Pred.Unified
import qualified Data.Trie.Pred.Unified as P
import qualified Data.Text as T
import qualified Data.Map.Lazy as M
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Maybe (fromMaybe)
import Data.Constraint
import Data.Witherable
import Data.List
import Data.Function.Poly
newtype HandlerT z x m a = HandlerT
{ runHandler :: WriterT ( RUPTrie T.Text x
, RUPTrie T.Text x ) m a }
deriving (Functor)
deriving instance Applicative m => Applicative (HandlerT z x m)
deriving instance Monad m => Monad (HandlerT z x m)
deriving instance MonadIO m => MonadIO (HandlerT z x m)
instance MonadTrans (HandlerT z x) where
lift ma = HandlerT $ lift ma
type ActionT z m a = VerbListenerT z (FileExtListenerT Response m a) m a
type family LastIsNothing (xs :: [Maybe *]) :: Constraint where
LastIsNothing '[] = ()
LastIsNothing ('Nothing ': '[]) = ()
LastIsNothing (x ': xs) = LastIsNothing xs
type family LastIsJust (xs :: [Maybe *]) :: Constraint where
LastIsJust (('Just x) ': '[]) = ()
LastIsJust (x ': xs) = LastIsJust xs
handle :: ( Monad m
, Functor m
, cleanxs ~ OnlyJusts xs
, HasResult childType (ActionT z m ())
, ExpectArity cleanxs childType
, Singleton (UrlChunks xs)
childType
(RUPTrie T.Text result)
, Extrude (UrlChunks xs)
(RUPTrie T.Text childType)
(RUPTrie T.Text result)
, (ArityMinusTypeList childType cleanxs) ~ result
, childType ~ TypeListToArity cleanxs result
, LastIsNothing xs
) =>
UrlChunks xs
-> childType
-> Maybe (HandlerT z childType m ())
-> HandlerT z result m ()
handle ts vl Nothing =
HandlerT $ tell (singleton ts vl, mempty)
handle ts vl (Just cs) = do
((Rooted _ ctrie),_) <- lift $ execWriterT $ runHandler cs
HandlerT $ tell (extrude ts $ Rooted (Just vl) ctrie, mempty)
notFound :: ( Monad m
, Functor m
, cleanxs ~ OnlyJusts xs
, HasResult childType (ActionT z m ())
, ExpectArity cleanxs childType
, Singleton (UrlChunks xs)
childType
(RUPTrie T.Text result)
, Extrude (UrlChunks xs)
(RUPTrie T.Text childType)
(RUPTrie T.Text result)
, (ArityMinusTypeList childType cleanxs) ~ result
, childType ~ TypeListToArity cleanxs result
) =>
UrlChunks xs
-> childType
-> Maybe (HandlerT z childType m ())
-> HandlerT z result m ()
notFound ts vl Nothing = do
HandlerT $ tell (mempty, singleton ts vl)
notFound ts vl (Just cs) = do
((Rooted _ ctrie),_) <- lift $ execWriterT $ runHandler cs
HandlerT $ tell (mempty, extrude ts $ Rooted (Just vl) ctrie)
route :: ( Functor m
, Monad m
, MonadIO m
) =>
HandlerT z (ActionT z m ()) m a
-> Request
-> (Response -> IO ResponseReceived) -> m ResponseReceived
route h req respond = do
(rtrie, nftrie) <- execWriterT $ runHandler h
let mMethod = httpMethodToMSym $ requestMethod req
mFileext = case pathInfo req of
[] -> Just Html
xs -> toExt $ T.pack $ dropWhile (/= '.') $ T.unpack $ last xs
mnftrans = P.lookupNearestParent (pathInfo req) nftrie
acceptBS = Prelude.lookup ("Accept" :: HeaderName) $ requestHeaders req
fe = fromMaybe Html mFileext
notFoundBasic <- handleNotFound acceptBS Html Get mnftrans
maybe (liftIO $ respond404 notFoundBasic) (\v -> do
menf <- handleNotFound acceptBS fe v mnftrans
let cleanedPathInfo = applyToLast trimFileExt $ pathInfo req
fail = liftIO $ respond404 menf
maybe (case pathInfo req of
[] -> fail
_ -> case trimFileExt $ last $ pathInfo req of
"index" -> maybe fail
(\foundM -> continue acceptBS fe v foundM menf)
(P.lookup (init $ pathInfo req) rtrie)
_ -> fail
) (\foundM -> continue acceptBS fe v foundM menf)
(P.lookup cleanedPathInfo rtrie)
) mMethod
where
onJustM :: Monad m => (a -> m (Maybe b)) -> Maybe a -> m (Maybe b)
onJustM f mx = maybe (return Nothing) f mx
handleNotFound :: MonadIO m =>
Maybe B.ByteString
-> FileExt
-> Verb
-> Maybe (ActionT z m ())
-> m (Maybe Response)
handleNotFound acceptBS f v mnfcomp =
let handleEither nfcomp = do
vmapLit <- execWriterT $ runVerbListenerT nfcomp
onJustM (\(_, femonad) -> do
femap <- execWriterT $ runFileExtListenerT femonad
return $ lookupProper acceptBS f $ unFileExts femap
) $ M.lookup v $ unVerbs vmapLit
in
onJustM handleEither mnfcomp
continue :: MonadIO m =>
Maybe B.ByteString
-> FileExt
-> Verb
-> ActionT z m ()
-> Maybe Response
-> m ResponseReceived
continue acceptBS f v foundM mnfResp = do
vmapLit <- execWriterT $ runVerbListenerT foundM
continueMap acceptBS f v (unVerbs vmapLit) mnfResp
continueMap :: MonadIO m =>
Maybe B.ByteString
-> FileExt
-> Verb
-> M.Map Verb (Maybe (ReaderT BL.ByteString m z, Maybe BodyLength), FileExtListenerT Response m ())
-> Maybe Response
-> m ResponseReceived
continueMap acceptBS f v vmap mnfResp = do
let fail = liftIO $ respond404 mnfResp
maybe fail (\(mreqbodyf, femonad) -> do
femap <- execWriterT $ runFileExtListenerT femonad
maybe fail (\r -> do
case mreqbodyf of
Nothing -> liftIO $ respond r
Just (reqbf,Nothing) -> do
body <- liftIO $ strictRequestBody req
(runReaderT $ reqbf) body
liftIO $ respond r
Just (reqbf,Just bl) -> do
case requestBodyLength req of
KnownLength bl' ->
if bl' <= bl
then do body <- liftIO $ strictRequestBody req
(runReaderT $ reqbf) body
liftIO $ respond r
else fail
_ -> fail) $
lookupProper acceptBS f $ unFileExts femap) $
M.lookup v vmap
respond404 :: Maybe Response -> IO ResponseReceived
respond404 mr = respond $ fromMaybe plain404 mr
plain404 :: Response
plain404 = responseLBS status404 [("Content-Type","text/plain")] "404"
lookupProper :: Maybe B.ByteString -> FileExt -> M.Map FileExt a -> Maybe a
lookupProper maccept k map =
let
attempts = maybe
[Html,Text,Json,JavaScript,Css]
(\accept -> possibleFileExts k accept)
maccept
in
foldr (go map) Nothing attempts
where
go map x Nothing = M.lookup x map
go _ _ (Just y) = Just y
possibleFileExts :: FileExt -> B.ByteString -> [FileExt]
possibleFileExts fe accept =
let computed = sortFE fe $ nub $ concat $
catMaybes [ mapAccept [ ("application/json" :: B.ByteString, [Json])
, ("application/javascript" :: B.ByteString, [Json,JavaScript])
] accept
, mapAccept [ ("text/html" :: B.ByteString, [Html])
] accept
, mapAccept [ ("text/plain" :: B.ByteString, [Text])
] accept
, mapAccept [ ("text/css" :: B.ByteString, [Css])
] accept
]
wildcard = concat $
catMaybes [ mapAccept [ ("*/*" :: B.ByteString, [Html,Text,Json,JavaScript,Css])
] accept
]
in
if length wildcard /= 0 then wildcard else computed
sortFE Html xs = [Html, Text] `intersect` xs
sortFE JavaScript xs = [JavaScript, Text] `intersect` xs
sortFE Json xs = [Json, JavaScript, Text] `intersect` xs
sortFE Css xs = [Css, Text] `intersect` xs
sortFE Text xs = [Text] `intersect` xs
applyToLast :: (a -> a) -> [a] -> [a]
applyToLast _ [] = []
applyToLast f (x:[]) = f x : []
applyToLast f (x:xs) = x : applyToLast f xs
trimFileExt :: T.Text -> T.Text
trimFileExt s = if (T.unpack s) `endsWithAny` possibleExts
then T.pack $ takeWhile (/= '.') $ T.unpack s
else s
where
possibleExts = [ ".html",".htm",".txt",".json",".lucid"
, ".julius",".css",".cassius",".lucius"
]
endsWithAny s xs = (dropWhile (/= '.') s) `elem` xs
httpMethodToMSym :: Method -> Maybe Verb
httpMethodToMSym x | x == methodGet = Just Get
| x == methodPost = Just Post
| x == methodPut = Just Put
| x == methodDelete = Just Delete
| otherwise = Nothing