150 lines
4.4 KiB
Haskell
150 lines
4.4 KiB
Haskell
{-# LANGUAGE ExistentialQuantification #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE FunctionalDependencies #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE TypeSynonymInstances #-}
|
|
---------------------------------------------------------
|
|
--
|
|
-- Module : Web.Restful.Handler
|
|
-- Copyright : Michael Snoyman
|
|
-- License : BSD3
|
|
--
|
|
-- Maintainer : Michael Snoyman <michael@snoyman.com>
|
|
-- Stability : unstable
|
|
-- Portability : portable
|
|
--
|
|
-- Define Handler stuff.
|
|
--
|
|
---------------------------------------------------------
|
|
module Web.Restful.Handler
|
|
( -- * Handler monad
|
|
HandlerT
|
|
, HandlerIO
|
|
, Handler
|
|
, runHandler
|
|
, getRequest
|
|
, liftIO
|
|
-- * Special handlers
|
|
, redirect
|
|
, notFound
|
|
-- * Setting headers
|
|
, addCookie
|
|
, deleteCookie
|
|
, header
|
|
) where
|
|
|
|
import Web.Restful.Request
|
|
import Web.Restful.Response
|
|
|
|
import Control.Monad.Trans
|
|
import Control.Monad (liftM)
|
|
|
|
import Data.Maybe (fromJust)
|
|
import qualified Data.ByteString.Lazy as B
|
|
import qualified Hack
|
|
|
|
------ Handler monad
|
|
newtype HandlerT m a =
|
|
HandlerT (RawRequest -> m (Either ErrorResult a, [Header]))
|
|
type HandlerIO = HandlerT IO
|
|
type Handler = HandlerIO Reps
|
|
|
|
runHandler :: (ErrorResult -> Reps)
|
|
-> (ContentType -> B.ByteString -> IO B.ByteString)
|
|
-> [ContentType]
|
|
-> Handler
|
|
-> RawRequest
|
|
-> IO Hack.Response
|
|
runHandler eh wrapper ctypesAll (HandlerT inside) rr = do
|
|
(x, headers') <- inside rr
|
|
let extraHeaders =
|
|
case x of
|
|
Left r -> getHeaders r
|
|
Right _ -> []
|
|
headers <- mapM toPair (headers' ++ extraHeaders)
|
|
let outReps = either (reps . eh) reps x
|
|
let statusCode =
|
|
case x of
|
|
Left r -> getStatus r
|
|
Right _ -> 200
|
|
(ctype, selectedRep) <- chooseRep outReps ctypesAll
|
|
finalRep <- wrapper ctype selectedRep
|
|
let headers'' = ("Content-Type", ctype) : headers
|
|
return $! Hack.Response statusCode headers'' finalRep
|
|
|
|
chooseRep :: Monad m
|
|
=> [(ContentType, B.ByteString)]
|
|
-> [ContentType]
|
|
-> m (ContentType, B.ByteString)
|
|
chooseRep rs cs
|
|
| length rs == 0 = fail "All reps must have at least one value"
|
|
| otherwise = do
|
|
let availCs = map fst rs
|
|
case filter (`elem` availCs) cs of
|
|
[] -> return $ head rs
|
|
[ctype] -> return (ctype, fromJust $ lookup ctype rs)
|
|
_ -> fail "Overlapping representations"
|
|
|
|
instance MonadTrans HandlerT where
|
|
lift ma = HandlerT $ const $ do
|
|
a <- ma
|
|
return (Right a, [])
|
|
|
|
instance MonadIO HandlerIO where
|
|
liftIO = lift
|
|
|
|
instance Monad m => Functor (HandlerT m) where
|
|
fmap = liftM
|
|
|
|
instance Monad m => Monad (HandlerT m) where
|
|
return = lift . return
|
|
fail s = HandlerT (const $ return (Left $ InternalError s, []))
|
|
(HandlerT mx) >>= f = HandlerT $ \rr -> do
|
|
(x, hs1) <- mx rr
|
|
case x of
|
|
Left x' -> return (Left x', hs1)
|
|
Right a -> do
|
|
let (HandlerT b') = f a
|
|
(b, hs2) <- b' rr
|
|
return (b, hs1 ++ hs2)
|
|
|
|
-- | Parse a request in the Handler monad. On failure, return a 400 error.
|
|
getRequest :: (Monad m, Request r) => HandlerT m r
|
|
getRequest = HandlerT $ \rr -> return (helper rr, []) where
|
|
helper :: Request r
|
|
=> RawRequest
|
|
-> Either ErrorResult r
|
|
helper rr =
|
|
case runRequestParser parseRequest rr of
|
|
Left errors -> Left $ InvalidArgs errors
|
|
Right r -> Right r
|
|
|
|
------ Special handlers
|
|
-- | Redirect to the given URL.
|
|
redirect :: Monad m => String -> HandlerT m a
|
|
redirect s = HandlerT (const $ return (Left $ Redirect s, []))
|
|
|
|
-- | Return a 404 not found page. Also denotes no handler available.
|
|
notFound :: Monad m => HandlerT m a
|
|
notFound = HandlerT (const $ return (Left NotFound, []))
|
|
|
|
------- Headers
|
|
-- | Set the cookie on the client.
|
|
addCookie :: Monad m
|
|
=> Int -- ^ minutes to timeout
|
|
-> String -- ^ key
|
|
-> String -- ^ value
|
|
-> HandlerT m ()
|
|
addCookie a b c = addHeader $ AddCookie a b c
|
|
|
|
-- | Unset the cookie on the client.
|
|
deleteCookie :: Monad m => String -> HandlerT m ()
|
|
deleteCookie = addHeader . DeleteCookie
|
|
|
|
-- | Set an arbitrary header on the client.
|
|
header :: Monad m => String -> String -> HandlerT m ()
|
|
header a b = addHeader $ Header a b
|
|
|
|
addHeader :: Monad m => Header -> HandlerT m ()
|
|
addHeader h = HandlerT (const $ return (Right (), [h]))
|