diff --git a/Data/Object/Html.hs b/Data/Object/Html.hs index 3a228cf1..32938049 100644 --- a/Data/Object/Html.hs +++ b/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 "

Some HTML
" ++ "<'this should be escaped'>" ++ "
" - cs actual @?= (cs expected :: Text) + unHtmlFragment (cs actual) @?= (cs expected :: Text) caseStringTemplate :: Assertion caseStringTemplate = do diff --git a/Test/Errors.hs b/Test/Errors.hs index 84cbe86f..1363987a 100644 --- a/Test/Errors.hs +++ b/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/" } diff --git a/Yesod/Definitions.hs b/Yesod/Definitions.hs index 8ad89f93..5340f864 100644 --- a/Yesod/Definitions.hs +++ b/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] diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 1ff77111..35194413 100644 --- a/Yesod/Helpers/Auth.hs +++ b/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 diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs index 7531fbb8..5d81cdb3 100644 --- a/Yesod/Rep.hs +++ b/Yesod/Rep.hs @@ -200,7 +200,7 @@ caseChooseRepTemplate :: Assertion caseChooseRepTemplate = do let temp = newSTMP "foo:$o.foo$, bar:$o.bar$" ho = toHtmlObject [ ("foo", toHtmlObject "") - , ("bar", toHtmlObject ["bar1", "bar2"]) + , ("bar", Sequence $ map cs ["bar1", "bar2"]) ] hasreps = Template temp "o" ho $ return [] res1 = cs "foo:<fooval>, bar:bar1bar2" @@ -215,7 +215,7 @@ caseChooseRepTemplateFile :: Assertion caseChooseRepTemplateFile = do let temp = "Test/rep.st" ho = toHtmlObject [ ("foo", toHtmlObject "") - , ("bar", toHtmlObject ["bar1", "bar2"]) + , ("bar", Sequence $ map cs ["bar1", "bar2"]) ] hasreps = TemplateFile temp ho res1 = cs "foo:<fooval>, bar:bar1bar2" diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 441ef611..5e3458b3 100644 --- a/Yesod/Request.hs +++ b/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 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 diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 581bfdad..0b1917a4 100644 --- a/Yesod/Resource.hs +++ b/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 - 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" diff --git a/Yesod/Utils.hs b/Yesod/Utils.hs deleted file mode 100644 index e8959e88..00000000 --- a/Yesod/Utils.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE CPP #-} ---------------------------------------------------------- --- --- Module : Yesod.Utils --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- 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 diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 3b9411a9..c5ab7843 100644 --- a/Yesod/Yesod.hs +++ b/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 diff --git a/runtests.hs b/runtests.hs index 6da45977..a5e8e423 100644 --- a/runtests.hs +++ b/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 diff --git a/yesod.cabal b/yesod.cabal index bc87bf3a..7ad4eeaf 100644 --- a/yesod.cabal +++ b/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