Removed more from Yesod.Request, with cascading removals

Data/Object/Html.hs

@@ -90,6 +90,12 @@ instance ConvertSuccess Text HtmlObject where
     convertSuccess = Scalar . cs
 instance ConvertSuccess TS.Text HtmlObject where
     convertSuccess = Scalar . cs
+instance ConvertSuccess [String] HtmlObject where
+    convertSuccess = Sequence . map cs
+instance ConvertSuccess [Text] HtmlObject where
+    convertSuccess = Sequence . map cs
+instance ConvertSuccess [TS.Text] HtmlObject where
+    convertSuccess = Sequence . map cs
 instance ConvertSuccess [(String, String)] HtmlObject where
     convertSuccess = omTO
 instance ConvertSuccess [(Text, Text)] HtmlObject where
@@ -202,7 +208,7 @@ caseHtmlToText = do
             "<div id=\"foo\" class=\"bar\"><br>Some HTML<br>" ++
             "&lt;&#39;this should be escaped&#39;&gt;" ++
             "<img src=\"baz&amp;\"></div>"
-    cs actual @?= (cs expected :: Text)
+    unHtmlFragment (cs actual) @?= (cs expected :: Text)
 
 caseStringTemplate :: Assertion
 caseStringTemplate = do

Test/Errors.hs

@@ -22,7 +22,7 @@ instance Yesod Errors where
     Get: hasArgs
 |]
 instance YesodApproot Errors where
-    approot _ = Approot "IGNORED/"
+    approot _ = "IGNORED/"
 instance YesodAuth Errors
 
 denied :: Handler Errors ()
@@ -41,7 +41,7 @@ hasArgs = do
 
 caseErrorMessages :: Assertion
 caseErrorMessages = do
-    let app = toHackApp Errors
+    app <- toHackApp Errors
     res <- app $ def { pathInfo = "/denied/" }
     assertBool "/denied/" $ "Permission denied" `isInfixOf` show res
     res' <- app $ def { pathInfo = "/needs-ident/" }

Yesod/Definitions.hs

@@ -21,7 +21,6 @@ module Yesod.Definitions
     , Language
     , Location (..)
     , showLocation
-    , PathInfo
     ) where
 
 import qualified Hack
@@ -67,5 +66,3 @@ data Location = AbsLoc String | RelLoc String
 showLocation :: Approot -> Location -> String
 showLocation _ (AbsLoc s) = s
 showLocation ar (RelLoc s) = ar ++ s
-
-type PathInfo = [String]

Yesod/Helpers/Auth.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 ---------------------------------------------------------
 --
 -- Module        : Yesod.Helpers.Auth
@@ -16,7 +17,9 @@
 module Yesod.Helpers.Auth
     ( authHandler
     , YesodAuth (..)
+    , maybeIdentifier
     , authIdentifier
+    , displayName
     ) where
 
 import Web.Encodings
@@ -29,6 +32,9 @@ import Yesod.Constants
 import Control.Monad.Attempt
 
 import Data.Maybe (fromMaybe)
+import qualified Hack
+import Data.Typeable (Typeable)
+import Control.Exception (Exception)
 
 class YesodApproot a => YesodAuth a where
     -- | The following breaks DRY, but I cannot think of a better solution
@@ -138,7 +144,10 @@ rpxnowLogin = do
     apiKey <- case rpxnowApiKey ay of
                 Just x -> return x
                 Nothing -> notFound
-    token <- runRequest $ anyParam "token"
+    rr <- getRawRequest
+    let token = case getParams rr "token" ++ postParams rr "token" of
+                    [] -> failure MissingToken
+                    (x:_) -> x
     postDest <- runRequest $ postParam "dest"
     dest' <- case postDest of
                 Nothing -> runRequest $ getParam "dest"
@@ -153,6 +162,10 @@ rpxnowLogin = do
     header authDisplayName $ getDisplayName ident
     redirect RedirectTemporary dest
 
+data MissingToken = MissingToken
+    deriving (Show, Typeable)
+instance Exception MissingToken
+
 -- | Get some form of a display name, defaulting to the identifier.
 getDisplayName :: Rpxnow.Identifier -> String
 getDisplayName (Rpxnow.Identifier ident extra) = helper choices where
@@ -164,7 +177,7 @@ getDisplayName (Rpxnow.Identifier ident extra) = helper choices where
 
 authCheck :: Handler y HtmlObject
 authCheck = do
