From d34f44fd53c4e696c2f7076a26ef486d10259a66 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Wed, 30 Jun 2010 21:11:15 +0300
Subject: [PATCH] More sane Yesod.Request lookup functions

---
 Yesod/Form.hs         |  9 +++--
 Yesod/Helpers/Auth.hs | 36 ++++++++----------
 Yesod/Request.hs      | 88 +++++++++++++++++++++++--------------------
 3 files changed, 69 insertions(+), 64 deletions(-)

diff --git a/Yesod/Form.hs b/Yesod/Form.hs
index 03f9c0fc..3dafee0b 100644
--- a/Yesod/Form.hs
+++ b/Yesod/Form.hs
@@ -63,15 +63,18 @@ runFormPost :: (RequestReader m, Failure ErrorResponse m, MonadIO m)
             => Form x -> m x
 runFormPost f = do
     rr <- getRequest
-    pp <- postParams rr
-    runFormGeneric pp f
+    (pp, _) <- liftIO $ reqRequestBody rr
+    runFormGeneric (flip lookup' pp) f
+
+lookup' :: Eq a => a -> [(a, b)] -> [b]
+lookup' a = map snd . filter (\x -> a == fst x)
 
 -- | Run a form against GET parameters.
 runFormGet :: (RequestReader m, Failure ErrorResponse m)
            => Form x -> m x
 runFormGet f = do
     rr <- getRequest
-    runFormGeneric (getParams rr) f
+    runFormGeneric (flip lookupGetParams rr) f
 
 input :: ParamName -> Form [ParamValue]
 input pn = Form $ \l -> Right (Just pn, l pn)
diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs
index cb55cd41..aee6537c 100644
--- a/Yesod/Helpers/Auth.hs
+++ b/Yesod/Helpers/Auth.hs
@@ -168,17 +168,14 @@ testOpenId = do
 getOpenIdR :: Yesod master => GHandler Auth master RepHtml
 getOpenIdR = do
     testOpenId
-    rr <- getRequest
-    case getParams rr "dest" of
-        [] -> return ()
-        (x:_) -> setUltDestString x
+    lookupGetParam "dest" >>= maybe (return ()) setUltDestString
     rtom <- getRouteToMaster
     message <- getMessage
     applyLayout "Log in via OpenID" mempty [$hamlet|
 $maybe message msg
     %p.message $msg$
 %form!method=get!action=@rtom.OpenIdForward@
-    %label!for=openid OpenID: 
+    %label!for=openid OpenID: $
     %input#openid!type=text!name=openid
     %input!type=submit!value=Login
 |]
@@ -186,10 +183,7 @@ $maybe message msg
 getOpenIdForward :: GHandler Auth master ()
 getOpenIdForward = do
     testOpenId
-    rr <- getRequest
-    oid <- case getParams rr "openid" of
-            [x] -> return x
-            _ -> invalidArgs [("openid", "Expected single parameter")]
+    oid <- runFormGet $ required $ input "openid"
     render <- getUrlRender
     toMaster <- getRouteToMaster
     let complete = render $ toMaster OpenIdComplete
@@ -224,11 +218,11 @@ handleRpxnowR = do
     apiKey <- case authRpxnowApiKey auth of
                 Just x -> return x
                 Nothing -> notFound
-    rr <- getRequest
-    pp <- postParams rr
-    let token = case getParams rr "token" ++ pp "token" of
-                    [] -> invalidArgs [("token", "Value not supplied")]
-                    (x:_) -> x
+    token1 <- lookupGetParam "token"
+    token2 <- lookupPostParam "token"
+    let token = case token1 `mplus` token2 of
+                    Nothing -> invalidArgs [("token", "Value not supplied")]
+                    Just x -> x
     Rpxnow.Identifier ident extra <- liftIO $ Rpxnow.authenticate apiKey token
     let creds = Creds
                     ident
@@ -238,14 +232,14 @@ handleRpxnowR = do
                     Nothing
                     Nothing
     setCreds creds extra
+    dest1 <- lookupPostParam "dest"
+    dest2 <- lookupGetParam "dest"
     either (redirect RedirectTemporary) (redirectString RedirectTemporary) $
-        case pp "dest" of
-            (d:_) -> Right d
-            [] -> case getParams rr "dest" of
-                    [] -> Left $ defaultDest ay
-                    ("":_) -> Left $ defaultDest ay
-                    (('#':rest):_) -> Right rest
-                    (s:_) -> Right s
+        case dest1 `mplus` dest2 of
+            Just "" -> Left $ defaultDest ay
+            Nothing -> Left $ defaultDest ay
+            Just ('#':d) -> Right d
+            Just d -> Right d
 
 -- | Get some form of a display name.
 getDisplayName :: [(String, String)] -> Maybe String
diff --git a/Yesod/Request.hs b/Yesod/Request.hs
index 10c9ef10..f69c0a67 100644
--- a/Yesod/Request.hs
+++ b/Yesod/Request.hs
@@ -29,11 +29,13 @@ module Yesod.Request
     , lookupPostParam
     , lookupCookie
     , lookupSession
-      -- ** Alternate
-    , getParams
-    , postParams
-    , cookies
-    , session
+    , lookupFile
+      -- ** Multi-lookup
+    , lookupGetParams
+    , lookupPostParams
+    , lookupCookies
+    , lookupSessions
+    , lookupFiles
       -- * Parameter type synonyms
     , ParamName
     , ParamValue
@@ -46,6 +48,7 @@ import "transformers" Control.Monad.IO.Class
 import Control.Monad (liftM)
 import Network.Wai.Parse
 import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r
+import Data.Maybe (listToMaybe)
 
 type ParamName = String
 type ParamValue = String
@@ -99,59 +102,64 @@ data Request = Request
     , reqLangs :: [String]
     }
 
