module Network.Wai.Middleware.Verbs
(
get
, post
, put
, delete
,
VerbMap
, Verb
,
VerbListenerT (..)
, execVerbListenerT
,
lookupVerb
, getVerb
, mapVerbs
) where
import Network.Wai (Request (..))
import Network.HTTP.Types
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as HM
import Data.Monoid
import Data.Hashable
import Control.Arrow (second)
import Control.Applicative
import Control.Monad.Trans
import Control.Monad.Trans.Maybe
import Control.Monad.State hiding (get, put)
import qualified Control.Monad.State as S
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.Cont
import Control.Monad.Base
import Control.Monad.Catch
import Control.Monad.Trans.Resource
import Control.Monad.Except
import Control.Monad.Logger
import Control.Error
import GHC.Generics
type VerbMap m r = HashMap Verb (Request -> m (), r)
type Verb = StdMethod
deriving instance Generic Verb
instance Hashable Verb
getVerb :: Request -> Verb
getVerb req = fromMaybe GET $ httpMethodToMSym (requestMethod req)
where
httpMethodToMSym :: Method -> Maybe Verb
httpMethodToMSym x | x == methodGet = Just GET
| x == methodPost = Just POST
| x == methodPut = Just PUT
| x == methodDelete = Just DELETE
| otherwise = Nothing
lookupVerb :: Monad m => Request -> Verb -> VerbMap m r -> m (Maybe r)
lookupVerb req v vmap = runMaybeT $ do
(upload, result) <- hoistMaybe $ HM.lookup v vmap
lift (upload req)
return result
newtype VerbListenerT r m a = VerbListenerT
{ runVerbListenerT :: StateT (VerbMap m r) m a
} deriving ( Functor, Applicative, Alternative, Monad, MonadFix, MonadPlus
, MonadState (VerbMap m r), MonadWriter w, MonadReader r, MonadIO
, MonadError e', MonadCont, MonadBase b, MonadThrow, MonadCatch
, MonadMask, MonadLogger
)
deriving instance (MonadResource m, MonadBase IO m) => MonadResource (VerbListenerT r m)
execVerbListenerT :: Monad m => VerbListenerT r m a -> m (VerbMap m r)
execVerbListenerT xs = execStateT (runVerbListenerT xs) mempty
instance MonadTrans (VerbListenerT r) where
lift = VerbListenerT . lift
get :: ( Monad m
) => r -> VerbListenerT r m ()
get r = tell' $! HM.singleton GET ( const $ return ()
, r
)
post :: ( Monad m
) => (Request -> m ())
-> r
-> VerbListenerT r m ()
post h r = tell' $! HM.singleton POST ( h
, r
)
put :: ( Monad m
) => (Request -> m ())
-> r
-> VerbListenerT r m ()
put h r = tell' $! HM.singleton PUT ( h
, r
)
delete :: ( Monad m
) => r -> VerbListenerT r m ()
delete r = tell' $! HM.singleton DELETE ( const $ return ()
, r
)
tell' :: (Monoid w, MonadState w m) => w -> m ()
tell' x = modify' (<> x)
mapVerbs :: Monad m => (r -> s) -> VerbListenerT r m () -> VerbListenerT s m ()
mapVerbs f xs = do
vmap <- lift $ execVerbListenerT xs
tell' $ second f <$> vmap