diff --git a/Web/Restful.hs b/Web/Restful.hs index 3e26bad6..f4925cad 100644 --- a/Web/Restful.hs +++ b/Web/Restful.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverlappingInstances #-} --------------------------------------------------------- -- -- Module : Web.Restful @@ -19,870 +13,13 @@ --------------------------------------------------------- module Web.Restful ( - -- * Request parsing - -- $param_overview - - -- ** Types - ParamError - , ParamName - , ParamValue - -- ** Parameter type class - , Parameter (..) - -- ** RequestParser helpers - , getParam - , postParam - , urlParam - , anyParam - , cookieParam - , identifier - , acceptedLanguages - , requestPath - -- ** Building actual request - , Request (..) - , Hack.RequestMethod (..) - , rawFiles - -- * Response construction - , Response (..) - , response - -- ** Helper 'Response' instances - -- *** Generic hierarchichal text - , Tree (..) - , IsTree (..) - -- *** Atom news feed - , AtomFeed (..) - , AtomFeedEntry (..) - -- *** Sitemap - , sitemap - , SitemapUrl (..) - , SitemapLoc (..) - , SitemapChangeFreq (..) - -- *** Generics - -- **** List/detail - , ListDetail (..) - , ItemList (..) - , ItemDetail (..) - , -- **** Multiple response types. - GenResponse (..) - -- * Defining an application - , ApplicationMonad - -- ** Routing - , addResource - -- ** Settings - , setHandler - , setRpxnowApiKey - , setUrlRewriter - , setHtmlWrapper - -- ** Engage - , run + module Data.Object + , module Web.Restful.Request + , module Web.Restful.Response + , module Web.Restful.Application ) where --- hideously long import list -import qualified Hack -import qualified Hack.Handler.CGI -import Control.Monad.Reader -import Control.Monad.Writer -import Control.Monad.State hiding (gets) -import Data.List (intercalate) -import Web.Encodings -import Data.Maybe (isJust) -import Data.ByteString.Class -import qualified Data.ByteString.Lazy as BS -import Data.Function.Predicate (equals) -import Data.Default -import qualified Web.Authenticate.Rpxnow as Rpxnow -import qualified Web.Authenticate.OpenId as OpenId -import Data.List.Split (splitOneOf) - -import Hack.Middleware.Gzip -import Hack.Middleware.CleanPath -import Hack.Middleware.Jsonp -import Hack.Middleware.ClientSession - -import Data.Time.Format -import Data.Time.Clock -import System.Locale -import Control.Applicative ((<$>), Applicative (..)) -import Control.Arrow (second) - --- $param_overview --- In Restful, all of the underlying parameter values are strings. They can --- come from multiple sources: GET parameters, URL rewriting (FIXME: link), --- cookies, etc. However, most applications eventually want to convert --- those strings into something else, like 'Int's. Additionally, it is --- often desirable to allow multiple values, or no value at all. --- --- That is what the parameter concept is for. A 'Parameter' is any value --- which can be converted from a 'String', or list of 'String's. - --- | Any kind of error message generated in the parsing stage. -type ParamError = String - --- | In GET parameters, the key. In cookies, the cookie name. So on and so --- forth. -type ParamName = String - --- | The 'String' value of a parameter, such as cookie content. -type ParamValue = String - --- | Anything which can be converted from a 'String' or list of 'String's. --- --- The default implementation of 'readParams' will error out if given --- anything but 1 'ParamValue'. This is usually what you want. --- --- Minimal complete definition: either 'readParam' or 'readParams'. -class Parameter a where - -- | Convert a string into the desired value, or explain why that can't - -- happen. - readParam :: ParamValue -> Either ParamError a - readParam = readParams . return - - -- | Convert a list of strings into the desired value, or explain why - -- that can't happen. - readParams :: [ParamValue] -> Either ParamError a - readParams [x] = readParam x - readParams [] = Left "Missing parameter" - readParams xs = Left $ "Given " ++ show (length xs) ++ - " values, expecting 1" - --- | Attempt to parse a list of param values using 'readParams'. --- If that fails, return an error message and an undefined value. This way, --- we can process all of the parameters and get all of the error messages. --- Be careful not to use the value inside until you can be certain the --- reading succeeded. -tryReadParams:: Parameter a - => ParamName - -> [ParamValue] - -> RequestParser a -tryReadParams name params = - case readParams params of - Left s -> do - tell [name ++ ": " ++ s] - return $ - error $ - "Trying to evaluate nonpresent parameter " ++ - name - Right x -> return x - --- | Helper function for generating 'RequestParser's from various --- 'ParamValue' lists. -genParam :: Parameter a - => (RawRequest -> ParamName -> [ParamValue]) - -> ParamName - -> RequestParser a -genParam f name = do - req <- ask - tryReadParams name $ f req name - --- | Parse a value passed as a GET parameter. -getParam :: Parameter a => ParamName -> RequestParser a -getParam = genParam getParams - --- | Parse a value passed as a POST parameter. -postParam :: Parameter a => ParamName -> RequestParser a -postParam = genParam postParams - --- | Parse a value passed in the URL and extracted using rewrite. --- (FIXME: link to rewrite section.) -urlParam :: Parameter a => ParamName -> RequestParser a -urlParam = genParam urlParams - --- | Parse a value passed as a GET, POST or URL parameter. -anyParam :: Parameter a => ParamName -> RequestParser a -anyParam = genParam anyParams - --- | Parse a value passed as a raw cookie. -cookieParam :: Parameter a => ParamName -> RequestParser a -cookieParam = genParam cookies - --- | Parse a value in the hackHeader field. -hackHeaderParam :: Parameter a => ParamName -> RequestParser a -hackHeaderParam name = do - env <- parseEnv - let vals' = lookup name $ Hack.hackHeaders env - vals = case vals' of - Nothing -> [] - Just x -> [x] - tryReadParams name vals - --- | Extract the cookie which specifies the identifier for a logged in --- user. -identifier :: Parameter a => RequestParser a -identifier = hackHeaderParam authCookieName - --- | Get the raw 'Hack.Env' value. -parseEnv :: RequestParser Hack.Env -parseEnv = rawEnv `fmap` ask - --- | Determine the ordered list of language preferences. --- --- FIXME: Future versions should account for some cookie. -acceptedLanguages :: RequestParser [String] -acceptedLanguages = do - env <- parseEnv - let rawLang = tryLookup "" "Accept-Language" $ Hack.http env - return $! parseHttpAccept rawLang - --- | Determinge the path requested by the user (ie, the path info). -requestPath :: RequestParser String -requestPath = do - env <- parseEnv - let q = case Hack.queryString env of - "" -> "" - q'@('?':_) -> q' - q' -> q' - return $! Hack.pathInfo env ++ q - -type RequestParser a = WriterT [ParamError] (Reader RawRequest) a -instance Applicative (WriterT [ParamError] (Reader RawRequest)) where - pure = return - f <*> a = do - f' <- f - a' <- a - return $! f' a' - --- | Parse a request into either the desired 'Request' or a list of errors. -runRequestParser :: RequestParser a -> RawRequest -> Either [ParamError] a -runRequestParser p req = - let (val, errors) = (runReader (runWriterT p)) req - in case errors of - [] -> Right val - x -> Left x - --- | The raw information passed through Hack, cleaned up a bit. -data RawRequest = RawRequest - { rawPathInfo :: PathInfo - , rawUrlParams :: [(ParamName, ParamValue)] - , rawGetParams :: [(ParamName, ParamValue)] - , rawPostParams :: [(ParamName, ParamValue)] - , rawCookies :: [(ParamName, ParamValue)] - , rawFiles :: [(ParamName, FileInfo)] - , rawEnv :: Hack.Env - } - --- | All GET paramater values with the given name. -getParams :: RawRequest -> ParamName -> [ParamValue] -getParams rr name = map snd - . filter (\x -> name == fst x) - . rawGetParams - $ rr - --- | All POST paramater values with the given name. -postParams :: RawRequest -> ParamName -> [ParamValue] -postParams rr name = map snd - . filter (\x -> name == fst x) - . rawPostParams - $ rr - --- | All URL paramater values (see rewriting) with the given name. -urlParams :: RawRequest -> ParamName -> [ParamValue] -urlParams rr name = map snd - . filter (\x -> name == fst x) - . rawUrlParams - $ rr - --- | All GET, POST and URL paramater values (see rewriting) with the given name. -anyParams :: RawRequest -> ParamName -> [ParamValue] -anyParams req name = urlParams req name ++ - getParams req name ++ - postParams req name - --- | All cookies with the given name. -cookies :: RawRequest -> ParamName -> [ParamValue] -cookies rr name = map snd . filter (fst `equals` name) . rawCookies $ rr - -instance Parameter a => Parameter (Maybe a) where - readParams [] = Right Nothing - readParams [x] = readParam x >>= return . Just - readParams xs = Left $ "Given " ++ show (length xs) ++ - " values, expecting 0 or 1" - -instance Parameter a => Parameter [a] where - readParams = mapM readParam - -instance Parameter String where - readParam = Right - -instance Parameter Int where - readParam s = case reads s of - ((x, _):_) -> Right x - _ -> Left $ "Invalid integer: " ++ s - --- | The input for a resource. --- --- Each resource can define its own instance of 'Request' and then more --- easily ensure that it received the correct input (ie, correct variables, --- properly typed). -class Request a where - parseRequest :: RequestParser a - -instance Request () where - parseRequest = return () - -type ContentType = String - --- | The output for a resource. -class Response a where - -- | Provide an ordered list of possible responses, depending on 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, Hack.Response)] - --- | Wrapper around 'Hack.Response' to allow arbitrary pieces of data to be --- used for the body. -response :: LazyByteString lbs - => Int - -> [(String, String)] - -> lbs - -> Hack.Response -response a b c = Hack.Response a b $ toLazyByteString c - -instance Response () where - reps _ = [("text/plain", response 200 [] "")] - -newtype ErrorResponse = ErrorResponse String -instance Response ErrorResponse where - reps (ErrorResponse s) = [("text/plain", response 500 [] s)] - -data ResponseWrapper = forall res. Response res => ResponseWrapper res -instance Response ResponseWrapper where - reps (ResponseWrapper res) = reps res - --- | Contains settings and a list of resources. -type ApplicationMonad = StateT ApplicationSettings (Writer [Resource]) -instance Applicative ApplicationMonad where - pure = return - f <*> a = do - f' <- f - a' <- a - return $! f' a' -data ApplicationSettings = ApplicationSettings - { hackHandler :: Hack.Application -> IO () - , rpxnowApiKey :: Maybe String - , encryptKey :: Either FilePath Word256 - , urlRewriter :: UrlRewriter - , hackMiddleware :: [Hack.Middleware] - , response404 :: Hack.Env -> IO Hack.Response - , htmlWrapper :: BS.ByteString -> BS.ByteString - } -instance Default ApplicationSettings where - def = ApplicationSettings - { hackHandler = Hack.Handler.CGI.run - , rpxnowApiKey = Nothing - , encryptKey = Left defaultKeyFile - , urlRewriter = \s -> (s, []) - , hackMiddleware = [gzip, cleanPath, jsonp] - , response404 = default404 - , htmlWrapper = id - } - -default404 :: Hack.Env -> IO Hack.Response -default404 env = return $ - Hack.Response - 404 - [("Content-Type", "text/plain")] - $ toLazyByteString $ "Not found: " ++ Hack.pathInfo env - -data Handler = forall req res. (Request req, Response res) - => Handler (req -> IO res) -type LiftedHandler = RawRequest -> IO ResponseWrapper - -liftHandler :: - Handler - -> RawRequest - -> IO ResponseWrapper -liftHandler (Handler h) rr = do - case runRequestParser parseRequest rr of - Left errors -> return $ ResponseWrapper - $ ErrorResponse - $ unlines errors - Right req -> ResponseWrapper `fmap` h req - -type PathInfo = [String] -data Resource = Resource [Hack.RequestMethod] PathInfo LiftedHandler - --- FIXME document below here - -addResource :: (Request req, Response res) - => [Hack.RequestMethod] - -> PathInfo - -> (req -> IO res) - -> ApplicationMonad () -addResource methods path f = - tell [Resource methods path $ liftHandler $ Handler f] - -setUrlRewriter :: UrlRewriter -> ApplicationMonad () -setUrlRewriter newUrlRewriter = do - s <- get - put $ s { urlRewriter = newUrlRewriter } - -setHtmlWrapper :: (BS.ByteString -> BS.ByteString) -> ApplicationMonad () -setHtmlWrapper f = do - s <- get - put $ s { htmlWrapper = f } - -run :: ApplicationMonad () -> IO () -run m = do - let (settings, resources') = runWriter $ execStateT m def - key <- case encryptKey settings of - Left f -> getKey f - Right k -> return k - let defApp = defaultResources settings - defResources = execWriter $ execStateT defApp def - resources = resources' ++ defResources - app' :: Hack.Application - app' = makeApplication' resources settings - clientsession' :: Hack.Middleware - clientsession' = clientsession [authCookieName] key - app :: Hack.Application - app = foldr ($) app' $ hackMiddleware settings ++ [clientsession'] - hackHandler settings app - -setHandler :: (Hack.Application -> IO ()) -> ApplicationMonad () -setHandler h = do - settings <- get - put $ settings { hackHandler = h } - -setRpxnowApiKey :: String -> ApplicationMonad () -setRpxnowApiKey k = do - settings <- get - put $ settings { rpxnowApiKey = Just k } - -defaultResources :: ApplicationSettings -> ApplicationMonad () -defaultResources settings = do - addResource [Hack.GET] ["auth", "check"] authCheck - addResource [Hack.GET] ["auth", "logout"] authLogout - addResource [Hack.GET] ["auth", "openid"] authOpenidForm - addResource [Hack.GET] ["auth", "openid", "forward"] authOpenidForward - addResource [Hack.GET] ["auth", "openid", "complete"] authOpenidComplete - case rpxnowApiKey settings of - Nothing -> return () - Just key -> do - addResource [Hack.GET] ["auth", "login", "rpxnow"] $ - rpxnowLogin key - -data OIDFormReq = OIDFormReq (Maybe String) (Maybe String) -instance Request OIDFormReq where - parseRequest = OIDFormReq <$> getParam "message" <*> getParam "dest" -instance Show OIDFormReq where - show (OIDFormReq Nothing _) = "" - show (OIDFormReq (Just s) _) = "

