diff --git a/.gitignore b/.gitignore new file mode 100644 index 00000000..39b806f8 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +dist +*.swp diff --git a/LICENSE b/LICENSE new file mode 100644 index 00000000..11dc17a1 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2008, Michael Snoyman. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README b/README index e69de29b..4ccea4d9 100644 --- a/README +++ b/README @@ -0,0 +1 @@ +A Restful front controller built on Hack. diff --git a/Setup.lhs b/Setup.lhs new file mode 100755 index 00000000..06e2708f --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/Web/Restful.hs b/Web/Restful.hs new file mode 100644 index 00000000..3e26bad6 --- /dev/null +++ b/Web/Restful.hs @@ -0,0 +1,888 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverlappingInstances #-} +--------------------------------------------------------- +-- +-- Module : Web.Restful +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Lightweight framework for designing RESTful APIs. +-- +--------------------------------------------------------- +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 + ) 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)] diff --git a/restful.cabal b/restful.cabal new file mode 100644 index 00000000..d48ec210 --- /dev/null +++ b/restful.cabal @@ -0,0 +1,17 @@ +name: restful +version: 0.0.0 +license: BSD3 +license-file: LICENSE +author: Michael Snoyman +maintainer: Michael Snoyman +synopsis: A Restful front controller built on Hack. +category: Web +stability: unstable +cabal-version: >= 1.2 +build-type: Simple +homepage: http://github.com/snoyberg/restful/tree/master + +library + build-depends: base + exposed-modules: Web.Restful + ghc-options: -Wall