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) _) = "

" ++ encodeHtml s ++ "

" -authOpenidForm :: OIDFormReq -> ResponseIO GenResponse -authOpenidForm m@(OIDFormReq _ dest) = do +authOpenidForm :: Handler +authOpenidForm = do + m@(OIDFormReq _ dest) <- getRequest let html = show m ++ "
" ++ @@ -86,7 +86,7 @@ authOpenidForm m@(OIDFormReq _ dest) = do case dest of Just dest' -> addCookie 20 "DEST" dest' Nothing -> return () - return $! htmlResponse html + htmlResponse html data OIDFReq = OIDFReq String String instance Request OIDFReq where @@ -97,8 +97,9 @@ instance Request OIDFReq where show (Hack.serverPort env) ++ "/auth/openid/complete/" return $! OIDFReq oid complete -authOpenidForward :: OIDFReq -> Response -authOpenidForward (OIDFReq oid complete) = do +authOpenidForward :: Handler +authOpenidForward = do + OIDFReq oid complete <- getRequest res <- liftIO $ OpenId.getForwardUrl oid complete case res of Left err -> redirect $ "/auth/openid/?message=" @@ -113,8 +114,9 @@ instance Request OIDComp where dest <- cookieParam "DEST" return $! OIDComp gets dest -authOpenidComplete :: OIDComp -> Response -authOpenidComplete (OIDComp gets' dest) = do +authOpenidComplete :: Handler +authOpenidComplete = do + OIDComp gets' dest <- getRequest res <- liftIO $ OpenId.authenticate gets' case res of Left err -> redirect $ "/auth/openid/?message=" @@ -137,9 +139,9 @@ chopHash ('#':rest) = rest chopHash x = x rpxnowLogin :: String -- ^ api key - -> RpxnowRequest - -> Response -rpxnowLogin apiKey (RpxnowRequest token dest') = do + -> Handler +rpxnowLogin apiKey = do + RpxnowRequest token dest' <- getRequest let dest = case dest' of Nothing -> "/" Just "" -> "/" @@ -154,16 +156,17 @@ data AuthRequest = AuthRequest (Maybe String) instance Request AuthRequest where parseRequest = AuthRequest `fmap` identifier -authCheck :: AuthRequest -> ResponseIO Object -authCheck (AuthRequest Nothing) = - return $ toObject [("status", "notloggedin")] -authCheck (AuthRequest (Just i)) = - return $ toObject - [ ("status", "loggedin") - , ("ident", i) - ] +authCheck :: Handler +authCheck = do + req <- getRequest + case req of + AuthRequest Nothing -> objectResponse[("status", "notloggedin")] + AuthRequest (Just i) -> objectResponse + [ ("status", "loggedin") + , ("ident", i) + ] -authLogout :: () -> ResponseIO Object -authLogout _ = do +authLogout :: Handler +authLogout = do deleteCookie authCookieName - return $ toObject [("status", "loggedout")] + objectResponse [("status", "loggedout")] diff --git a/Web/Restful/Helpers/Static.hs b/Web/Restful/Helpers/Static.hs index 9d88131c..d2e46614 100644 --- a/Web/Restful/Helpers/Static.hs +++ b/Web/Restful/Helpers/Static.hs @@ -25,19 +25,20 @@ import Web.Restful type FileLookup = FilePath -> IO (Maybe B.ByteString) serveStatic :: FileLookup -> Verb -> Handler -serveStatic fl Get = liftHandler $ getStatic fl -serveStatic _ _ = noHandler +serveStatic fl Get = getStatic fl +serveStatic _ _ = notFound newtype StaticReq = StaticReq FilePath instance Request StaticReq where parseRequest = StaticReq `fmap` urlParam "filepath" -- FIXME check for .. -getStatic :: FileLookup -> StaticReq -> ResponseIO GenResponse -getStatic fl (StaticReq fp) = do +getStatic :: FileLookup -> Handler +getStatic fl = do + StaticReq fp <- getRequest content <- liftIO $ fl fp case content of Nothing -> notFound - Just bs -> return $ byteStringResponse (mimeType $ ext fp) bs + Just bs -> genResponse (mimeType $ ext fp) bs mimeType :: String -> String mimeType "jpg" = "image/jpeg" diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index 4fbdfa3f..d8f15dce 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} --------------------------------------------------------- -- -- Module : Web.Restful.Response @@ -15,45 +13,36 @@ -- --------------------------------------------------------- module Web.Restful.Response - ( formatW3 + ( -- * Representations + Reps , HasReps (..) - , notFound - , wrapResponse - , ResponseIO - , ResponseT - , Response - , runResponse - , deleteCookie - , redirect - , addCookie - , header - , GenResponse (..) - , liftIO + , ContentType + -- * Abnormal responses , ErrorResult (..) - , HasRepsW (..) - , byteStringResponse + , getHeaders + , getStatus + -- * Header + , Header (..) + , toPair + -- * Generic responses + , response + , genResponse , htmlResponse - , getRequest + , objectResponse ) where import Data.ByteString.Class -import Data.Time.Format import Data.Time.Clock -import System.Locale import Data.Object import qualified Data.ByteString.Lazy as B import Data.Object.Instances -import Data.Maybe (fromJust) -import Web.Restful.Request - -import Control.Monad.Trans -import Control.Monad (liftM) - -import qualified Hack +import Web.Restful.Utils (formatW3) type ContentType = String +type Reps = [(ContentType, B.ByteString)] + -- | Something which can be represented as multiple content types. -- Each content type is called a representation of the data. class HasReps a where @@ -61,14 +50,9 @@ class HasReps a where -- content type. If the user asked for a specific response type (like -- text/html), then that will get priority. If not, then the first -- element in this list will be used. - reps :: a -> [(ContentType, B.ByteString)] - --- | Wrap up any instance of 'HasReps'. -data HasRepsW = forall a. HasReps a => HasRepsW a - -instance HasReps HasRepsW where - reps (HasRepsW r) = reps r + reps :: a -> Reps +-- | Abnormal return codes. data ErrorResult = Redirect String | NotFound @@ -85,47 +69,14 @@ getHeaders :: ErrorResult -> [Header] getHeaders (Redirect s) = [Header "Location" s] getHeaders _ = [] -newtype ResponseT m a = - ResponseT (RawRequest -> m (Either ErrorResult a, [Header])) -type ResponseIO = ResponseT IO -type Response = ResponseIO HasRepsW - -runResponse :: (ErrorResult -> HasRepsW) - -> (ContentType -> B.ByteString -> IO B.ByteString) - -> [ContentType] - -> Response - -> RawRequest - -> IO Hack.Response -runResponse eh wrapper ctypesAll (ResponseT 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" +----- header stuff +-- | Headers to be added to a 'Result'. +data Header = + AddCookie Int String String + | DeleteCookie String + | Header String String +-- | Convert Header to a key/value pair. toPair :: Header -> IO (String, String) toPair (AddCookie minutes key value) = do now <- getCurrentTime @@ -137,78 +88,29 @@ toPair (DeleteCookie key) = return key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") toPair (Header key value) = return (key, value) -wrapResponse :: (Monad m, HasReps rep) - => ResponseT m rep - -> ResponseT m HasRepsW -wrapResponse = fmap HasRepsW +------ Generic responses +-- | Lifts a 'HasReps' into a monad. +response :: (Monad m, HasReps reps) => reps -> m Reps +response = return . reps -instance MonadTrans ResponseT where - lift ma = ResponseT $ const $ do - a <- ma - return (Right a, []) +-- | Return a response with an arbitrary content type. +genResponse :: (Monad m, LazyByteString lbs) + => ContentType + -> lbs + -> m Reps +genResponse ct lbs = return [(ct, toLazyByteString lbs)] -instance MonadIO ResponseIO where - liftIO = lift +-- | Return a response with a text/html content type. +htmlResponse :: (Monad m, LazyByteString lbs) => lbs -> m Reps +htmlResponse = genResponse "text/html" -redirect :: Monad m => String -> ResponseT m a -redirect s = ResponseT (const $ return (Left $ Redirect s, [])) - -notFound :: Monad m => ResponseT m a -notFound = ResponseT (const $ return (Left NotFound, [])) - -instance Monad m => Functor (ResponseT m) where - fmap = liftM - -instance Monad m => Monad (ResponseT m) where - return = lift . return - fail s = ResponseT (const $ return (Left $ InternalError s, [])) - (ResponseT mx) >>= f = ResponseT $ \rr -> do - (x, hs1) <- mx rr - case x of - Left x' -> return (Left x', hs1) - Right a -> do - let (ResponseT b') = f a - (b, hs2) <- b' rr - return (b, hs1 ++ hs2) - --- | Headers to be added to a 'Result'. -data Header = - AddCookie Int String String - | DeleteCookie String - | Header String String - -addCookie :: Monad m => Int -> String -> String -> ResponseT m () -addCookie a b c = addHeader $ AddCookie a b c - -deleteCookie :: Monad m => String -> ResponseT m () -deleteCookie = addHeader . DeleteCookie - -header :: Monad m => String -> String -> ResponseT m () -header a b = addHeader $ Header a b - -addHeader :: Monad m => Header -> ResponseT m () -addHeader h = ResponseT (const $ return (Right (), [h])) +-- | Return a response from an Object. +objectResponse :: (Monad m, ToObject o) => o -> m Reps +objectResponse = return . reps . toObject +-- HasReps instances instance HasReps () where reps _ = [("text/plain", toLazyByteString "")] - -data GenResponse = HtmlResponse B.ByteString - | ObjectResponse Object - | HtmlOrObjectResponse String Object - | ByteStringResponse ContentType B.ByteString -instance HasReps GenResponse where - reps (HtmlResponse h) = [("text/html", toLazyByteString h)] - reps (ObjectResponse t) = reps t - reps (HtmlOrObjectResponse h t) = - ("text/html", toLazyByteString h) : reps t - reps (ByteStringResponse ct con) = [(ct, con)] - -byteStringResponse :: LazyByteString lbs => ContentType -> lbs -> GenResponse -byteStringResponse ct = ByteStringResponse ct . toLazyByteString - -htmlResponse :: LazyByteString lbs => lbs -> GenResponse -htmlResponse = HtmlResponse . toLazyByteString - instance HasReps Object where reps o = [ ("text/html", unHtml $ safeFromObject o) @@ -218,17 +120,3 @@ instance HasReps Object where instance HasReps [(ContentType, B.ByteString)] where reps = id - --- FIXME put in a separate module (maybe Web.Encodings) -formatW3 :: UTCTime -> String -formatW3 = formatTime defaultTimeLocale "%FT%X-08:00" - -getRequest :: (Monad m, Request r) => ResponseT m r -getRequest = ResponseT $ \rr -> return (helper rr, []) where - helper :: Request r - => RawRequest - -> Either ErrorResult r - helper rr = - case runRequestParser parseRequest rr of - Left errors -> Left $ InvalidArgs errors -- FIXME better error output - Right r -> Right r diff --git a/Web/Restful/Response/AtomFeed.hs b/Web/Restful/Response/AtomFeed.hs index 8f093a49..323c0676 100644 --- a/Web/Restful/Response/AtomFeed.hs +++ b/Web/Restful/Response/AtomFeed.hs @@ -18,6 +18,7 @@ module Web.Restful.Response.AtomFeed ) where import Web.Restful.Response +import Web.Restful.Utils import Data.Time.Clock import Web.Encodings diff --git a/Web/Restful/Response/Sitemap.hs b/Web/Restful/Response/Sitemap.hs index 92f2566a..7bce9561 100644 --- a/Web/Restful/Response/Sitemap.hs +++ b/Web/Restful/Response/Sitemap.hs @@ -19,7 +19,9 @@ module Web.Restful.Response.Sitemap , SitemapChangeFreq (..) ) where +import Web.Restful.Handler import Web.Restful.Response +import Web.Restful.Utils import Web.Encodings import qualified Hack import Web.Restful.Request @@ -86,7 +88,7 @@ instance HasReps SitemapResponse where [ ("text/xml", toLazyByteString $ show res) ] -sitemap :: IO [SitemapUrl] -> SitemapRequest -> ResponseIO SitemapResponse +sitemap :: IO [SitemapUrl] -> SitemapRequest -> Handler sitemap urls' req = do urls <- liftIO urls' - return $ SitemapResponse req urls + return $ reps $ SitemapResponse req urls diff --git a/Web/Restful/Utils.hs b/Web/Restful/Utils.hs index 605a9c99..43a62179 100644 --- a/Web/Restful/Utils.hs +++ b/Web/Restful/Utils.hs @@ -9,15 +9,23 @@ -- Portability : portable -- -- Utility functions for Restful. +-- These are all functions which could be exported to another library. -- --------------------------------------------------------- module Web.Restful.Utils ( parseHttpAccept , tryLookup + , formatW3 ) where import Data.List.Split (splitOneOf) +import Data.Maybe (fromMaybe) +import Data.Time.Clock +import System.Locale +import Data.Time.Format + +-- | Parse the HTTP accept string to determine supported content types. parseHttpAccept :: String -> [String] parseHttpAccept = filter (not . specialHttpAccept) . splitOneOf ";," @@ -26,8 +34,10 @@ specialHttpAccept ('q':'=':_) = True specialHttpAccept ('*':_) = True specialHttpAccept _ = False +-- | Attempt a lookup, returning a default value on failure. tryLookup :: Eq k => v -> k -> [(k, v)] -> v -tryLookup v _ [] = v -tryLookup v k ((k', v'):rest) - | k == k' = v' - | otherwise = tryLookup v k rest +tryLookup def key = fromMaybe def . lookup key + +-- | Format a 'UTCTime' in W3 format; useful for setting cookies. +formatW3 :: UTCTime -> String +formatW3 = formatTime defaultTimeLocale "%FT%X-08:00" -- FIXME time zone?