module Network.Wai.Middleware.Verbs
(
get
, post
, put
, delete
,
VerbMap
, Verb
,
VerbListenerT (..)
, execVerbListenerT
,
lookupVerb
, getVerb
) where
import Network.Wai (Request (..))
import Network.HTTP.Types (StdMethod (..), Method, methodDelete, methodPut, methodPost, methodGet)
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as HM
import Data.Monoid ((<>))
import Data.Hashable (Hashable)
import Data.Maybe (fromMaybe)
import Control.Applicative (Alternative)
import Control.Monad (MonadPlus)
import Control.Monad.Fix (MonadFix)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Trans (MonadTrans (lift))
import Control.Monad.State (MonadState, StateT (..), modify', execStateT)
import Control.Monad.Reader (MonadReader)
import Control.Monad.Writer (MonadWriter)
import Control.Monad.Cont (MonadCont)
import Control.Monad.Base (MonadBase)
import Control.Monad.Catch (MonadCatch, MonadThrow, MonadMask)
import Control.Monad.Trans.Resource (MonadResource)
import Control.Monad.Except (MonadError)
import Control.Monad.Logger (MonadLogger)
import GHC.Generics (Generic)
type VerbMap r = HashMap Verb 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 :: Verb -> VerbMap r -> Maybe r
lookupVerb = HM.lookup
newtype VerbListenerT r m a = VerbListenerT
{ runVerbListenerT :: StateT (VerbMap r) m a
} deriving ( Functor, Applicative, Alternative, Monad, MonadFix, MonadPlus
, MonadState (VerbMap 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 r)
execVerbListenerT xs = execStateT (runVerbListenerT xs) mempty
instance MonadTrans (VerbListenerT r) where
lift = VerbListenerT . lift
get :: ( Monad m
, Monoid r
) => r -> VerbListenerT r m ()
get r = tell' $ HM.singleton GET r
post :: ( Monad m
, Monoid r
) => r -> VerbListenerT r m ()
post r = tell' $ HM.singleton POST r
put :: ( Monad m
, Monoid r
) => r -> VerbListenerT r m ()
put r = tell' $ HM.singleton PUT r
delete :: ( Monad m
, Monoid r
) => r -> VerbListenerT r m ()
delete r = tell' $ HM.singleton DELETE r
tell' :: (Monoid r, MonadState (VerbMap r) m) => VerbMap r -> m ()
tell' x = modify' (\y -> HM.unionWith (<>) y x)