Massive overhaul of Request system

Web/Restful/Application.hs

@@ -77,6 +77,8 @@ class ResourceName a b => RestfulApp a b | a -> b where
             [ ("errorMsg", toObject "Invalid arguments")
             , ("messages", toObject ia)
             ]
+    errorHandler _ _ PermissionDenied =
+        reps $ toObject $ "Permission denied"
 
 -- | Given a sample resource name (purely for typing reasons), generating
 -- a Hack application.

Web/Restful/Handler.hs

@@ -22,7 +22,6 @@ module Web.Restful.Handler
     , HandlerIO
     , Handler
     , runHandler
-    , getRequest
     , liftIO
       -- * Special handlers
     , redirect
@@ -37,7 +36,8 @@ import Web.Restful.Request
 import Web.Restful.Response
 
 import Control.Monad.Trans
-import Control.Monad (liftM)
+import Control.Monad (liftM, ap)
+import Control.Applicative
 
 import Data.Maybe (fromJust)
 import qualified Data.ByteString.Lazy as B
@@ -108,25 +108,27 @@ instance Monad m => Monad (HandlerT m) where
                 (b, hs2) <- b' rr
                 return (b, hs1 ++ hs2)
 
--- | Parse a request in the Handler monad. On failure, return a 400 error.
+instance Monad m => Applicative (HandlerT m) where
-getRequest :: (Monad m, Request r) => HandlerT m r
+    pure = return
-getRequest = HandlerT $ \rr -> return (helper rr, []) where
+    (<*>) = ap
-    helper :: Request r
+
-           => RawRequest
+instance Monad m => MonadRequestReader (HandlerT m) where
-           -> Either ErrorResult r
+    askRawRequest = HandlerT $ \rr -> return (Right rr, [])
-    helper rr =
+    invalidParam ptype name msg =
-        case runRequestParser parseRequest rr of
+        errorResult $ InvalidArgs [(name ++ " (" ++ show ptype ++ ")", msg)]
-            Left errors -> Left $ InvalidArgs errors
+    authRequired = errorResult PermissionDenied
-            Right r -> Right r
 
 ------ Special handlers
+errorResult :: Monad m => ErrorResult -> HandlerT m a
+errorResult er = HandlerT (const $ return (Left er, []))
+
 -- | Redirect to the given URL.
 redirect :: Monad m => String -> HandlerT m a
-redirect s = HandlerT (const $ return (Left $ Redirect s, []))
+redirect = errorResult . Redirect
 
 -- | Return a 404 not found page. Also denotes no handler available.
 notFound :: Monad m => HandlerT m a
-notFound = HandlerT (const $ return (Left NotFound, []))
+notFound = errorResult NotFound
 
 ------- Headers
 -- | Set the cookie on the client.

Web/Restful/Helpers/Auth.hs

@@ -80,7 +80,7 @@ instance Show OIDFormReq where
 
 authOpenidForm :: Handler
 authOpenidForm = do
-    m@(OIDFormReq _ dest) <- getRequest
+    m@(OIDFormReq _ dest) <- parseRequest
     let html =
             show m ++
             "<form method='get' action='forward/'>" ++
@@ -92,35 +92,23 @@ authOpenidForm = do
         Nothing -> return ()
     htmlResponse html
 
-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 :: Handler
 authOpenidForward = do
-    OIDFReq oid complete <- getRequest
+    oid <- getParam "openid"
+    env <- parseEnv
+    let complete = "http://" ++ Hack.serverName env ++ ":" ++
+                   show (Hack.serverPort env) ++
+                   "/auth/openid/complete/"
     res <- liftIO $ OpenId.getForwardUrl oid complete
     case res of
         Left err -> redirect $ "/auth/openid/?message="
                             ++ encodeUrl (err :: String)
         Right url -> redirect 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
-
 authOpenidComplete :: Handler
 authOpenidComplete = do