-    ident <- identifier
+    ident <- maybeIdentifier
     dn <- displayName
     return $ toHtmlObject
         [ ("identifier", fromMaybe "" ident)
@@ -178,9 +191,27 @@ authLogout = do
     redirect RedirectTemporary ar
     -- FIXME check the DEST information
 
+-- | Gets the identifier for a user if available.
+maybeIdentifier :: (Functor m, Monad m, RequestReader m) => m (Maybe String)
+maybeIdentifier = do
+    env <- parseEnv
+    case lookup authCookieName $ Hack.hackHeaders env of
+        Nothing -> return Nothing
+        Just x -> return (Just x)
+
+-- | Gets the display name for a user if available.
+displayName :: (Functor m, Monad m, RequestReader m) => m (Maybe String)
+displayName = do
+    env <- parseEnv
+    case lookup authDisplayName $ Hack.hackHeaders env of
+        Nothing -> return Nothing
+        Just x -> return (Just x)
+
+-- | Gets the identifier for a user. If user is not logged in, redirects them
+-- to the login page.
 authIdentifier :: YesodAuth y => Handler y String
 authIdentifier = do
-    mi <- identifier
+    mi <- maybeIdentifier
     ar <- getApproot
     case mi of
         Nothing -> do
@@ -190,3 +221,17 @@ authIdentifier = do
             addCookie 120 "DEST" dest
             redirect RedirectTemporary $ ar ++ lp
         Just x -> return x
+
+-- | Determinge the path requested by the user (ie, the path info). This
+-- includes the query string.
+requestPath :: (Functor m, Monad m, RequestReader m) => m String
+requestPath = do
+    env <- parseEnv
+    let q = case Hack.queryString env of
+                "" -> ""
+                q'@('?':_) -> q'
+                q' -> '?' : q'
+    return $! dropSlash (Hack.pathInfo env) ++ q
+      where
+        dropSlash ('/':x) = x
+        dropSlash x = x

Yesod/Rep.hs

@@ -200,7 +200,7 @@ caseChooseRepTemplate :: Assertion
 caseChooseRepTemplate = do
     let temp = newSTMP "foo:$o.foo$, bar:$o.bar$"
         ho = toHtmlObject [ ("foo", toHtmlObject "<fooval>")
-                          , ("bar", toHtmlObject ["bar1", "bar2"])
+                          , ("bar", Sequence $ map cs ["bar1", "bar2"])
                           ]
         hasreps = Template temp "o" ho $ return []
         res1 = cs "foo:&lt;fooval&gt;, bar:bar1bar2"
@@ -215,7 +215,7 @@ caseChooseRepTemplateFile :: Assertion
 caseChooseRepTemplateFile = do
     let temp = "Test/rep.st"
         ho = toHtmlObject [ ("foo", toHtmlObject "<fooval>")
-                          , ("bar", toHtmlObject ["bar1", "bar2"])
+                          , ("bar", Sequence $ map cs ["bar1", "bar2"])
                           ]
         hasreps = TemplateFile temp ho
         res1 = cs "foo:&lt;fooval&gt;, bar:bar1bar2"

Yesod/Request.hs

@@ -20,24 +20,17 @@ module Yesod.Request
     (
       -- * RawRequest
       RawRequest (..)
-      -- * Parameter type class
-      -- * MonadRequestReader type class and helpers
     , RequestReader (..)
     , getParam
     , postParam
-    , anyParam
-    , identifier
-    , displayName
-    , acceptedLanguages
-    , requestPath
     , parseEnv
     , runRequest
     , cookies
+    , getParams
+    , postParams
       -- * Building actual request
     , Request (..)
     , Hack.RequestMethod (..)
-      -- * Parameter restrictions
-    -- FIXME , notBlank
 #if TEST
     , testSuite
 #endif
@@ -45,19 +38,15 @@ module Yesod.Request
 
 import qualified Hack
 import Data.Function.Predicate (equals)
-import Yesod.Constants
-import Yesod.Utils (tryLookup)
-import Yesod.Definitions
 import Yesod.Parameter
 import Control.Applicative (Applicative (..))
 import Web.Encodings
 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 Control.Exception (SomeException (..))
-import Data.Typeable (Typeable)
 import Data.Attempt
+import Data.Maybe (fromMaybe)
 
 #if TEST
 import Test.Framework (testGroup, Test)
@@ -89,22 +78,6 @@ 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.
--- Be careful not to use the value inside until you can be certain the
--- reading succeeded.
-tryReadParams:: (Parameter a, MonadRequestReader m)
-             => ParamType
-             -> ParamName
-             -> [RawParam]
-             -> m a
-tryReadParams ptype name params =
-    case readParams params of
-        Failure s -> invalidParam ptype name s
-        Success x -> return x
--}
 
 -- | Helper function for generating 'RequestParser's from various
 -- 'ParamValue' lists.
@@ -126,61 +99,19 @@ getParam = genParam getParams GetParam
 postParam :: (Parameter a) => ParamName -> Request a
 postParam = genParam postParams PostParam
 
--- | Parse a value passed as a GET, POST or URL parameter.
-anyParam :: (Parameter a) => ParamName -> Request a
-anyParam = genParam anyParams PostParam -- FIXME
-
--- | Extract the cookie which specifies the identifier for a logged in
--- user, if available.
-identifier :: (Functor m, Monad m, RequestReader m) => m (Maybe String)
-identifier = do
-    env <- parseEnv
-    case lookup authCookieName $ Hack.hackHeaders env of
-        Nothing -> return Nothing
-        Just x -> return (Just x)
-
-displayName :: (Functor m, Monad m, RequestReader m) => m (Maybe String)
-displayName = do
-    env <- parseEnv
-    case lookup authDisplayName $ Hack.hackHeaders env of
-        Nothing -> return Nothing
-        Just x -> return (Just x)
-
 -- | Get the raw 'Hack.Env' value.
 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 :: (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 :: (Functor m, Monad m, RequestReader m) => m String
-requestPath = do
-    env <- parseEnv
-    let q = case Hack.queryString env of
-                "" -> ""
-                q'@('?':_) -> q'
-                q' -> q'
-    return $! dropSlash (Hack.pathInfo env) ++ q
-      where
-        dropSlash ('/':x) = x
-        dropSlash x = x
-
 -- | The raw information passed through Hack, cleaned up a bit.
 data RawRequest = RawRequest
-    { rawPathInfo :: PathInfo
+    { rawGetParams :: [(ParamName, ParamValue)]
-    , rawGetParams :: [(ParamName, ParamValue)]
-    , rawPostParams :: [(ParamName, ParamValue)]
     , rawCookies :: [(ParamName, ParamValue)]
+    -- FIXME when we switch to WAI, the following two should be combined and
+    -- wrapped in the IO monad
+    , rawPostParams :: [(ParamName, ParamValue)]
     , rawFiles :: [(ParamName, FileInfo String BL.ByteString)]
     , rawEnv :: Hack.Env
-    , rawLanguages :: [Language]
     }
     deriving Show
 
@@ -198,43 +129,23 @@ postParams rr name = map snd
                    . rawPostParams
                    $ rr
 
--- | All GET and POST paramater values (see rewriting) with the given name.
-anyParams :: RawRequest -> ParamName -> [ParamValue]
-anyParams 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
 
-{- 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) RequiredField
-    s -> return s
--}
-
-data RequiredField = RequiredField
-    deriving (Show, Typeable)
-instance Exception RequiredField
-
 instance ConvertSuccess Hack.Env RawRequest where
   convertSuccess env =
-    let (Right rawPieces) = splitPath $ Hack.pathInfo env
+    let gets' = decodeUrlPairs $ Hack.queryString env :: [(String, String)]
-        gets' = decodeUrlPairs $ Hack.queryString env :: [(String, String)]
+        clength = fromMaybe "0" $ lookup "Content-Length" $ Hack.http env
-        clength = tryLookup "0" "Content-Length" $ Hack.http env
+        ctype = fromMaybe "" $ lookup "Content-Type" $ Hack.http env
-        ctype = tryLookup "" "Content-Type" $ Hack.http env
         convertFileInfo (FileInfo a b c) = FileInfo (cs a) (cs b) c
         (posts, files) = map (convertSuccess *** convertSuccess) ***
                          map (convertSuccess *** convertFileInfo)
                        $ parsePost ctype clength
                        $ Hack.hackInput env
-        rawCookie = tryLookup "" "Cookie" $ Hack.http env
+        rawCookie = fromMaybe "" $ lookup "Cookie" $ Hack.http env
         cookies' = decodeCookies rawCookie :: [(String, String)]
-        langs = ["en"] -- FIXME
+     in RawRequest gets' cookies' posts files env
-     in RawRequest rawPieces gets' posts cookies' files env langs
 
 #if TEST
 testSuite :: Test
@@ -244,12 +155,12 @@ testSuite = testGroup "Yesod.Request"
 
 caseAppInst :: Assertion
 caseAppInst = do
-    let r5 = Request $ const $ Right 5
+    let r5 = Request $ const $ Right (5 :: Int)
         rAdd2 = Request $ const $ Right (+ 2)
-        r7 = Request $ const $ Right 7
+        r7 = Request $ const $ Right (7 :: Int)
         rr = undefined
         myEquals e t = (unRequest e) rr `myEquals2` (unRequest t) rr
         myEquals2 x y = show x @=? show y
-    r5 `myEquals` pure 5
+    r5 `myEquals` pure (5 :: Int)
     r7 `myEquals` (rAdd2 <*> r5)
 #endif

Yesod/Resource.hs

@@ -477,7 +477,6 @@ instance Arbitrary RPP where
 
 caseFromYaml :: Assertion
 caseFromYaml = do
-    contents <- readYamlDoc "Test/resource-patterns.yaml"
     rp1 <- readRP "static/*filepath"
     rp2 <- readRP "page"
     rp3 <- readRP "page/$page"
@@ -491,13 +490,14 @@ caseFromYaml = do
                               ]
          , RPNode rp4 $ Verbs [(Get, "userInfo")]
          ]
