diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index eb287784..035101ce 100644 --- a/Web/Restful/Application.hs +++ b/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. diff --git a/Web/Restful/Handler.hs b/Web/Restful/Handler.hs index 3a9454cf..043fb109 100644 --- a/Web/Restful/Handler.hs +++ b/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. -getRequest :: (Monad m, Request r) => HandlerT m r -getRequest = HandlerT $ \rr -> return (helper rr, []) where - helper :: Request r - => RawRequest - -> Either ErrorResult r - helper rr = - case runRequestParser parseRequest rr of - Left errors -> Left $ InvalidArgs errors - Right r -> Right r +instance Monad m => Applicative (HandlerT m) where + pure = return + (<*>) = ap + +instance Monad m => MonadRequestReader (HandlerT m) where + askRawRequest = HandlerT $ \rr -> return (Right rr, []) + invalidParam ptype name msg = + errorResult $ InvalidArgs [(name ++ " (" ++ show ptype ++ ")", msg)] + authRequired = errorResult PermissionDenied ------ 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. diff --git a/Web/Restful/Helpers/Auth.hs b/Web/Restful/Helpers/Auth.hs index 14b12067..83c909ca 100644 --- a/Web/Restful/Helpers/Auth.hs +++ b/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 ++ "
" ++ @@ -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 - case ident' of - Nothing -> return () - Just ident -> header authCookieName $ Rpxnow.identifier ident + ident <- join $ liftIO $ Rpxnow.authenticate apiKey token + 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 - case req of - AuthRequest Nothing -> objectResponse[("status", "notloggedin")] - AuthRequest (Just i) -> objectResponse + ident <- maybeIdentifier + case ident of + Nothing -> objectResponse [("status", "notloggedin")] + Just i -> objectResponse [ ("status", "loggedin") , ("ident", i) ] diff --git a/Web/Restful/Helpers/Static.hs b/Web/Restful/Helpers/Static.hs index 3b84d2e3..8e43925a 100644 --- a/Web/Restful/Helpers/Static.hs +++ b/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 diff --git a/Web/Restful/Request.hs b/Web/Restful/Request.hs index 50886fc4..610126cc 100644 --- a/Web/Restful/Request.hs +++ b/Web/Restful/Request.hs @@ -17,38 +17,38 @@ --------------------------------------------------------- module Web.Restful.Request ( - -- * Request parsing + -- * Parameter -- $param_overview - - -- ** Types - ParamError + Parameter (..) + , ParamError + , ParamType , ParamName , ParamValue - -- ** Parameter type class - , Parameter (..) - -- ** RequestParser helpers + -- * RawRequest + , RawRequest (..) + , 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 - , parseEnv - , RawRequest (..) - , PathInfo - , runRequestParser + -- * Parameter restrictions + , notBlank ) 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 - => ParamName - -> [ParamValue] - -> RequestParser a -tryReadParams name params = +tryReadParams:: (Parameter a, MonadRequestReader m) + => ParamType + -> ParamName + -> [RawParam] + -> m a +tryReadParams ptype name params = case readParams params of - Left s -> do - tell [(name, s)] - return $ - error $ - "Trying to evaluate nonpresent parameter " ++ - name + Left s -> invalidParam ptype name s 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 -genParam f name = do - req <- ask - tryReadParams name $ f req name + -> m a +genParam f ptype name = do + req <- askRawRequest + 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 = genParam getParams +getParam :: (Parameter a, MonadRequestReader m) => ParamName -> m a +getParam = genParam getParams GetParam -- | Parse a value passed as a POST parameter. -postParam :: Parameter a => ParamName -> RequestParser a -postParam = genParam postParams +postParam :: (Parameter a, MonadRequestReader m) => ParamName -> m a +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 = genParam urlParams +urlParam :: (Parameter a, MonadRequestReader m) => ParamName -> m a +urlParam = genParam urlParams UrlParam -- | Parse a value passed as a GET, POST or URL parameter. -anyParam :: Parameter a => ParamName -> RequestParser a -anyParam = genParam anyParams +anyParam :: (Parameter a, MonadRequestReader m) => ParamName -> m a +anyParam = genParam anyParams PostParam -- FIXME -- | 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 +cookieParam :: (Parameter a, MonadRequestReader m) => ParamName -> m a +cookieParam = genParam cookies CookieParam -- | Extract the cookie which specifies the identifier for a logged in -- user. -identifier :: Parameter a => RequestParser a -identifier = hackHeaderParam authCookieName -- FIXME better error message +identifier :: MonadRequestReader m => m String +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 = rawEnv `fmap` ask +parseEnv :: MonadRequestReader m => m Hack.Env +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 -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 +type PathInfo = [String] -- | 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 diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index dff158b9..05b6746a 100644 --- a/Web/Restful/Response.hs +++ b/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] diff --git a/Web/Restful/Response/Sitemap.hs b/Web/Restful/Response/Sitemap.hs index 54d8a169..40334a6c 100644 --- a/Web/Restful/Response/Sitemap.hs +++ b/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 diff --git a/restful.cabal b/restful.cabal index 7005f940..e97d62ed 100644 --- a/restful.cabal +++ b/restful.cabal @@ -1,5 +1,5 @@ name: restful -version: 0.1.3 +version: 0.1.4 license: BSD3 license-file: LICENSE author: Michael Snoyman