-    OIDComp gets' dest <- getRequest
+    gets' <- rawGetParams <$> askRawRequest
+    dest <- cookieParam "DEST"
     res <- liftIO $ OpenId.authenticate gets'
     case res of
       Left err -> redirect $ "/auth/openid/?message="
@@ -145,27 +133,26 @@ chopHash x = x
 rpxnowLogin :: String -- ^ api key
             -> Handler
 rpxnowLogin apiKey = do
-    RpxnowRequest token dest' <- getRequest
+    token <- anyParam "token"
+    postDest <- postParam "dest"
+    dest' <- case postDest of
+                Nothing -> getParam "dest"
+                Just d -> return d
     let dest = case dest' of
                 Nothing -> "/"
                 Just "" -> "/"
+                Just ('#':rest) -> rest
                 Just s -> s
-    ident' <- liftIO $ Rpxnow.authenticate apiKey token
+    ident <- join $ liftIO $ Rpxnow.authenticate apiKey token
-    case ident' of
+    header authCookieName $ Rpxnow.identifier ident
-        Nothing -> return ()
-        Just ident -> header authCookieName $ Rpxnow.identifier ident
     redirect dest
 
-data AuthRequest = AuthRequest (Maybe String)
-instance Request AuthRequest where
-    parseRequest = AuthRequest `fmap` identifier
-
 authCheck :: Handler
 authCheck = do
-    req <- getRequest
+    ident <- maybeIdentifier
-    case req of
+    case ident of
-        AuthRequest Nothing -> objectResponse[("status", "notloggedin")]
+        Nothing -> objectResponse [("status", "notloggedin")]
-        AuthRequest (Just i) -> objectResponse
+        Just i -> objectResponse
             [ ("status", "loggedin")
             , ("ident", i)
             ]

Web/Restful/Helpers/Static.hs

@@ -40,13 +40,9 @@ serveStatic :: FileLookup -> Verb -> Handler
 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 -> Handler
 getStatic fl = do
-    StaticReq fp <- getRequest
+    fp <- urlParam "filepath" -- FIXME check for ..
     content <- liftIO $ fl fp
     case content of
         Nothing -> notFound

Web/Restful/Request.hs

