haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Removed more from Yesod.Request, with cascading removals

Browse Source
This commit is contained in:
Michael Snoyman 2010-01-25 00:23:55 +02:00
parent 9ccfe9ba90
commit 254018e3c3
11 changed files with 82 additions and 185 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
Data/Object/Html.hs
View File

@ -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

4
Test/Errors.hs
View File

@ -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/" }

3
Yesod/Definitions.hs
View File

@ -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]

51
Yesod/Helpers/Auth.hs
View File

@ -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

4
Yesod/Rep.hs
View File

@ -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"

121
Yesod/Request.hs
View File

@ -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 Data.Typeable (Typeable)
import Control.Exception (SomeException (..))
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)]
, rawPostParams :: [(ParamName, ParamValue)]
{ rawGetParams :: [(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
gets' = decodeUrlPairs $ Hack.queryString env :: [(String, String)]
clength = tryLookup "0" "Content-Length" $ Hack.http env
ctype = tryLookup "" "Content-Type" $ Hack.http env
let gets' = decodeUrlPairs $ Hack.queryString env :: [(String, String)]
clength = fromMaybe "0" $ lookup "Content-Length" $ Hack.http env
ctype = fromMaybe "" $ lookup "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 rawPieces gets' posts cookies' files env langs
in RawRequest gets' cookies' posts files env
#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

10
Yesod/Resource.hs
View File

@ -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
expected @=? contents'
contents' <- decodeFile "Test/resource-patterns.yaml"
contents <- convertAttemptWrap (contents' :: TextObject)
expected @=? contents
caseCheckRPNodes :: Assertion
caseCheckRPNodes = do
good' <- readYamlDoc "Test/resource-patterns.yaml"
good <- fa $ ca good'
good' <- decodeFile "Test/resource-patterns.yaml"
good <- convertAttemptWrap (good' :: TextObject)
Just good @=? checkRPNodes good
rp1 <- readRP "foo/bar"
rp2 <- readRP "$foo/bar"

59
Yesod/Utils.hs
View File

@ -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

2
Yesod/Yesod.hs
View File

@ -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

2
runtests.hs
View File

@ -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

3
yesod.cabal
View File

@ -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