" ++ encodeHtml s ++ - "

" -data OIDFormRes = OIDFormRes String (Maybe String) -instance Response OIDFormRes where - reps (OIDFormRes s dest) = [("text/html", response 200 heads s)] - where - heads = - case dest of - Nothing -> [] - Just dest' -> - [("Set-Cookie", "DEST=" ++ dest' ++ "; path=/")] -authOpenidForm :: OIDFormReq -> IO OIDFormRes -authOpenidForm m@(OIDFormReq _ dest) = - let html = - show m ++ - "
" ++ - "OpenID: " ++ - "" ++ - "
" - in return $! OIDFormRes html dest -data OIDFReq = OIDFReq String String -instance Request OIDFReq where - parseRequest = do - oid <- getParam "openid" - env <- parseEnv - let complete = "http://" ++ Hack.serverName env ++ ":" ++ - show (Hack.serverPort env) ++ - "/auth/openid/complete/" - return $! OIDFReq oid complete -authOpenidForward :: OIDFReq -> IO GenResponse -authOpenidForward (OIDFReq oid complete) = do - res <- OpenId.getForwardUrl oid complete :: IO (Either String String) - return $ - case res of - Left err -> RedirectResponse $ "/auth/openid/?message=" ++ - encodeUrl err - Right url -> RedirectResponse url - -data OIDComp = OIDComp [(String, String)] (Maybe String) -instance Request OIDComp where - parseRequest = do - rr <- ask - let gets = rawGetParams rr - dest <- cookieParam "DEST" - return $! OIDComp gets dest -data OIDCompRes = OIDCompResErr String - | OIDCompResGood String (Maybe String) -instance Response OIDCompRes where - reps (OIDCompResErr err) = - reps $ RedirectResponse - $ "/auth/openid/?message=" ++ - encodeUrl err - reps (OIDCompResGood ident Nothing) = - reps $ OIDCompResGood ident (Just "/") - reps (OIDCompResGood ident (Just dest)) = - [("text/plain", response 303 heads "")] where - heads = - [ (authCookieName, ident) - , resetCookie "DEST" - , ("Location", dest) - ] - -resetCookie :: String -> (String, String) -resetCookie name = - ("Set-Cookie", - name ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") - -authOpenidComplete :: OIDComp -> IO OIDCompRes -authOpenidComplete (OIDComp gets' dest) = do - res <- OpenId.authenticate gets' :: IO (Either String OpenId.Identifier) - return $ - case res of - Left err -> OIDCompResErr err - Right (OpenId.Identifier ident) -> OIDCompResGood ident dest - --- | token dest -data RpxnowRequest = RpxnowRequest String (Maybe String) -instance Request RpxnowRequest where - parseRequest = do - token <- getParam "token" - dest <- getParam "dest" - return $! RpxnowRequest token $ chopHash `fmap` dest - -chopHash :: String -> String -chopHash ('#':rest) = rest -chopHash x = x - --- | dest identifier -data RpxnowResponse = RpxnowResponse String (Maybe String) -instance Response RpxnowResponse where - reps (RpxnowResponse dest Nothing) = - [("text/html", response 303 [("Location", dest)] "")] - reps (RpxnowResponse dest (Just ident)) = - [("text/html", response 303 - [ ("Location", dest) - , (authCookieName, ident) - ] - "")] - -rpxnowLogin :: String -- ^ api key - -> RpxnowRequest - -> IO RpxnowResponse -rpxnowLogin apiKey (RpxnowRequest token dest') = do - let dest = case dest' of - Nothing -> "/" - Just "" -> "/" - Just s -> s - ident' <- Rpxnow.authenticate apiKey token - return $ RpxnowResponse dest (Rpxnow.identifier `fmap` ident') - -authCookieName :: String -authCookieName = "IDENTIFIER" - -data AuthRequest = AuthRequest (Maybe String) -instance Request AuthRequest where - parseRequest = AuthRequest `fmap` identifier - -authCheck :: AuthRequest -> IO Tree -authCheck (AuthRequest Nothing) = - return $ TreeMap [("status", TreeScalar "notloggedin")] -authCheck (AuthRequest (Just i)) = - return $ TreeMap $ - [ ("status", TreeScalar "loggedin") - , ("ident", TreeScalar i) - ] - -authLogout :: () -> IO LogoutResponse -authLogout _ = return LogoutResponse - -data LogoutResponse = LogoutResponse -instance Response LogoutResponse where - reps _ = map (second addCookie) $ reps tree where - tree = TreeMap [("status", TreeScalar "loggedout")] - addCookie (Hack.Response s h c) = - Hack.Response s (h':h) c - h' = resetCookie authCookieName - -makeApplication' :: [Resource] - -> ApplicationSettings - -> Hack.Env - -> IO Hack.Response -makeApplication' resources settings env = do - let method = Hack.requestMethod env - rr = envToRawRequest (urlRewriter settings) env - path' = rawPathInfo rr - isValid :: Resource -> Bool - isValid (Resource methods path _) = method `elem` methods - && path == path' - case filter isValid resources of - [Resource _ _ handler] -> do - let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env - ctypes' = parseHttpAccept rawHttpAccept - body <- handler rr - let reps' = reps body - ctypes = filter (\c -> isJust $ lookup c reps') ctypes' - let handlerPair = - case ctypes of - [] -> Just $ head reps' - (c:_) -> - case filter (fst `equals` c) reps' of - [pair] -> Just pair - [] -> Nothing - _ -> error "Overlapping reps" - case handlerPair of - Nothing -> response404 settings $ env - Just (ctype, Hack.Response status headers content) -> do - let wrapper = - case ctype of - "text/html" -> htmlWrapper settings - _ -> id - return $ Hack.Response status - (("Content-Type", ctype) : headers) - $ toLazyByteString $ wrapper content - [] -> response404 settings $ env - _ -> fail "Overlapping handlers" - -type UrlRewriter = PathInfo -> (PathInfo, [(String, String)]) -envToRawRequest :: UrlRewriter -> Hack.Env -> RawRequest -envToRawRequest rewriter env = - let (Right rawPieces) = splitPath $ Hack.pathInfo env - (pi', urls) = rewriter rawPieces - gets' = decodeUrlPairs $ Hack.queryString env :: [(String, String)] - clength = tryLookup "0" "Content-Length" $ Hack.http env - ctype = tryLookup "" "Content-Type" $ Hack.http env - (posts, files) = parsePost ctype clength - $ Hack.hackInput env - rawCookie = tryLookup "" "Cookie" $ Hack.http env - cookies' = decodeCookies rawCookie :: [(String, String)] - in RawRequest pi' urls gets' posts cookies' files env - -data Tree = TreeScalar String - | TreeList [Tree] - | TreeMap [(String, Tree)] -class IsTree a where - toTree :: a -> Tree - -treeToJson :: Tree -> String -treeToJson (TreeScalar s) = '"' : encodeJson s ++ "\"" -treeToJson (TreeList l) = - "[" ++ intercalate "," (map treeToJson l) ++ "]" -treeToJson (TreeMap m) = - "{" ++ intercalate "," (map helper m) ++ "}" where - helper (k, v) = - treeToJson (TreeScalar k) ++ - ":" ++ - treeToJson v - -treeToHtml :: Tree -> String -treeToHtml (TreeScalar s) = encodeHtml s -treeToHtml (TreeList l) = - "" -treeToHtml (TreeMap m) = - "
" ++ - concatMap (\(k, v) -> "
" ++ encodeHtml k ++ "
" ++ - "
" ++ treeToHtml v ++ "
") m ++ - "
" - -instance Response Tree where - reps tree = - [ ("text/html", response 200 [] $ treeToHtml tree) - , ("application/json", response 200 [] $ treeToJson tree) - ] - -parseHttpAccept :: String -> [String] -parseHttpAccept = filter (not . specialHttpAccept) . splitOneOf ";," - -specialHttpAccept :: String -> Bool -specialHttpAccept ('q':'=':_) = True -specialHttpAccept ('*':_) = True -specialHttpAccept _ = False - -data AtomFeed = AtomFeed - { atomTitle :: String - , atomLinkSelf :: String - , atomLinkHome :: String - , atomUpdated :: UTCTime - , atomEntries :: [AtomFeedEntry] - } -instance Response AtomFeed where - reps e = - [ ("application/atom+xml", response 200 [] $ show e) - ] - -data AtomFeedEntry = AtomFeedEntry - { atomEntryLink :: String - , atomEntryUpdated :: UTCTime - , atomEntryTitle :: String - , atomEntryContent :: String - } - -instance Show AtomFeed where - show f = concat - [ "\n" - , "" - , "" - , encodeHtml $ atomTitle f - , "" - , "" - , "" - , "" - , formatW3 $ atomUpdated f - , "" - , "" - , encodeHtml $ atomLinkHome f - , "" - , concatMap show $ atomEntries f - , "" - ] - -instance Show AtomFeedEntry where - show e = concat - [ "" - , "" - , encodeHtml $ atomEntryLink e - , "" - , "" - , "" - , formatW3 $ atomEntryUpdated e - , "" - , "" - , encodeHtml $ atomEntryTitle e - , "" - , "" - , "" - ] - -formatW3 :: UTCTime -> String -formatW3 = formatTime defaultTimeLocale "%FT%X-08:00" - -class IsTree a => ListDetail a where - htmlDetail :: a -> String - htmlDetail = treeToHtml . toTree - detailTitle :: a -> String - detailUrl :: a -> String - htmlList :: [a] -> String - htmlList l = "" - where - helper i = "
  • " ++ encodeHtml (detailTitle i) ++ - "
    • " - -- | Often times for the JSON response of the list, we don't need all - -- the information. - treeList :: [a] -> Tree - treeList = TreeList . map treeListSingle - treeListSingle :: a -> Tree - treeListSingle = toTree - -newtype ItemList a = ItemList [a] -instance ListDetail a => Response (ItemList a) where - reps (ItemList l) = - [ ("text/html", response 200 [] $ htmlList l) - , ("application/json", response 200 [] $ treeToJson $ treeList l) - ] -newtype ItemDetail a = ItemDetail a -instance ListDetail a => Response (ItemDetail a) where - reps (ItemDetail i) = - [ ("text/html", response 200 [] $ htmlDetail i) - , ("application/json", response 200 [] $ treeToJson $ toTree i) - ] - --- sitemaps -data SitemapLoc = AbsLoc String | RelLoc String -data SitemapChangeFreq = Always - | Hourly - | Daily - | Weekly - | Monthly - | Yearly - | Never -instance Show SitemapChangeFreq where - show Always = "always" - show Hourly = "hourly" - show Daily = "daily" - show Weekly = "weekly" - show Monthly = "monthly" - show Yearly = "yearly" - show Never = "never" - -data SitemapUrl = SitemapUrl - { sitemapLoc :: SitemapLoc - , sitemapLastMod :: UTCTime - , sitemapChangeFreq :: SitemapChangeFreq - , priority :: Double - } -data SitemapRequest = SitemapRequest String Int -instance Request SitemapRequest where - parseRequest = do - env <- parseEnv - return $! SitemapRequest (Hack.serverName env) - (Hack.serverPort env) -data SitemapResponse = SitemapResponse SitemapRequest [SitemapUrl] -instance Show SitemapResponse where - show (SitemapResponse (SitemapRequest host port) urls) = - "\n" ++ - "" ++ - concatMap helper urls ++ - "" - where - prefix = "http://" ++ host ++ - case port of - 80 -> "" - _ -> ":" ++ show port - helper (SitemapUrl loc modTime freq pri) = concat - [ "" - , encodeHtml $ showLoc loc - , "" - , formatW3 modTime - , "" - , show freq - , "" - , show pri - , "" - ] - showLoc (AbsLoc s) = s - showLoc (RelLoc s) = prefix ++ s - -instance Response SitemapResponse where - reps res = - [ ("text/xml", response 200 [] $ show res) - ] - -sitemap :: IO [SitemapUrl] -> SitemapRequest -> IO SitemapResponse -sitemap urls' req = do - urls <- urls' - return $ SitemapResponse req urls - --- misc helper functions -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 - -data GenResponse = HtmlResponse String - | TreeResponse Tree - | HtmlOrTreeResponse String Tree - | RedirectResponse String - | PermissionDeniedResult String - | NotFoundResponse String -instance Response GenResponse where - reps (HtmlResponse h) = [("text/html", response 200 [] h)] - reps (TreeResponse t) = reps t - reps (HtmlOrTreeResponse h t) = - ("text/html", response 200 [] h) : reps t - reps (RedirectResponse url) = [("text/html", response 303 heads body)] - where - heads = [("Location", url)] - body = "

    Redirecting to " ++ encodeHtml url ++ "

    " - reps (PermissionDeniedResult s) = [("text/plain", response 403 [] s)] - reps (NotFoundResponse s) = [("text/plain", response 404 [] s)] +import Data.Object +import Web.Restful.Request +import Web.Restful.Response +import Web.Restful.Application diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs new file mode 100644 index 00000000..84c30672 --- /dev/null +++ b/Web/Restful/Application.hs @@ -0,0 +1,362 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ExistentialQuantification #-} +--------------------------------------------------------- +-- +-- Module : Web.Restful.Application +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Defining the application. +-- +--------------------------------------------------------- +module Web.Restful.Application + ( + -- * Defining an application + ApplicationMonad + -- ** Routing + , addResource + -- ** Settings + , setHandler + , setRpxnowApiKey + , setUrlRewriter + , setHtmlWrapper + -- ** Engage + , run + ) where + +-- hideously long import list +import qualified Hack +import qualified Hack.Handler.CGI +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.State hiding (gets) +import Web.Encodings +import Data.Maybe (isJust) +import Data.ByteString.Class +import qualified Data.ByteString.Lazy as BS +import Data.Function.Predicate (equals) +import Data.Default +import qualified Web.Authenticate.Rpxnow as Rpxnow +import qualified Web.Authenticate.OpenId as OpenId + +import Hack.Middleware.Gzip +import Hack.Middleware.CleanPath +import Hack.Middleware.Jsonp +import Hack.Middleware.ClientSession + +import Control.Applicative ((<$>), Applicative (..)) +import Control.Arrow (second) + +import Web.Restful.Request +import Web.Restful.Response +import Web.Restful.Constants +import Web.Restful.Utils +import Data.Object + +-- | Contains settings and a list of resources. +type ApplicationMonad = StateT ApplicationSettings (Writer [Resource]) +instance Applicative ApplicationMonad where + pure = return + f <*> a = do + f' <- f + a' <- a + return $! f' a' +data ApplicationSettings = ApplicationSettings + { hackHandler :: Hack.Application -> IO () + , rpxnowApiKey :: Maybe String + , encryptKey :: Either FilePath Word256 + , urlRewriter :: UrlRewriter + , hackMiddleware :: [Hack.Middleware] + , response404 :: Hack.Env -> IO Hack.Response + , htmlWrapper :: BS.ByteString -> BS.ByteString + } +instance Default ApplicationSettings where + def = ApplicationSettings + { hackHandler = Hack.Handler.CGI.run + , rpxnowApiKey = Nothing + , encryptKey = Left defaultKeyFile + , urlRewriter = \s -> (s, []) + , hackMiddleware = [gzip, cleanPath, jsonp] + , response404 = default404 + , htmlWrapper = id + } + +default404 :: Hack.Env -> IO Hack.Response +default404 env = return $ + Hack.Response + 404 + [("Content-Type", "text/plain")] + $ toLazyByteString $ "Not found: " ++ Hack.pathInfo env + +data Handler = forall req res. (Request req, Response res) + => Handler (req -> IO res) +type LiftedHandler = RawRequest -> IO ResponseWrapper + +liftHandler :: + Handler + -> RawRequest + -> IO ResponseWrapper +liftHandler (Handler h) rr = do + case runRequestParser parseRequest rr of + Left errors -> return $ ResponseWrapper + $ ErrorResponse + $ unlines errors + Right req -> ResponseWrapper `fmap` h req + +data Resource = Resource [Hack.RequestMethod] PathInfo LiftedHandler + +-- FIXME document below here + +addResource :: (Request req, Response res) + => [Hack.RequestMethod] + -> PathInfo + -> (req -> IO res) + -> ApplicationMonad () +addResource methods path f = + tell [Resource methods path $ liftHandler $ Handler f] + +setUrlRewriter :: UrlRewriter -> ApplicationMonad () +setUrlRewriter newUrlRewriter = do + s <- get + put $ s { urlRewriter = newUrlRewriter } + +setHtmlWrapper :: (BS.ByteString -> BS.ByteString) -> ApplicationMonad () +setHtmlWrapper f = do + s <- get + put $ s { htmlWrapper = f } + +run :: ApplicationMonad () -> IO () +run m = do + let (settings, resources') = runWriter $ execStateT m def + key <- case encryptKey settings of + Left f -> getKey f + Right k -> return k + let defApp = defaultResources settings + defResources = execWriter $ execStateT defApp def + resources = resources' ++ defResources + app' :: Hack.Application + app' = makeApplication' resources settings + clientsession' :: Hack.Middleware + clientsession' = clientsession [authCookieName] key + app :: Hack.Application + app = foldr ($) app' $ hackMiddleware settings ++ [clientsession'] + hackHandler settings app + +setHandler :: (Hack.Application -> IO ()) -> ApplicationMonad () +setHandler h = do + settings <- get + put $ settings { hackHandler = h } + +setRpxnowApiKey :: String -> ApplicationMonad () +setRpxnowApiKey k = do + settings <- get + put $ settings { rpxnowApiKey = Just k } + +defaultResources :: ApplicationSettings -> ApplicationMonad () +defaultResources settings = do + addResource [Hack.GET] ["auth", "check"] authCheck + addResource [Hack.GET] ["auth", "logout"] authLogout + addResource [Hack.GET] ["auth", "openid"] authOpenidForm + addResource [Hack.GET] ["auth", "openid", "forward"] authOpenidForward + addResource [Hack.GET] ["auth", "openid", "complete"] authOpenidComplete + case rpxnowApiKey settings of + Nothing -> return () + Just key -> do + addResource [Hack.GET] ["auth", "login", "rpxnow"] $ + rpxnowLogin key + +data OIDFormReq = OIDFormReq (Maybe String) (Maybe String) +instance Request OIDFormReq where + parseRequest = OIDFormReq <$> getParam "message" <*> getParam "dest" +instance Show OIDFormReq where + show (OIDFormReq Nothing _) = "" + show (OIDFormReq (Just s) _) = "

    " ++ encodeHtml s ++ + "

    " +data OIDFormRes = OIDFormRes String (Maybe String) +instance Response OIDFormRes where + reps (OIDFormRes s dest) = [("text/html", response 200 heads s)] + where + heads = + case dest of + Nothing -> [] + Just dest' -> + [("Set-Cookie", "DEST=" ++ dest' ++ "; path=/")] +authOpenidForm :: OIDFormReq -> IO OIDFormRes +authOpenidForm m@(OIDFormReq _ dest) = + let html = + show m ++ + "
    " ++ + "OpenID: " ++ + "" ++ + "
    " + in return $! OIDFormRes html dest +data OIDFReq = OIDFReq String String +instance Request OIDFReq where + parseRequest = do + oid <- getParam "openid" + env <- parseEnv + let complete = "http://" ++ Hack.serverName env ++ ":" ++ + show (Hack.serverPort env) ++ + "/auth/openid/complete/" + return $! OIDFReq oid complete +authOpenidForward :: OIDFReq -> IO GenResponse +authOpenidForward (OIDFReq oid complete) = do + res <- OpenId.getForwardUrl oid complete :: IO (Either String String) + return $ + case res of + Left err -> RedirectResponse $ "/auth/openid/?message=" ++ + encodeUrl err + Right url -> RedirectResponse url + +data OIDComp = OIDComp [(String, String)] (Maybe String) +instance Request OIDComp where + parseRequest = do + rr <- ask + let gets = rawGetParams rr + dest <- cookieParam "DEST" + return $! OIDComp gets dest +data OIDCompRes = OIDCompResErr String + | OIDCompResGood String (Maybe String) +instance Response OIDCompRes where + reps (OIDCompResErr err) = + reps $ RedirectResponse + $ "/auth/openid/?message=" ++ + encodeUrl err + reps (OIDCompResGood ident Nothing) = + reps $ OIDCompResGood ident (Just "/") + reps (OIDCompResGood ident (Just dest)) = + [("text/plain", response 303 heads "")] where + heads = + [ (authCookieName, ident) + , resetCookie "DEST" + , ("Location", dest) + ] + +resetCookie :: String -> (String, String) +resetCookie name = + ("Set-Cookie", + name ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") + +authOpenidComplete :: OIDComp -> IO OIDCompRes +authOpenidComplete (OIDComp gets' dest) = do + res <- OpenId.authenticate gets' :: IO (Either String OpenId.Identifier) + return $ + case res of + Left err -> OIDCompResErr err + Right (OpenId.Identifier ident) -> OIDCompResGood ident dest + +-- | token dest +data RpxnowRequest = RpxnowRequest String (Maybe String) +instance Request RpxnowRequest where + parseRequest = do + token <- getParam "token" + dest <- getParam "dest" + return $! RpxnowRequest token $ chopHash `fmap` dest + +chopHash :: String -> String +chopHash ('#':rest) = rest +chopHash x = x + +-- | dest identifier +data RpxnowResponse = RpxnowResponse String (Maybe String) +instance Response RpxnowResponse where + reps (RpxnowResponse dest Nothing) = + [("text/html", response 303 [("Location", dest)] "")] + reps (RpxnowResponse dest (Just ident)) = + [("text/html", response 303 + [ ("Location", dest) + , (authCookieName, ident) + ] + "")] + +rpxnowLogin :: String -- ^ api key + -> RpxnowRequest + -> IO RpxnowResponse +rpxnowLogin apiKey (RpxnowRequest token dest') = do + let dest = case dest' of + Nothing -> "/" + Just "" -> "/" + Just s -> s + ident' <- Rpxnow.authenticate apiKey token + return $ RpxnowResponse dest (Rpxnow.identifier `fmap` ident') + +data AuthRequest = AuthRequest (Maybe String) +instance Request AuthRequest where + parseRequest = AuthRequest `fmap` identifier + +authCheck :: AuthRequest -> IO Object +authCheck (AuthRequest Nothing) = + return $ toObject [("status", "notloggedin")] +authCheck (AuthRequest (Just i)) = + return $ toObject + [ ("status", "loggedin") + , ("ident", i) + ] + +authLogout :: () -> IO LogoutResponse +authLogout _ = return LogoutResponse + +data LogoutResponse = LogoutResponse +instance Response LogoutResponse where + reps _ = map (second addCookie) $ reps tree where + tree = toObject [("status", "loggedout")] + addCookie (Hack.Response s h c) = + Hack.Response s (h':h) c + h' = resetCookie authCookieName + +makeApplication' :: [Resource] + -> ApplicationSettings + -> Hack.Env + -> IO Hack.Response +makeApplication' resources settings env = do + let method = Hack.requestMethod env + rr = envToRawRequest (urlRewriter settings) env + path' = rawPathInfo rr + isValid :: Resource -> Bool + isValid (Resource methods path _) = method `elem` methods + && path == path' + case filter isValid resources of + [Resource _ _ handler] -> do + let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env + ctypes' = parseHttpAccept rawHttpAccept + body <- handler rr + let reps' = reps body + ctypes = filter (\c -> isJust $ lookup c reps') ctypes' + let handlerPair = + case ctypes of + [] -> Just $ head reps' + (c:_) -> + case filter (fst `equals` c) reps' of + [pair] -> Just pair + [] -> Nothing + _ -> error "Overlapping reps" + case handlerPair of + Nothing -> response404 settings $ env + Just (ctype, Hack.Response status headers content) -> do + let wrapper = + case ctype of + "text/html" -> htmlWrapper settings + _ -> id + return $ Hack.Response status + (("Content-Type", ctype) : headers) + $ toLazyByteString $ wrapper content + [] -> response404 settings $ env + _ -> fail "Overlapping handlers" + +type UrlRewriter = PathInfo -> (PathInfo, [(String, String)]) +envToRawRequest :: UrlRewriter -> Hack.Env -> RawRequest +envToRawRequest rewriter env = + let (Right rawPieces) = splitPath $ Hack.pathInfo env + (pi', urls) = rewriter rawPieces + gets' = decodeUrlPairs $ Hack.queryString env :: [(String, String)] + clength = tryLookup "0" "Content-Length" $ Hack.http env + ctype = tryLookup "" "Content-Type" $ Hack.http env + (posts, files) = parsePost ctype clength + $ Hack.hackInput env + rawCookie = tryLookup "" "Cookie" $ Hack.http env + cookies' = decodeCookies rawCookie :: [(String, String)] + in RawRequest pi' urls gets' posts cookies' files env diff --git a/Web/Restful/Constants.hs b/Web/Restful/Constants.hs new file mode 100644 index 00000000..c39aa532 --- /dev/null +++ b/Web/Restful/Constants.hs @@ -0,0 +1,17 @@ +--------------------------------------------------------- +-- +-- Module : Web.Restful.Constants +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Constants used throughout Restful. +-- +--------------------------------------------------------- +module Web.Restful.Constants where + +authCookieName :: String +authCookieName = "IDENTIFIER" diff --git a/Web/Restful/Request.hs b/Web/Restful/Request.hs new file mode 100644 index 00000000..9f98849b --- /dev/null +++ b/Web/Restful/Request.hs @@ -0,0 +1,271 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE OverlappingInstances #-} +--------------------------------------------------------- +-- +-- Module : Web.Restful.Request +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Code for extracting parameters from requests. +-- +--------------------------------------------------------- +module Web.Restful.Request + ( + -- * Request parsing + -- $param_overview + + -- ** Types + ParamError + , ParamName + , ParamValue + -- ** Parameter type class + , Parameter (..) + -- ** RequestParser helpers + , getParam + , postParam + , urlParam + , anyParam + , cookieParam + , identifier + , acceptedLanguages + , requestPath + -- ** Building actual request + , Request (..) + , Hack.RequestMethod (..) + -- ** FIXME + , parseEnv + , RawRequest (..) + , PathInfo + , runRequestParser + ) where + +import qualified Hack +import Data.Function.Predicate (equals) +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.Error () +import Web.Restful.Constants +import Web.Restful.Utils +import Control.Applicative (Applicative (..)) +import Web.Encodings + +-- $param_overview +-- In Restful, all of the underlying parameter values are strings. They can +-- come from multiple sources: GET parameters, URL rewriting (FIXME: link), +-- cookies, etc. However, most applications eventually want to convert +-- those strings into something else, like 'Int's. Additionally, it is +-- often desirable to allow multiple values, or no value at all. +-- +-- That is what the parameter concept is for. A 'Parameter' is any value +-- which can be converted from a 'String', or list of 'String's. + +-- | Any kind of error message generated in the parsing stage. +type ParamError = String + +-- | In GET parameters, the key. In cookies, the cookie name. So on and so +-- forth. +type ParamName = String + +-- | The 'String' value of a parameter, such as cookie content. +type ParamValue = String + +-- | Anything which can be converted from a 'String' or list of 'String's. +-- +-- The default implementation of 'readParams' will error out if given +-- anything but 1 'ParamValue'. This is usually what you want. +-- +-- Minimal complete definition: either 'readParam' or 'readParams'. +class Parameter a where + -- | Convert a string into the desired value, or explain why that can't + -- happen. + readParam :: ParamValue -> Either ParamError a + readParam = readParams . return + + -- | Convert a list of strings into the desired value, or explain why + -- that can't happen. + readParams :: [ParamValue] -> Either ParamError a + readParams [x] = readParam x + readParams [] = Left "Missing parameter" + readParams xs = Left $ "Given " ++ show (length xs) ++ + " values, expecting 1" + +-- | Attempt to parse a list of param values using 'readParams'. +-- If that fails, return an error message and an undefined value. This way, +-- we can process all of the parameters and get all of the error messages. +-- Be careful not to use the value inside until you can be certain the +-- reading succeeded. +tryReadParams:: Parameter a + => ParamName + -> [ParamValue] + -> RequestParser a +tryReadParams name params = + case readParams params of + Left s -> do + tell [name ++ ": " ++ s] + return $ + error $ + "Trying to evaluate nonpresent parameter " ++ + name + Right x -> return x + +-- | Helper function for generating 'RequestParser's from various +-- 'ParamValue' lists. +genParam :: Parameter a + => (RawRequest -> ParamName -> [ParamValue]) + -> ParamName + -> RequestParser a +genParam f name = do + req <- ask + tryReadParams name $ f req name + +-- | Parse a value passed as a GET parameter. +getParam :: Parameter a => ParamName -> RequestParser a +getParam = genParam getParams + +-- | Parse a value passed as a POST parameter. +postParam :: Parameter a => ParamName -> RequestParser a +postParam = genParam postParams + +-- | Parse a value passed in the URL and extracted using rewrite. +-- (FIXME: link to rewrite section.) +urlParam :: Parameter a => ParamName -> RequestParser a +urlParam = genParam urlParams + +-- | Parse a value passed as a GET, POST or URL parameter. +anyParam :: Parameter a => ParamName -> RequestParser a +anyParam = genParam anyParams + +-- | Parse a value passed as a raw cookie. +cookieParam :: Parameter a => ParamName -> RequestParser a +cookieParam = genParam cookies + +-- | Parse a value in the hackHeader field. +hackHeaderParam :: Parameter a => ParamName -> RequestParser a +hackHeaderParam name = do + env <- parseEnv + let vals' = lookup name $ Hack.hackHeaders env + vals = case vals' of + Nothing -> [] + Just x -> [x] + tryReadParams name vals + +-- | Extract the cookie which specifies the identifier for a logged in +-- user. +identifier :: Parameter a => RequestParser a +identifier = hackHeaderParam authCookieName + +-- | Get the raw 'Hack.Env' value. +parseEnv :: RequestParser Hack.Env +parseEnv = rawEnv `fmap` ask + +-- | Determine the ordered list of language preferences. +-- +-- FIXME: Future versions should account for some cookie. +acceptedLanguages :: RequestParser [String] +acceptedLanguages = do + env <- parseEnv + let rawLang = tryLookup "" "Accept-Language" $ Hack.http env + return $! parseHttpAccept rawLang + +-- | Determinge the path requested by the user (ie, the path info). +requestPath :: RequestParser String +requestPath = do + env <- parseEnv + let q = case Hack.queryString env of + "" -> "" + q'@('?':_) -> q' + q' -> q' + return $! Hack.pathInfo env ++ q + +type RequestParser a = WriterT [ParamError] (Reader RawRequest) a +instance Applicative (WriterT [ParamError] (Reader RawRequest)) where + pure = return + f <*> a = do + f' <- f + a' <- a + return $! f' a' + +-- | Parse a request into either the desired 'Request' or a list of errors. +runRequestParser :: RequestParser a -> RawRequest -> Either [ParamError] a +runRequestParser p req = + let (val, errors) = (runReader (runWriterT p)) req + in case errors of + [] -> Right val + x -> Left x + +-- | The raw information passed through Hack, cleaned up a bit. +data RawRequest = RawRequest + { rawPathInfo :: PathInfo + , rawUrlParams :: [(ParamName, ParamValue)] + , rawGetParams :: [(ParamName, ParamValue)] + , rawPostParams :: [(ParamName, ParamValue)] + , rawCookies :: [(ParamName, ParamValue)] + , rawFiles :: [(ParamName, FileInfo)] + , rawEnv :: Hack.Env + } + +-- | All GET paramater values with the given name. +getParams :: RawRequest -> ParamName -> [ParamValue] +getParams rr name = map snd + . filter (\x -> name == fst x) + . rawGetParams + $ rr + +-- | All POST paramater values with the given name. +postParams :: RawRequest -> ParamName -> [ParamValue] +postParams rr name = map snd + . filter (\x -> name == fst x) + . rawPostParams + $ rr + +-- | All URL paramater values (see rewriting) with the given name. +urlParams :: RawRequest -> ParamName -> [ParamValue] +urlParams rr name = map snd + . filter (\x -> name == fst x) + . rawUrlParams + $ rr + +-- | All GET, POST and URL paramater values (see rewriting) with the given name. +anyParams :: RawRequest -> ParamName -> [ParamValue] +anyParams req name = urlParams req name ++ + getParams req name ++ + postParams req name + +-- | All cookies with the given name. +cookies :: RawRequest -> ParamName -> [ParamValue] +cookies rr name = map snd . filter (fst `equals` name) . rawCookies $ rr + +instance Parameter a => Parameter (Maybe a) where + readParams [] = Right Nothing + readParams [x] = readParam x >>= return . Just + readParams xs = Left $ "Given " ++ show (length xs) ++ + " values, expecting 0 or 1" + +instance Parameter a => Parameter [a] where + readParams = mapM readParam + +instance Parameter String where + readParam = Right + +instance Parameter Int where + readParam s = case reads s of + ((x, _):_) -> Right x + _ -> Left $ "Invalid integer: " ++ s + +-- | The input for a resource. +-- +-- Each resource can define its own instance of 'Request' and then more +-- easily ensure that it received the correct input (ie, correct variables, +-- properly typed). +class Request a where + parseRequest :: RequestParser a + +instance Request () where + parseRequest = return () + +type PathInfo = [String] diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs new file mode 100644 index 00000000..8fd46e7c --- /dev/null +++ b/Web/Restful/Response.hs @@ -0,0 +1,293 @@ +{-# LANGUAGE ExistentialQuantification #-} +--------------------------------------------------------- +-- +-- Module : Web.Restful.Response +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Generating responses. +-- +--------------------------------------------------------- +module Web.Restful.Response + ( + -- * Response construction + Response (..) + , response + -- ** Helper 'Response' instances + -- *** Atom news feed + , AtomFeed (..) + , AtomFeedEntry (..) + -- *** Sitemap + , sitemap + , SitemapUrl (..) + , SitemapLoc (..) + , SitemapChangeFreq (..) + -- *** Generics + -- **** List/detail + , ListDetail (..) + , ItemList (..) + , ItemDetail (..) + -- **** Multiple response types. + , GenResponse (..) + -- * FIXME + , ResponseWrapper (..) + , ErrorResponse (..) + ) where + +import Data.ByteString.Class +import qualified Hack +import Data.Time.Format +import Data.Time.Clock +import Web.Encodings +import System.Locale +import Web.Restful.Request -- FIXME ultimately remove +import Data.Object +import Data.List (intercalate) + +type ContentType = String + +-- | The output for a resource. +class Response a where + -- | Provide an ordered list of possible responses, depending on 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, Hack.Response)] + +-- | Wrapper around 'Hack.Response' to allow arbitrary pieces of data to be +-- used for the body. +response :: LazyByteString lbs + => Int + -> [(String, String)] + -> lbs + -> Hack.Response +response a b c = Hack.Response a b $ toLazyByteString c + +instance Response () where + reps _ = [("text/plain", response 200 [] "")] + +newtype ErrorResponse = ErrorResponse String +instance Response ErrorResponse where + reps (ErrorResponse s) = [("text/plain", response 500 [] s)] + +data ResponseWrapper = forall res. Response res => ResponseWrapper res +instance Response ResponseWrapper where + reps (ResponseWrapper res) = reps res + +data AtomFeed = AtomFeed + { atomTitle :: String + , atomLinkSelf :: String + , atomLinkHome :: String + , atomUpdated :: UTCTime + , atomEntries :: [AtomFeedEntry] + } +instance Response AtomFeed where + reps e = + [ ("application/atom+xml", response 200 [] $ show e) + ] + +data AtomFeedEntry = AtomFeedEntry + { atomEntryLink :: String + , atomEntryUpdated :: UTCTime + , atomEntryTitle :: String + , atomEntryContent :: String + } + +instance Show AtomFeed where + show f = concat + [ "\n" + , "" + , "" + , encodeHtml $ atomTitle f + , "" + , "" + , "" + , "" + , formatW3 $ atomUpdated f + , "" + , "" + , encodeHtml $ atomLinkHome f + , "" + , concatMap show $ atomEntries f + , "" + ] + +instance Show AtomFeedEntry where + show e = concat + [ "" + , "" + , encodeHtml $ atomEntryLink e + , "" + , "" + , "" + , formatW3 $ atomEntryUpdated e + , "" + , "" + , encodeHtml $ atomEntryTitle e + , "" + , "" + , "" + ] + +formatW3 :: UTCTime -> String +formatW3 = formatTime defaultTimeLocale "%FT%X-08:00" + +-- sitemaps +data SitemapLoc = AbsLoc String | RelLoc String +data SitemapChangeFreq = Always + | Hourly + | Daily + | Weekly + | Monthly + | Yearly + | Never +instance Show SitemapChangeFreq where + show Always = "always" + show Hourly = "hourly" + show Daily = "daily" + show Weekly = "weekly" + show Monthly = "monthly" + show Yearly = "yearly" + show Never = "never" + +data SitemapUrl = SitemapUrl + { sitemapLoc :: SitemapLoc + , sitemapLastMod :: UTCTime + , sitemapChangeFreq :: SitemapChangeFreq + , priority :: Double + } +data SitemapRequest = SitemapRequest String Int +instance Request SitemapRequest where + parseRequest = do + env <- parseEnv + return $! SitemapRequest (Hack.serverName env) + (Hack.serverPort env) +data SitemapResponse = SitemapResponse SitemapRequest [SitemapUrl] +instance Show SitemapResponse where + show (SitemapResponse (SitemapRequest host port) urls) = + "\n" ++ + "" ++ + concatMap helper urls ++ + "" + where + prefix = "http://" ++ host ++ + case port of + 80 -> "" + _ -> ":" ++ show port + helper (SitemapUrl loc modTime freq pri) = concat + [ "" + , encodeHtml $ showLoc loc + , "" + , formatW3 modTime + , "" + , show freq + , "" + , show pri + , "" + ] + showLoc (AbsLoc s) = s + showLoc (RelLoc s) = prefix ++ s + +instance Response SitemapResponse where + reps res = + [ ("text/xml", response 200 [] $ show res) + ] + +sitemap :: IO [SitemapUrl] -> SitemapRequest -> IO SitemapResponse +sitemap urls' req = do + urls <- urls' + return $ SitemapResponse req urls + +data GenResponse = HtmlResponse String + | ObjectResponse Object + | HtmlOrObjectResponse String Object + | RedirectResponse String + | PermissionDeniedResult String + | NotFoundResponse String +instance Response GenResponse where + reps (HtmlResponse h) = [("text/html", response 200 [] h)] + reps (ObjectResponse t) = reps t + reps (HtmlOrObjectResponse h t) = + ("text/html", response 200 [] h) : reps t + reps (RedirectResponse url) = [("text/html", response 303 heads body)] + where + heads = [("Location", url)] + body = "

    Redirecting to " ++ encodeHtml url ++ "

    " + reps (PermissionDeniedResult s) = [("text/plain", response 403 [] s)] + reps (NotFoundResponse s) = [("text/plain", response 404 [] s)] +class ToObject a => ListDetail a where + htmlDetail :: a -> String + htmlDetail = treeToHtml . toObject + detailTitle :: a -> String + detailUrl :: a -> String + htmlList :: [a] -> String + htmlList l = "
      " ++ concatMap helper l ++ "
    " + where + helper i = "
  • " ++ encodeHtml (detailTitle i) ++ + "
    • " + -- | Often times for the JSON response of the list, we don't need all + -- the information. + treeList :: [a] -> Object -- FIXME + treeList = Sequence . map treeListSingle + treeListSingle :: a -> Object + treeListSingle = toObject + +newtype ItemList a = ItemList [a] +instance ListDetail a => Response (ItemList a) where + reps (ItemList l) = + [ ("text/html", response 200 [] $ htmlList l) + , ("application/json", response 200 [] $ treeToJson $ treeList l) + ] +newtype ItemDetail a = ItemDetail a +instance ListDetail a => Response (ItemDetail a) where + reps (ItemDetail i) = + [ ("text/html", response 200 [] $ htmlDetail i) + , ("application/json", response 200 [] $ treeToJson $ toObject i) + ] + +-- FIXME remove treeTo functions, replace with Object instances +treeToJson :: Object -> String +treeToJson (Scalar s) = '"' : encodeJson (fromStrictByteString s) ++ "\"" +treeToJson (Sequence l) = + "[" ++ intercalate "," (map treeToJson l) ++ "]" +treeToJson (Mapping m) = + "{" ++ intercalate "," (map helper m) ++ "}" where + helper (k, v) = + treeToJson (Scalar k) ++ + ":" ++ + treeToJson v + +treeToHtml :: Object -> String +treeToHtml (Scalar s) = encodeHtml $ fromStrictByteString s +treeToHtml (Sequence l) = + "
      " ++ concatMap (\e -> "
    • " ++ treeToHtml e ++ "
      • ") l ++ + "
    " +treeToHtml (Mapping m) = + "
    " ++ + concatMap (\(k, v) -> "
    " ++ + encodeHtml (fromStrictByteString k) ++ + "
    " ++ + "
    " ++ + treeToHtml v ++ + "
    ") m ++ + "
    " + +instance Response Object where + reps tree = + [ ("text/html", response 200 [] $ treeToHtml tree) + , ("application/json", response 200 [] $ treeToJson tree) + ] diff --git a/Web/Restful/Utils.hs b/Web/Restful/Utils.hs new file mode 100644 index 00000000..605a9c99 --- /dev/null +++ b/Web/Restful/Utils.hs @@ -0,0 +1,33 @@ +--------------------------------------------------------- +-- +-- Module : Web.Restful.Utils +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Utility functions for Restful. +-- +--------------------------------------------------------- +module Web.Restful.Utils + ( parseHttpAccept + , tryLookup + ) where + +import Data.List.Split (splitOneOf) + +parseHttpAccept :: String -> [String] +parseHttpAccept = filter (not . specialHttpAccept) . splitOneOf ";," + +specialHttpAccept :: String -> Bool +specialHttpAccept ('q':'=':_) = True +specialHttpAccept ('*':_) = True +specialHttpAccept _ = False + +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 diff --git a/restful.cabal b/restful.cabal index 26910f74..dacf32c7 100644 --- a/restful.cabal +++ b/restful.cabal @@ -28,6 +28,12 @@ library bytestring >= 0.9.1.4, bytestring-class, web-encodings, - mtl >= 1.1.0.2 - exposed-modules: Web.Restful + mtl >= 1.1.0.2, + data-object + exposed-modules: Web.Restful, + Web.Restful.Constants, + Web.Restful.Request, + Web.Restful.Response, + Web.Restful.Utils, + Web.Restful.Application ghc-options: -Wall