-    contents' <- fa $ ca contents
+    contents' <- decodeFile "Test/resource-patterns.yaml"
-    expected @=? contents'
+    contents <- convertAttemptWrap (contents' :: TextObject)
+    expected @=? contents
 
 caseCheckRPNodes :: Assertion
 caseCheckRPNodes = do
-    good' <- readYamlDoc "Test/resource-patterns.yaml"
+    good' <- decodeFile "Test/resource-patterns.yaml"
-    good <- fa $ ca good'
+    good <- convertAttemptWrap (good' :: TextObject)
     Just good @=? checkRPNodes good
     rp1 <- readRP "foo/bar"
     rp2 <- readRP "$foo/bar"

Yesod/Utils.hs

@@ -1,59 +0,0 @@
-{-# LANGUAGE CPP #-}
----------------------------------------------------------
---
--- Module        : Yesod.Utils
--- Copyright     : Michael Snoyman
--- License       : BSD3
---
--- Maintainer    : Michael Snoyman <michael@snoyman.com>
--- Stability     : Stable
--- Portability   : portable
---
--- Utility functions for Restful.
--- These are all functions which could be exported to another library.
---
----------------------------------------------------------
-module Yesod.Utils
-    ( parseHttpAccept
-    , tryLookup
-#if TEST
-    , testSuite
-#endif
-    ) where
-
-import Data.List.Split (splitOneOf)
-import Data.Maybe (fromMaybe)
-
-#if TEST
-import Test.Framework (testGroup, Test)
-import Test.Framework.Providers.HUnit
-import Test.HUnit hiding (Test)
-#endif
-
--- | Parse the HTTP accept string to determine supported content types.
-parseHttpAccept :: String -> [String]
-parseHttpAccept = filter (not . specialHttpAccept) . splitOneOf ";,"
-
-specialHttpAccept :: String -> Bool
-specialHttpAccept ('q':'=':_) = True
-specialHttpAccept ('*':_) = True
-specialHttpAccept _ = False
-
--- | Attempt a lookup, returning a default value on failure.
-tryLookup :: Eq k => v -> k -> [(k, v)] -> v
-tryLookup def key = fromMaybe def . lookup key
-
-#if TEST
------ Testing
-testSuite :: Test
-testSuite = testGroup "Yesod.Utils"
-    [ testCase "tryLookup1" caseTryLookup1
-    , testCase "tryLookup2" caseTryLookup2
-    ]
-
-caseTryLookup1 :: Assertion
-caseTryLookup1 = tryLookup "default" "foo" [] @?= "default"
-
-caseTryLookup2 :: Assertion
-caseTryLookup2 = tryLookup "default" "foo" [("foo", "baz")] @?= "baz"
-#endif

Yesod/Yesod.hs

@@ -13,13 +13,13 @@ import Yesod.Request
 import Yesod.Constants
 import Yesod.Definitions
 import Yesod.Handler
-import Yesod.Utils
 import Yesod.Template (TemplateGroup)
 
 import Data.Maybe (fromMaybe)
 import Data.Convertible.Text
 import Text.StringTemplate
 import Web.Mime
+import Web.Encodings (parseHttpAccept)
 
 import qualified Hack
 import Hack.Middleware.CleanPath

runtests.hs

@@ -1,7 +1,6 @@
 import Test.Framework (defaultMain)
 
 import qualified Yesod.Response
-import qualified Yesod.Utils
 import qualified Yesod.Resource
 import qualified Yesod.Rep
 import qualified Yesod.Request
@@ -12,7 +11,6 @@ import qualified Test.QuasiResource
 main :: IO ()
 main = defaultMain
     [ Yesod.Response.testSuite
-    , Yesod.Utils.testSuite
     , Yesod.Resource.testSuite
     , Yesod.Rep.testSuite
     , Yesod.Request.testSuite

yesod.cabal

@@ -37,7 +37,7 @@ library
                      authenticate >= 0.4.0 && < 0.5,
                      predicates >= 0.1 && < 0.2,
                      bytestring >= 0.9.1.4 && < 0.10,
-                     web-encodings >= 0.2.0 && < 0.3,
+                     web-encodings >= 0.2.1 && < 0.3,
                      data-object >= 0.2.0 && < 0.3,
                      data-object-yaml >= 0.2.0 && < 0.3,
                      directory >= 1 && < 1.1,
@@ -59,7 +59,6 @@ library
                      Yesod.Rep
                      Yesod.Request
                      Yesod.Response
-                     Yesod.Utils
                      Yesod.Definitions
                      Yesod.Handler
                      Yesod.Parameter