diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index 017824f2..6f4f72ac 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -65,14 +65,14 @@ class ResourceName a b => RestfulApp a b | a -> b where responseWrapper _ _ = return -- | Output error response pages. - errorHandler :: a -> RawRequest -> ErrorResult -> HasRepsW - errorHandler _ rr NotFound = HasRepsW $ toObject $ "Not found: " ++ show rr + errorHandler :: a -> RawRequest -> ErrorResult -> Reps + errorHandler _ rr NotFound = reps $ toObject $ "Not found: " ++ show rr errorHandler _ _ (Redirect url) = - HasRepsW $ toObject $ "Redirect to: " ++ url + reps $ toObject $ "Redirect to: " ++ url errorHandler _ _ (InternalError e) = - HasRepsW $ toObject $ "Internal server error: " ++ e + reps $ toObject $ "Internal server error: " ++ e errorHandler _ _ (InvalidArgs ia) = - HasRepsW $ toObject $ + reps $ toObject $ [ ("errorMsg", toObject "Invalid arguments") , ("messages", toObject ia) ] @@ -118,7 +118,7 @@ toHackApplication sampleRN hm env = do let (Right resource) = splitPath $ Hack.pathInfo env let (handler, urlParams') = case findResourceNames resource of - [] -> (noHandler, []) + [] -> (notFound, []) [(rn, urlParams'')] -> let verb = toVerb $ Hack.requestMethod env in (hm rn verb, urlParams'') @@ -126,7 +126,7 @@ toHackApplication sampleRN hm env = do let rr = envToRawRequest urlParams' env let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env ctypes' = parseHttpAccept rawHttpAccept - runResponse (errorHandler sampleRN rr) + runHandler (errorHandler sampleRN rr) (responseWrapper sampleRN) ctypes' handler diff --git a/Web/Restful/Handler.hs b/Web/Restful/Handler.hs index bcfd86f9..3a9454cf 100644 --- a/Web/Restful/Handler.hs +++ b/Web/Restful/Handler.hs @@ -1,6 +1,8 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} --------------------------------------------------------- -- -- Module : Web.Restful.Handler @@ -15,22 +17,133 @@ -- --------------------------------------------------------- module Web.Restful.Handler - ( Handler - , liftHandler - , noHandler + ( -- * 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 -type Handler = Response -- FIXME maybe move some stuff around now... +import Control.Monad.Trans +import Control.Monad (liftM) -liftHandler :: (Request req, HasReps rep) - => (req -> ResponseIO rep) +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 -liftHandler f = do - req <- getRequest - wrapResponse $ f req + -> 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 -noHandler :: Handler -noHandler = notFound +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])) diff --git a/Web/Restful/Helpers/Auth.hs b/Web/Restful/Helpers/Auth.hs index 067cd551..fec60a3d 100644 --- a/Web/Restful/Helpers/Auth.hs +++ b/Web/Restful/Helpers/Auth.hs @@ -28,7 +28,6 @@ import Web.Restful.Constants import Control.Applicative ((<$>), Applicative (..)) import Control.Monad.Reader -import Data.Object import Data.Maybe (fromMaybe) data AuthResource = @@ -42,13 +41,13 @@ data AuthResource = type RpxnowApiKey = String -- FIXME newtype instance ResourceName AuthResource (Maybe RpxnowApiKey) where - getHandler _ Check Get = liftHandler authCheck - getHandler _ Logout Get = liftHandler authLogout - getHandler _ Openid Get = liftHandler authOpenidForm - getHandler _ OpenidForward Get = liftHandler authOpenidForward - getHandler _ OpenidComplete Get = liftHandler authOpenidComplete - getHandler (Just key) LoginRpxnow Get = liftHandler $ rpxnowLogin key - getHandler _ _ _ = noHandler + getHandler _ Check Get = authCheck + getHandler _ Logout Get = authLogout + getHandler _ Openid Get = authOpenidForm + getHandler _ OpenidForward Get = authOpenidForward + getHandler _ OpenidComplete Get = authOpenidComplete + getHandler (Just key) LoginRpxnow Get = rpxnowLogin key + getHandler _ _ _ = notFound allValues = Check @@ -75,8 +74,9 @@ instance Show OIDFormReq where show (OIDFormReq (Just s) _) = "
" -authOpenidForm :: OIDFormReq -> ResponseIO GenResponse -authOpenidForm m@(OIDFormReq _ dest) = do +authOpenidForm :: Handler +authOpenidForm = do + m@(OIDFormReq _ dest) <- getRequest let html = show m ++ "