@@ -17,38 +17,38 @@
 ---------------------------------------------------------
 module Web.Restful.Request
     (
-      -- * Request parsing
+      -- * Parameter
       -- $param_overview
-
+      Parameter (..)
-      -- ** Types
+    , ParamError
-      ParamError
+    , ParamType
     , ParamName
     , ParamValue
-      -- ** Parameter type class
+      -- * RawRequest
-    , Parameter (..)
+    , RawRequest (..)
-      -- ** RequestParser helpers
+    , PathInfo
+      -- * Parameter type class
+      -- * MonadRequestReader type class and helpers
+    , MonadRequestReader (..)
     , getParam
     , postParam
     , urlParam
     , anyParam
     , cookieParam
     , identifier
+    , maybeIdentifier
     , acceptedLanguages
     , requestPath
-      -- ** Building actual request
+    , parseEnv
+      -- * Building actual request
     , Request (..)
     , Hack.RequestMethod (..)
-      -- ** FIXME
+      -- * Parameter restrictions
-    , parseEnv
+    , notBlank
-    , 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
@@ -67,6 +67,14 @@ import Data.Char (isDigit)
 -- 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.
 
+-- | Where this parameter came from.
+data ParamType =
+    GetParam
+    | PostParam
+    | UrlParam
+    | CookieParam
+    deriving (Eq, Show)
+
 -- | Any kind of error message generated in the parsing stage.
 type ParamError = String
 
@@ -77,6 +85,12 @@ type ParamName = String
 -- | The 'String' value of a parameter, such as cookie content.
 type ParamValue = String
 
+data RawParam = RawParam
+    { paramType :: ParamType
+    , paramName :: ParamName
+    , paramValue :: ParamValue
+    }
+
 -- | Anything which can be converted from a 'String' or list of 'String's.
 --
 -- The default implementation of 'readParams' will error out if given
@@ -86,97 +100,105 @@ type ParamValue = String
 class Parameter a where
     -- | Convert a string into the desired value, or explain why that can't
     -- happen.
-    readParam :: ParamValue -> Either ParamError a
+    readParam :: RawParam -> 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 :: [RawParam] -> Either ParamError a
     readParams [x] = readParam x
     readParams [] = Left "Missing parameter"
     readParams xs = Left $ "Given " ++ show (length xs) ++
                            " values, expecting 1"
 
+instance Parameter RawParam where
+    readParam = Right
+
+class (Monad m, Functor m, Applicative m) => MonadRequestReader m where
+    askRawRequest :: m RawRequest
+    invalidParam :: ParamType -> ParamName -> ParamError -> m a
+    authRequired :: m a
+
 -- | 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
+tryReadParams:: (Parameter a, MonadRequestReader m)
-             => ParamName
+             => ParamType
-             -> [ParamValue]
+             -> ParamName
-             -> RequestParser a
+             -> [RawParam]
-tryReadParams name params =
+             -> m a
+tryReadParams ptype name params =
     case readParams params of
-        Left s -> do
+        Left s -> invalidParam ptype name s
-            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
+genParam :: (Parameter a, MonadRequestReader m)
          => (RawRequest -> ParamName -> [ParamValue])
+         -> ParamType
          -> ParamName
-         -> RequestParser a
+         -> m a
-genParam f name = do
+genParam f ptype name = do
-    req <- ask
+    req <- askRawRequest
-    tryReadParams name $ f req name
+    tryReadParams ptype name $ map (RawParam ptype name) $ f req name
 
 -- | Parse a value passed as a GET parameter.
-getParam :: Parameter a => ParamName -> RequestParser a
+getParam :: (Parameter a, MonadRequestReader m) => ParamName -> m a
-getParam = genParam getParams
+getParam = genParam getParams GetParam
 
 -- | Parse a value passed as a POST parameter.
-postParam :: Parameter a => ParamName -> RequestParser a
+postParam :: (Parameter a, MonadRequestReader m) => ParamName -> m a
-postParam = genParam postParams
+postParam = genParam postParams PostParam
 
 -- | Parse a value passed in the URL and extracted using rewrite.
 -- (FIXME: link to rewrite section.)
-urlParam :: Parameter a => ParamName -> RequestParser a
+urlParam :: (Parameter a, MonadRequestReader m) => ParamName -> m a
-urlParam = genParam urlParams
+urlParam = genParam urlParams UrlParam
 
 -- | Parse a value passed as a GET, POST or URL parameter.
-anyParam :: Parameter a => ParamName -> RequestParser a
+anyParam :: (Parameter a, MonadRequestReader m) => ParamName -> m a
-anyParam = genParam anyParams
+anyParam = genParam anyParams PostParam -- FIXME
 
 -- | Parse a value passed as a raw cookie.
-cookieParam :: Parameter a => ParamName -> RequestParser a
+cookieParam :: (Parameter a, MonadRequestReader m) => ParamName -> m a
-cookieParam = genParam cookies
+cookieParam = genParam cookies CookieParam
-
--- | 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 :: MonadRequestReader m => m String
-identifier = hackHeaderParam authCookieName -- FIXME better error message
+identifier = do
+    mi <- maybeIdentifier
+    case mi of
+        Nothing -> authRequired
+        Just x -> return x
+
+-- | Extract the cookie which specifies the identifier for a logged in
+-- user, if available.
+maybeIdentifier :: MonadRequestReader m => m (Maybe String)
+maybeIdentifier = do
+    env <- parseEnv
+    case lookup authCookieName $ Hack.hackHeaders env of
+        Nothing -> return Nothing
+        Just x -> return (Just x)
 
 -- | Get the raw 'Hack.Env' value.
-parseEnv :: RequestParser Hack.Env
+parseEnv :: MonadRequestReader m => m Hack.Env
-parseEnv = rawEnv `fmap` ask
+parseEnv = rawEnv `fmap` askRawRequest
 
 -- | Determine the ordered list of language preferences.
 --
 -- FIXME: Future versions should account for some cookie.
-acceptedLanguages :: RequestParser [String]
+acceptedLanguages :: MonadRequestReader m => m [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 :: MonadRequestReader m => m String
 requestPath = do
     env <- parseEnv
     let q = case Hack.queryString env of
@@ -185,20 +207,7 @@ requestPath = do
                 q' -> q'
     return $! Hack.pathInfo env ++ q
 
-type RequestParser a = WriterT [(ParamName, ParamError)] (Reader RawRequest) a
+type PathInfo = [String]
-instance Applicative (WriterT [(ParamName, ParamError)] (Reader RawRequest)) where
-    pure = return
-    (<*>) = ap
-
--- | Parse a request into either the desired 'Request' or a list of errors.
-runRequestParser :: RequestParser a
-                 -> RawRequest
-                 -> Either [(ParamName, 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
@@ -253,15 +262,15 @@ instance Parameter a => Parameter [a] where
     readParams = mapM readParam
 
 instance Parameter String where
-    readParam = Right
+    readParam = Right . paramValue
 
 instance Parameter Int where
-    readParam s = case reads s of
+    readParam (RawParam _ _ s) = case reads s of
                     ((x, _):_) -> Right x
                     _ -> Left $ "Invalid integer: " ++ s
 
 instance Parameter Day where
-    readParam s =
+    readParam (RawParam _ _ s) =
         let t1 = length s == 10
             t2 = s !! 4 == '-'
             t3 = s !! 7 == '-'
@@ -282,7 +291,7 @@ instance Parameter Day where
 instance Parameter Bool where
     readParams [] = Right False
     readParams [_] = Right True
-    readParams x = Left $ "Invalid Bool parameter: " ++ show x
+    readParams x = Left $ "Invalid Bool parameter: " ++ show (map paramValue x)
 
 -- | The input for a resource.
 --
@@ -290,9 +299,14 @@ instance Parameter Bool where
 -- easily ensure that it received the correct input (ie, correct variables,
 -- properly typed).
 class Request a where
-    parseRequest :: RequestParser a
+    parseRequest :: MonadRequestReader m => m a
 
 instance Request () where
     parseRequest = return ()
 
-type PathInfo = [String]
+-- | Unsures that a String parameter is not blank.
+notBlank :: MonadRequestReader m => RawParam -> m String
+notBlank rp =
+  case paramValue rp of
+    "" -> invalidParam (paramType rp) (paramName rp) "Required field"
+    s -> return s

Web/Restful/Response.hs

@@ -63,12 +63,14 @@ data ErrorResult =
     | NotFound
     | InternalError String
     | InvalidArgs [(String, String)]
+    | PermissionDenied
 
 getStatus :: ErrorResult -> Int
 getStatus (Redirect _) = 303
 getStatus NotFound = 404
 getStatus (InternalError _) = 500
 getStatus (InvalidArgs _) = 400
+getStatus PermissionDenied = 403
 
 getHeaders :: ErrorResult -> [Header]
 getHeaders (Redirect s) = [Header "Location" s]

Web/Restful/Response/Sitemap.hs

@@ -51,11 +51,6 @@ data SitemapUrl = SitemapUrl
     , 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) =
@@ -89,6 +84,8 @@ instance HasReps SitemapResponse where
 
 sitemap :: IO [SitemapUrl] -> Handler
 sitemap urls' = do
-    req <- getRequest
+    env <- parseEnv
+    -- FIXME
+    let req = SitemapRequest (Hack.serverName env) (Hack.serverPort env)
     urls <- liftIO urls'
     return $ reps $ SitemapResponse req urls

restful.cabal

@@ -1,5 +1,5 @@
 name:            restful
-version:         0.1.3
+version:         0.1.4
 license:         BSD3
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>