-multiLookup :: [(ParamName, ParamValue)] -> ParamName -> [ParamValue]
-multiLookup [] _ = []
-multiLookup ((k, v):rest) pn
-    | k == pn = v : multiLookup rest pn
-    | otherwise = multiLookup rest pn
+lookup' :: Eq a => a -> [(a, b)] -> [b]
+lookup' a = map snd . filter (\x -> a == fst x)
 
--- | All GET paramater values with the given name.
-getParams :: RequestReader m => m (ParamName -> [ParamValue])
-getParams = do
+-- | Lookup for GET parameters.
+lookupGetParams :: RequestReader m => ParamName -> m [ParamValue]
+lookupGetParams pn = do
     rr <- getRequest
-    return $ multiLookup $ reqGetParams rr
+    return $ lookup' pn $ reqGetParams rr
 
 -- | Lookup for GET parameters.
 lookupGetParam :: RequestReader m => ParamName -> m (Maybe ParamValue)
-lookupGetParam pn = do
-    rr <- getRequest
-    return $ lookup pn $ reqGetParams rr
-
--- | All POST paramater values with the given name.
-postParams :: MonadIO m => Request -> m (ParamName -> [ParamValue])
-postParams rr = do
-    (pp, _) <- liftIO $ reqRequestBody rr
-    return $ multiLookup pp
+lookupGetParam = liftM listToMaybe . lookupGetParams
 
 -- | Lookup for POST parameters.
+lookupPostParams :: (MonadIO m, RequestReader m)
+                 => ParamName
+                 -> m [ParamValue]
+lookupPostParams pn = do
+    rr <- getRequest
+    (pp, _) <- liftIO $ reqRequestBody rr
+    return $ lookup' pn pp
+
 lookupPostParam :: (MonadIO m, RequestReader m)
                 => ParamName
                 -> m (Maybe ParamValue)
-lookupPostParam pn = do
-    rr <- getRequest
-    (pp, _) <- liftIO $ reqRequestBody rr
-    return $ lookup pn pp
+lookupPostParam = liftM listToMaybe . lookupPostParams
 
--- | All cookies with the given name.
-cookies :: RequestReader m => m (ParamName -> [ParamValue])
-cookies = do
+-- | Lookup for POSTed files.
+lookupFile :: (MonadIO m, RequestReader m)
+           => ParamName
+           -> m (Maybe (FileInfo BL.ByteString))
+lookupFile = liftM listToMaybe . lookupFiles
+
+-- | Lookup for POSTed files.
+lookupFiles :: (MonadIO m, RequestReader m)
+            => ParamName
+            -> m [FileInfo BL.ByteString]
+lookupFiles pn = do
     rr <- getRequest
-    return $ multiLookup $ reqCookies rr
+    (_, files) <- liftIO $ reqRequestBody rr
+    return $ lookup' pn files
 
 -- | Lookup for cookie data.
 lookupCookie :: RequestReader m => ParamName -> m (Maybe ParamValue)
-lookupCookie pn = do
-    rr <- getRequest
-    return $ lookup pn $ reqCookies rr
+lookupCookie = liftM listToMaybe . lookupCookies
 
--- | All session data with the given name.
-session :: RequestReader m => m (ParamName -> [ParamValue])
-session = do
+-- | Lookup for cookie data.
+lookupCookies :: RequestReader m => ParamName -> m [ParamValue]
+lookupCookies pn = do
     rr <- getRequest
-    return $ multiLookup $ reqSession rr
+    return $ lookup' pn $ reqCookies rr
 
 -- | Lookup for session data.
 lookupSession :: RequestReader m => ParamName -> m (Maybe ParamValue)
-lookupSession pn = do
+lookupSession = liftM listToMaybe . lookupSessions
+
+-- | Lookup for session data.
+lookupSessions :: RequestReader m => ParamName -> m [ParamValue]
+lookupSessions pn = do
     rr <- getRequest
-    return $ lookup pn $ reqSession rr
+    return $ lookup' pn $ reqSession rr