Passed the hasArgs in Test.Errors test; ugly hacks, needs cleanup

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)

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, b) <- runRequest $ (,) <$> getParam "firstParam"
-    a <- getParam "firstParam"
+                               <*> getParam "secondParam"
-    b <- 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

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

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]

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
+instance RequestReader (Handler yesod) where
-    askRawRequest = Handler $ \(rr, _, _) -> return ([], HCContent rr)
+    getRawRequest = Handler $ \(rr, _, _) -> return ([], HCContent rr)
-    invalidParam _pt pn pe = invalidArgs [(pn, pe)]
+    invalidParams = invalidArgs . map helper where
-    authRequired = permissionDenied
+        helper ((_pt, pn, _pvs), e) = (pn, show e)
 
 getYesod :: Handler yesod yesod
 getYesod = Handler $ \(_, yesod, _) -> return ([], HCContent yesod)

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
+    gets' <- rawGetParams <$> getRawRequest
-    dest <- cookieParam "DEST"
+    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"
+    token <- runRequest $ anyParam "token"
-    postDest <- postParam "dest"
+    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 -> "/"

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 (..)
+      RawRequest (..)
-    , PathInfo
       -- * 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
+#if TEST
--- In Restful, all of the underlying parameter values are strings. They can
+import Test.Framework (testGroup, Test)
--- come from multiple sources: GET parameters, URL rewriting (FIXME: link),
+import Test.Framework.Providers.HUnit
--- cookies, etc. However, most applications eventually want to convert
+import Test.HUnit hiding (Test)
--- those strings into something else, like 'Int's. Additionally, it is
+#endif
--- 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.
 
--- | Where this parameter came from.
+newtype Request v = Request { unRequest :: RawRequest
-data ParamType =
+                                        -> Either ParamException v }
-    GetParam
+instance Functor Request where
-    | PostParam
+    fmap f (Request r) = Request $ fmap f . r
-    | CookieParam
+instance Applicative Request where
-    deriving (Eq, Show)
+    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.
+class RequestReader m where
-type ParamError = String
+    getRawRequest :: m RawRequest
-
+    invalidParams :: ParamException -> m a
--- | In GET parameters, the key. In cookies, the cookie name. So on and so
+instance RequestReader Request where
--- forth.
+    getRawRequest = Request $ Right
-type ParamName = String
+    invalidParams = Request . const . Left
-
--- | 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
 
+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
+        Failure s -> invalidParam ptype name s
-        Right x -> return x
+        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
+         -> Request a
-genParam f ptype name = do
+genParam f ptype name = Request helper where
-    req <- askRawRequest
+  helper req = attempt failureH Right $ readParams pvs where
-    tryReadParams ptype name $ map (RawParam ptype name) $ f req name
+      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 :: (Functor m, RequestReader m) => m Hack.Env
-parseEnv = rawEnv `fmap` askRawRequest
+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
+{- FIXME
-    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 ()
-
 -- | 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

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

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

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