{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE OverloadedStrings #-} module Web.Routes.Nested where import Web.Routes.Nested.FileExtListener import Web.Routes.Nested.VerbListener import Network.HTTP.Types import Network.Wai import Network.Wai.Middleware.AddHeaders import Control.Applicative import Control.Arrow (second, first, (***)) import Control.Monad.IO.Class import Control.Monad.Trans import Control.Monad.Writer import qualified Data.List.NonEmpty as NE import Data.Monoid import Data.Trie.Pseudo import Data.Trie.Rooted import qualified Data.Trie.Rooted as R import Data.Traversable import qualified Data.Text as T import qualified Data.Map.Lazy as M newtype HandlerT m a = HandlerT { runHandler :: WriterT (MergeRooted T.Text (Verbs Response)) m a } deriving (Functor) deriving instance Applicative m => Applicative (HandlerT m) deriving instance Monad m => Monad (HandlerT m) deriving instance MonadIO m => MonadIO (HandlerT m) deriving instance MonadTrans HandlerT handle :: Monad m => [T.Text] -> VerbListenerT Response m () -> HandlerT m () handle ts vl = do vfrs <- lift $ execWriterT $ runVerbListenerT vl HandlerT $ tell $ case ts of [] -> MergeRooted $ Rooted (Just vfrs) [] _ -> MergeRooted $ Rooted Nothing [Rest (NE.fromList ts) vfrs] route :: (Functor m, Monad m) => HandlerT m a -> Request -> (Response -> m b) -> m b route h req respond = do trie <- unMergeRooted <$> (execWriterT $ runHandler h) let mMethod = httpMethodToMSym $ requestMethod req mFileext = possibleExts $ T.pack $ getFileExt $ T.unpack $ last $ pathInfo req case (mFileext, mMethod) of (Just f, Just m) -> case R.lookup (pathInfo req) trie of Just map -> case M.lookup (f,m) $ unVerbs map of Just r -> respond r Nothing -> respond notFound Nothing -> respond notFound _ -> respond notFound where getFileExt :: String -> String getFileExt s = case foldr go Nothing s of Nothing -> "" Just x -> x where go '.' _ = Just "." go x (Just xs) = Just $ xs ++ [x] go x Nothing = Nothing httpMethodToMSym :: Method -> Maybe Verb httpMethodToMSym x | x == methodGet = Just Get | x == methodPost = Just Post | x == methodPut = Just Put | x == methodDelete = Just Delete | otherwise = Nothing notFound = responseLBS status404 [("Content-Type","text/plain")] "404 :("