From 58f9f3e0547910e3d78b33ce6b172987b2aa9120 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 1 Jan 2010 03:50:52 +0200 Subject: [PATCH] Passed the hasArgs in Test.Errors test; ugly hacks, needs cleanup --- TODO | 1 + Test/Errors.hs | 7 +- Yesod.hs | 5 +- Yesod/Definitions.hs | 5 +- Yesod/Handler.hs | 10 +- Yesod/Helpers/Auth.hs | 25 ++--- Yesod/Request.hs | 239 +++++++++++++++--------------------------- Yesod/Yesod.hs | 2 +- runtests.hs | 2 + yesod.cabal | 7 +- 10 files changed, 120 insertions(+), 183 deletions(-) diff --git a/TODO b/TODO index e2c54485..a09e2e82 100644 --- a/TODO +++ b/TODO @@ -2,3 +2,4 @@ Some form of i18n. Cleanup Parameter stuff. Own module? Interface with formlets? Authentication via e-mail address built in. (eaut.org) OpenID 2 stuff (for direct Google login). +Languages (read languages header, set language cookie) diff --git a/Test/Errors.hs b/Test/Errors.hs index f4d142d3..84cbe86f 100644 --- a/Test/Errors.hs +++ b/Test/Errors.hs @@ -9,6 +9,7 @@ import Data.List import Test.Framework (testGroup, Test) import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test) +import Control.Applicative data Errors = Errors instance Yesod Errors where @@ -34,9 +35,8 @@ needsIdent = do hasArgs :: Handler Errors HtmlObject hasArgs = do - -- FIXME this test needs more work - a <- getParam "firstParam" - b <- getParam "secondParam" + (a, b) <- runRequest $ (,) <$> getParam "firstParam" + <*> getParam "secondParam" return $ toHtmlObject [a :: String, b] caseErrorMessages :: Assertion @@ -45,7 +45,6 @@ caseErrorMessages = do res <- app $ def { pathInfo = "/denied/" } assertBool "/denied/" $ "Permission denied" `isInfixOf` show res res' <- app $ def { pathInfo = "/needs-ident/" } - print res' assertBool "/needs-ident/" $ "IGNORED/auth/openid/" `isInfixOf` show res' res3 <- app $ def { pathInfo = "/has-args/" } assertBool "/has-args/" $ "secondParam" `isInfixOf` show res3 diff --git a/Yesod.hs b/Yesod.hs index c96f9d7b..fdc2ce15 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -21,6 +21,7 @@ module Yesod , module Yesod.Handler , module Yesod.Resource , module Data.Object.Html + , module Yesod.Parameter , module Yesod.Rep , module Yesod.Template , module Data.Convertible.Text @@ -32,14 +33,16 @@ import Yesod.Resource hiding (testSuite) import Yesod.Response hiding (testSuite) import Data.Object.Html hiding (testSuite) import Yesod.Rep hiding (testSuite) +import Yesod.Request hiding (testSuite) #else import Yesod.Resource import Yesod.Response import Data.Object.Html import Yesod.Rep +import Yesod.Request #endif -import Yesod.Request +import Yesod.Parameter import Yesod.Yesod import Yesod.Definitions import Yesod.Handler diff --git a/Yesod/Definitions.hs b/Yesod/Definitions.hs index e86fc6b9..b3ff2d8d 100644 --- a/Yesod/Definitions.hs +++ b/Yesod/Definitions.hs @@ -21,6 +21,7 @@ module Yesod.Definitions , Language , Location (..) , showLocation + , PathInfo ) where import qualified Hack @@ -54,7 +55,7 @@ type Resource = [String] -- | An absolute URL to the base of this application. This can almost be done -- programatically, but due to ambiguities in different ways of doing URL -- rewriting for (fast)cgi applications, it should be supplied by the user. -newtype Approot = Approot { unApproot :: String } +newtype Approot = Approot { unApproot :: String } -- FIXME make type syn? type Language = String @@ -66,3 +67,5 @@ data Location = AbsLoc String | RelLoc String showLocation :: Approot -> Location -> String showLocation _ (AbsLoc s) = s showLocation (Approot ar) (RelLoc s) = ar ++ s + +type PathInfo = [String] diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 882e3cb1..ca89257d 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -50,6 +50,8 @@ import Control.Monad (liftM, ap) import System.IO import Data.Object.Html +import Yesod.Parameter + ------ Handler monad newtype Handler yesod a = Handler { unHandler :: (RawRequest, yesod, TemplateGroup) @@ -80,10 +82,10 @@ instance MonadIO (Handler yesod) where liftIO i = Handler $ \_ -> i >>= \i' -> return ([], HCContent i') instance Exception e => Failure e (Handler yesod) where failure e = Handler $ \_ -> return ([], HCError e) -instance MonadRequestReader (Handler yesod) where - askRawRequest = Handler $ \(rr, _, _) -> return ([], HCContent rr) - invalidParam _pt pn pe = invalidArgs [(pn, pe)] - authRequired = permissionDenied +instance RequestReader (Handler yesod) where + getRawRequest = Handler $ \(rr, _, _) -> return ([], HCContent rr) + invalidParams = invalidArgs . map helper where + helper ((_pt, pn, _pvs), e) = (pn, show e) getYesod :: Handler yesod yesod getYesod = Handler $ \(_, yesod, _) -> return ([], HCContent yesod) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 3f7831a7..675044b8 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -76,8 +76,6 @@ authHandler _ ["login", "rpxnow"] = rc rpxnowLogin authHandler _ _ = notFound data OIDFormReq = OIDFormReq (Maybe String) (Maybe String) -instance Request OIDFormReq where - parseRequest = OIDFormReq <$> getParam "message" <*> getParam "dest" instance ConvertSuccess OIDFormReq Html where convertSuccess (OIDFormReq Nothing _) = cs "" convertSuccess (OIDFormReq (Just s) _) = @@ -85,7 +83,9 @@ instance ConvertSuccess OIDFormReq Html where authOpenidForm :: Handler y HtmlObject authOpenidForm = do - m@(OIDFormReq _ dest) <- parseRequest + message <- runRequest $ getParam "message" + dest <- runRequest $ getParam "dest" + let m = OIDFormReq message dest let html = HtmlList [ cs m @@ -104,7 +104,7 @@ authOpenidForm = do authOpenidForward :: YesodAuth y => Handler y HtmlObject authOpenidForward = do - oid <- getParam "openid" + oid <- runRequest $ getParam "openid" authroot <- getFullAuthRoot let complete = authroot ++ "/openid/complete/" res <- runAttemptT $ OpenId.getForwardUrl oid complete @@ -115,8 +115,8 @@ authOpenidForward = do authOpenidComplete :: Handler y HtmlObject authOpenidComplete = do - gets' <- rawGetParams <$> askRawRequest - dest <- cookieParam "DEST" + gets' <- rawGetParams <$> getRawRequest + dest <- runRequest $ cookieParam "DEST" res <- runAttemptT $ OpenId.authenticate gets' let onFailure err = redirect $ "/auth/openid/?message=" ++ encodeUrl (show err) @@ -127,13 +127,6 @@ authOpenidComplete = do attempt onFailure onSuccess res -- | token dest -data RpxnowRequest = RpxnowRequest String (Maybe String) -instance Request RpxnowRequest where - parseRequest = do - token <- anyParam "token" - dest <- anyParam "dest" - return $! RpxnowRequest token $ chopHash `fmap` dest - chopHash :: String -> String chopHash ('#':rest) = rest chopHash x = x @@ -144,10 +137,10 @@ rpxnowLogin = do apiKey <- case rpxnowApiKey ay of Just x -> return x Nothing -> notFound - token <- anyParam "token" - postDest <- postParam "dest" + token <- runRequest $ anyParam "token" + postDest <- runRequest $ postParam "dest" dest' <- case postDest of - Nothing -> getParam "dest" + Nothing -> runRequest $ getParam "dest" Just d -> return d let dest = case dest' of Nothing -> "/" diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 9373776b..a0ab2153 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -1,7 +1,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverlappingInstances #-} -- Parameter String {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} --------------------------------------------------------- -- -- Module : Yesod.Request @@ -17,20 +18,11 @@ --------------------------------------------------------- module Yesod.Request ( - -- * Parameter - -- $param_overview - Parameter (..) - , ParamError - , ParamType - , ParamName - , ParamValue - , RawParam (..) -- * RawRequest - , RawRequest (..) - , PathInfo + RawRequest (..) -- * Parameter type class -- * MonadRequestReader type class and helpers - , MonadRequestReader (..) + , RequestReader (..) , getParam , postParam , anyParam @@ -39,88 +31,64 @@ module Yesod.Request , acceptedLanguages , requestPath , parseEnv + , runRequest -- * Building actual request , Request (..) , Hack.RequestMethod (..) -- * Parameter restrictions - , notBlank + -- FIXME , notBlank +#if TEST + , testSuite +#endif ) where import qualified Hack import Data.Function.Predicate (equals) import Yesod.Constants -import Yesod.Utils +import Yesod.Utils (tryLookup, parseHttpAccept) import Yesod.Definitions +import Yesod.Parameter import Control.Applicative (Applicative (..)) import Web.Encodings -import Data.Time.Calendar (Day, fromGregorian) -import Data.Char (isDigit) import qualified Data.ByteString.Lazy as BL import Data.Convertible.Text import Hack.Middleware.CleanPath (splitPath) import Control.Arrow ((***)) +import Control.Exception (Exception, SomeException (..)) +import Data.Typeable (Typeable) +import Data.Attempt --- $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. +#if TEST +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) +#endif --- | Where this parameter came from. -data ParamType = - GetParam - | PostParam - | CookieParam - deriving (Eq, Show) +newtype Request v = Request { unRequest :: RawRequest + -> Either ParamException v } +instance Functor Request where + fmap f (Request r) = Request $ fmap f . r +instance Applicative Request where + pure = Request . const . Right + (Request f) <*> (Request r) = Request helper where + helper rr = helper2 (f rr) (r rr) + helper2 (Left e1) (Left e2) = Left $ e1 ++ e2 + helper2 (Left e) _ = Left e + helper2 _ (Left e) = Left e + helper2 (Right f') (Right r') = Right $ f' r' --- | 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 - -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 --- 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 :: RawParam -> Either ParamError a - readParam = readParams . return - - -- | Convert a list of strings into the desired value, or explain why - -- that can't happen. - 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 +class RequestReader m where + getRawRequest :: m RawRequest + invalidParams :: ParamException -> m a +instance RequestReader Request where + getRawRequest = Request $ Right + invalidParams = Request . const . Left +runRequest :: (Monad m, RequestReader m) => Request a -> m a +runRequest (Request f) = do + rr <- getRawRequest + either invalidParams return $ f rr +{- FIXME -- | 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. @@ -133,39 +101,41 @@ tryReadParams:: (Parameter a, MonadRequestReader m) -> m a tryReadParams ptype name params = case readParams params of - Left s -> invalidParam ptype name s - Right x -> return x + Failure s -> invalidParam ptype name s + Success x -> return x +-} -- | Helper function for generating 'RequestParser's from various -- 'ParamValue' lists. -genParam :: (Parameter a, MonadRequestReader m) +genParam :: Parameter a => (RawRequest -> ParamName -> [ParamValue]) -> ParamType -> ParamName - -> m a -genParam f ptype name = do - req <- askRawRequest - tryReadParams ptype name $ map (RawParam ptype name) $ f req name + -> Request a +genParam f ptype name = Request helper where + helper req = attempt failureH Right $ readParams pvs where + pvs = f req name + failureH e = Left [((ptype, name, pvs), SomeException e)] -- | Parse a value passed as a GET parameter. -getParam :: (Parameter a, MonadRequestReader m) => ParamName -> m a +getParam :: (Parameter a) => ParamName -> Request a getParam = genParam getParams GetParam -- | Parse a value passed as a POST parameter. -postParam :: (Parameter a, MonadRequestReader m) => ParamName -> m a +postParam :: (Parameter a) => ParamName -> Request a postParam = genParam postParams PostParam -- | Parse a value passed as a GET, POST or URL parameter. -anyParam :: (Parameter a, MonadRequestReader m) => ParamName -> m a +anyParam :: (Parameter a) => ParamName -> Request a anyParam = genParam anyParams PostParam -- FIXME -- | Parse a value passed as a raw cookie. -cookieParam :: (Parameter a, MonadRequestReader m) => ParamName -> m a +cookieParam :: (Parameter a) => ParamName -> Request a cookieParam = genParam cookies CookieParam -- | Extract the cookie which specifies the identifier for a logged in -- user, if available. -identifier :: MonadRequestReader m => m (Maybe String) +identifier :: (Functor m, Monad m, RequestReader m) => m (Maybe String) identifier = do env <- parseEnv case lookup authCookieName $ Hack.hackHeaders env of @@ -173,20 +143,20 @@ identifier = do Just x -> return (Just x) -- | Get the raw 'Hack.Env' value. -parseEnv :: MonadRequestReader m => m Hack.Env -parseEnv = rawEnv `fmap` askRawRequest +parseEnv :: (Functor m, RequestReader m) => m Hack.Env +parseEnv = rawEnv `fmap` getRawRequest -- | Determine the ordered list of language preferences. -- -- FIXME: Future versions should account for some cookie. -acceptedLanguages :: MonadRequestReader m => m [String] +acceptedLanguages :: (Functor m, Monad m, RequestReader 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 :: MonadRequestReader m => m String +requestPath :: (Functor m, Monad m, RequestReader m) => m String requestPath = do env <- parseEnv let q = case Hack.queryString env of @@ -198,8 +168,6 @@ requestPath = do dropSlash ('/':x) = x dropSlash x = x -type PathInfo = [String] - -- | The raw information passed through Hack, cleaned up a bit. data RawRequest = RawRequest { rawPathInfo :: PathInfo @@ -235,73 +203,18 @@ anyParams req name = getParams req 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] = Just `fmap` readParam x - readParams xs = Left $ "Given " ++ show (length xs) ++ - " values, expecting 0 or 1" - -instance Parameter a => Parameter [a] where - readParams = mapM' readParam where - mapM' f = sequence' . map f - sequence' :: [Either String v] -> Either String [v] - sequence' [] = Right [] - sequence' (Left l:_) = Left l - sequence' (Right r:rest) = - case sequence' rest of - Left l -> Left l - Right rest' -> Right $ r : rest' - -instance Parameter String where - readParam = Right . paramValue - -instance Parameter Int where - readParam (RawParam _ _ s) = case reads s of - ((x, _):_) -> Right x - _ -> Left $ "Invalid integer: " ++ s - -instance Parameter Day where - readParam (RawParam _ _ s) = - let t1 = length s == 10 - t2 = s !! 4 == '-' - t3 = s !! 7 == '-' - t4 = all isDigit $ concat - [ take 4 s - , take 2 $ drop 5 s - , take 2 $ drop 8 s - ] - t = and [t1, t2, t3, t4] - y = read $ take 4 s - m = read $ take 2 $ drop 5 s - d = read $ take 2 $ drop 8 s - in if t - then Right $ fromGregorian y m d - else Left $ "Invalid date: " ++ s - --- for checkboxes; checks for presence or a "false" value -instance Parameter Bool where - readParams [] = Right False - readParams [RawParam _ _ "false"] = Right False - readParams [_] = Right True - readParams x = Left $ "Invalid Bool parameter: " ++ show (map paramValue x) - --- | 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 :: MonadRequestReader m => m a - -instance Request () where - parseRequest = return () - +{- FIXME -- | Ensures 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" + "" -> invalidParam (paramType rp) (paramName rp) RequiredField s -> return s +-} + +data RequiredField = RequiredField + deriving (Show, Typeable) +instance Exception RequiredField instance ConvertSuccess Hack.Env RawRequest where convertSuccess env = @@ -318,3 +231,21 @@ instance ConvertSuccess Hack.Env RawRequest where cookies' = decodeCookies rawCookie :: [(String, String)] langs = ["en"] -- FIXME in RawRequest rawPieces gets' posts cookies' files env langs + +#if TEST +testSuite :: Test +testSuite = testGroup "Yesod.Request" + [ testCase "Request applicative instance" caseAppInst + ] + +caseAppInst :: Assertion +caseAppInst = do + let r5 = Request $ const $ Right 5 + rAdd2 = Request $ const $ Right (+ 2) + r7 = Request $ const $ Right 7 + rr = undefined + myEquals e t = (unRequest e) rr `myEquals2` (unRequest t) rr + myEquals2 x y = show x @=? show y + r5 `myEquals` pure 5 + r7 `myEquals` (rAdd2 <*> r5) +#endif diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 7866277b..c6d5edb8 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -58,7 +58,7 @@ defaultErrorHandler :: Yesod y => ErrorResult -> Handler y RepChooser defaultErrorHandler NotFound = do - rr <- askRawRequest + rr <- getRawRequest return $ chooseRep $ toHtmlObject $ "Not found: " ++ show rr defaultErrorHandler (Redirect url) = return $ chooseRep $ toHtmlObject $ "Redirect to: " ++ url diff --git a/runtests.hs b/runtests.hs index b7b64c3e..6da45977 100644 --- a/runtests.hs +++ b/runtests.hs @@ -4,6 +4,7 @@ import qualified Yesod.Response import qualified Yesod.Utils import qualified Yesod.Resource import qualified Yesod.Rep +import qualified Yesod.Request import qualified Data.Object.Html import qualified Test.Errors import qualified Test.QuasiResource @@ -14,6 +15,7 @@ main = defaultMain , Yesod.Utils.testSuite , Yesod.Resource.testSuite , Yesod.Rep.testSuite + , Yesod.Request.testSuite , Data.Object.Html.testSuite , Test.Errors.testSuite , Test.QuasiResource.testSuite diff --git a/yesod.cabal b/yesod.cabal index d0d71895..a6e4ff0f 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -52,7 +52,8 @@ library data-object-json >= 0.0.0 && < 0.1, attempt >= 0.2.1 && < 0.3, template-haskell, - failure >= 0.0.0 && < 0.1 + failure >= 0.0.0 && < 0.1, + safe-failure >= 0.4.0 && < 0.5 exposed-modules: Yesod Yesod.Constants Yesod.Rep @@ -61,6 +62,7 @@ library Yesod.Utils Yesod.Definitions Yesod.Handler + Yesod.Parameter Yesod.Resource Yesod.Yesod Yesod.Template @@ -84,7 +86,8 @@ executable runtests test-framework-quickcheck, test-framework-hunit, HUnit, - QuickCheck >= 1 && < 2 + QuickCheck >= 1 && < 2, + data-default >= 0.2 && < 0.3 else Buildable: False ghc-options: -Wall