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

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

Browse Source
This commit is contained in:
Michael Snoyman 2010-01-01 03:50:52 +02:00
parent 24c9e5c54a
commit 58f9f3e054
10 changed files with 120 additions and 183 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
TODO
View File

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

7
Test/Errors.hs
View File

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

5
Yesod.hs
View File

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

5
Yesod/Definitions.hs
View File

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

10
Yesod/Handler.hs
View File

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

25
Yesod/Helpers/Auth.hs
View File

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

239
Yesod/Request.hs
View File

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

2
Yesod/Yesod.hs
View File

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

2
runtests.hs
View File

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

7
yesod.cabal
View File

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