diff --git a/Yesod/Form.hs b/Yesod/Form.hs index ee9aa7ef..672c5160 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -52,14 +52,14 @@ runFormGeneric params (Form f) = -- | Run a form against POST parameters. runFormPost :: Form x -> Handler y x runFormPost f = do - rr <- getRawRequest + rr <- getRequest pp <- postParams rr runFormGeneric pp f -- | Run a form against GET parameters. runFormGet :: Form x -> Handler y x runFormGet f = do - rr <- getRawRequest + rr <- getRequest runFormGeneric (getParams rr) f input :: ParamName -> Form [ParamValue] diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 082b461f..55df6bb7 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -51,7 +51,7 @@ import Data.Object.Html import qualified Data.ByteString.Lazy as BL import qualified Network.Wai as W -data HandlerData yesod = HandlerData RawRequest yesod +data HandlerData yesod = HandlerData Request yesod ------ Handler monad newtype Handler yesod a = Handler { @@ -84,7 +84,7 @@ instance MonadIO (Handler yesod) where instance Exception e => Failure e (Handler yesod) where failure e = Handler $ \_ -> return ([], HCError $ InternalError $ show e) instance RequestReader (Handler yesod) where - getRawRequest = Handler $ \(HandlerData rr _) + getRequest = Handler $ \(HandlerData rr _) -> return ([], HCContent rr) getYesod :: Handler yesod yesod @@ -92,7 +92,7 @@ getYesod = Handler $ \(HandlerData _ yesod) -> return ([], HCContent yesod) runHandler :: Handler yesod ChooseRep -> (ErrorResponse -> Handler yesod ChooseRep) - -> RawRequest + -> Request -> yesod -> [ContentType] -> IO Response diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index a0600e1e..888e59f8 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -98,7 +98,7 @@ instance Exception ExpectedSingleParam authOpenidForm :: Yesod y => Handler y ChooseRep authOpenidForm = do - rr <- getRawRequest + rr <- getRequest case getParams rr "dest" of [] -> return () (x:_) -> addCookie destCookieTimeout destCookieName x @@ -119,7 +119,7 @@ authOpenidForm = do authOpenidForward :: YesodAuth y => Handler y () authOpenidForward = do - rr <- getRawRequest + rr <- getRequest oid <- case getParams rr "openid" of [x] -> return x _ -> invalidArgs [("openid", show ExpectedSingleParam)] @@ -134,8 +134,8 @@ authOpenidForward = do authOpenidComplete :: YesodApproot y => Handler y () authOpenidComplete = do - rr <- getRawRequest - let gets' = rawGetParams rr + rr <- getRequest + let gets' = reqGetParams rr res <- runAttemptT $ OpenId.authenticate gets' let onFailure err = redirect RedirectTemporary $ "/auth/openid/?message=" @@ -153,7 +153,7 @@ rpxnowLogin = do apiKey <- case rpxnowApiKey ay of Just x -> return x Nothing -> notFound - rr <- getRawRequest + rr <- getRequest pp <- postParams rr let token = case getParams rr "token" ++ pp "token" of [] -> failure MissingToken @@ -201,14 +201,14 @@ authLogout = do -- | Gets the identifier for a user if available. maybeIdentifier :: (Functor m, Monad m, RequestReader m) => m (Maybe String) maybeIdentifier = - fmap cs . lookup (B8.pack authCookieName) . rawSession - <$> getRawRequest + fmap cs . lookup (B8.pack authCookieName) . reqSession + <$> getRequest -- | Gets the display name for a user if available. displayName :: (Functor m, Monad m, RequestReader m) => m (Maybe String) displayName = do - rr <- getRawRequest - return $ fmap cs $ lookup (B8.pack authDisplayName) $ rawSession rr + rr <- getRequest + return $ fmap cs $ lookup (B8.pack authDisplayName) $ reqSession rr -- | Gets the identifier for a user. If user is not logged in, redirects them -- to the login page. @@ -249,7 +249,7 @@ redirectSetDest rt dest = do -- cookie is missing, then use the default path provided. redirectToDest :: RedirectType -> String -> Handler y a redirectToDest rt def = do - rr <- getRawRequest + rr <- getRequest dest <- case cookies rr destCookieName of [] -> return def (x:_) -> do diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 0d925f9f..13c74953 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -4,6 +4,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE CPP #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE NoMonomorphismRestriction #-} --------------------------------------------------------- -- -- Module : Yesod.Request @@ -19,8 +20,8 @@ --------------------------------------------------------- module Yesod.Request ( - -- * RawRequest - RawRequest (..) + -- * Request + Request (..) , RequestReader (..) , waiRequest , cookies @@ -60,30 +61,30 @@ type ParamValue = String type ParamError = String class RequestReader m where - getRawRequest :: m RawRequest -instance RequestReader ((->) RawRequest) where - getRawRequest = id + getRequest :: m Request +instance RequestReader ((->) Request) where + getRequest = id languages :: (Functor m, RequestReader m) => m [Language] -languages = rawLangs `fmap` getRawRequest +languages = reqLangs `fmap` getRequest --- | Get the raw 'W.Request' value. +-- | Get the req 'W.Request' value. waiRequest :: (Functor m, RequestReader m) => m W.Request -waiRequest = rawWaiRequest `fmap` getRawRequest +waiRequest = reqWaiRequest `fmap` getRequest type RequestBodyContents = ( [(ParamName, ParamValue)] , [(ParamName, FileInfo String BL.ByteString)] ) --- | The raw information passed through W, cleaned up a bit. -data RawRequest = RawRequest - { rawGetParams :: [(ParamName, ParamValue)] - , rawCookies :: [(ParamName, ParamValue)] - , rawSession :: [(B.ByteString, B.ByteString)] - , rawRequestBody :: IO RequestBodyContents - , rawWaiRequest :: W.Request - , rawLangs :: [Language] +-- | The req information passed through W, cleaned up a bit. +data Request = Request + { reqGetParams :: [(ParamName, ParamValue)] + , reqCookies :: [(ParamName, ParamValue)] + , reqSession :: [(B.ByteString, B.ByteString)] + , reqRequestBody :: IO RequestBodyContents + , reqWaiRequest :: W.Request + , reqLangs :: [Language] } multiLookup :: [(ParamName, ParamValue)] -> ParamName -> [ParamValue] @@ -93,13 +94,13 @@ multiLookup ((k, v):rest) pn | otherwise = multiLookup rest pn -- | All GET paramater values with the given name. -getParams :: RawRequest -> ParamName -> [ParamValue] -getParams rr = multiLookup $ rawGetParams rr +getParams :: Request -> ParamName -> [ParamValue] +getParams rr = multiLookup $ reqGetParams rr -- | All POST paramater values with the given name. -postParams :: MonadIO m => RawRequest -> m (ParamName -> [ParamValue]) +postParams :: MonadIO m => Request -> m (ParamName -> [ParamValue]) postParams rr = do - (pp, _) <- liftIO $ rawRequestBody rr + (pp, _) <- liftIO $ reqRequestBody rr return $ multiLookup pp -- | Produces a \"compute on demand\" value. The computation will be run once @@ -116,14 +117,16 @@ iothunk = fmap go . newMVar . Left where return (Right val, val) -- | All cookies with the given name. -cookies :: RawRequest -> ParamName -> [ParamValue] -cookies rr name = map snd . filter (fst `equals` name) . rawCookies $ rr +cookies :: Request -> ParamName -> [ParamValue] +cookies rr name = map snd . filter (fst `equals` name) . reqCookies $ rr -parseWaiRequest :: W.Request -> [(B.ByteString, B.ByteString)] -> IO RawRequest +parseWaiRequest :: W.Request + -> [(B.ByteString, B.ByteString)] -- ^ session + -> IO Request parseWaiRequest env session = do let gets' = map (cs *** cs) $ decodeUrlPairs $ W.queryString env - let rawCookie = fromMaybe B.empty $ lookup W.Cookie $ W.requestHeaders env - cookies' = map (cs *** cs) $ parseCookies rawCookie + let reqCookie = fromMaybe B.empty $ lookup W.Cookie $ W.requestHeaders env + cookies' = map (cs *** cs) $ parseCookies reqCookie acceptLang = lookup W.AcceptLanguage $ W.requestHeaders env langs = map cs $ maybe [] parseHttpAccept acceptLang langs' = case lookup langKey cookies' of @@ -133,7 +136,7 @@ parseWaiRequest env session = do Nothing -> langs' Just x -> x : langs' rbthunk <- iothunk $ rbHelper env - return $ RawRequest gets' cookies' session rbthunk env langs'' + return $ Request gets' cookies' session rbthunk env langs'' rbHelper :: W.Request -> IO RequestBodyContents rbHelper = fmap (fix1 *** map fix2) . parseRequestBody lbsSink where diff --git a/Yesod/Response.hs b/Yesod/Response.hs index ccb64fe2..b3a90802 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -242,7 +242,7 @@ responseToWaiResponse (Response sc hs ct c) = do #if TEST runContent :: Content -> IO L.ByteString runContent (ContentFile fp) = L.readFile fp -runContent (ContentEnum c) = WE.toLBS c +runContent (ContentEnum c) = WE.toLBS $ W.Enumerator c ----- Testing testSuite :: Test diff --git a/Yesod/Template.hs b/Yesod/Template.hs index f4dd799e..45302ff6 100644 --- a/Yesod/Template.hs +++ b/Yesod/Template.hs @@ -22,14 +22,14 @@ import Yesod.Response import Yesod.Yesod import Yesod.Handler import Control.Monad (join) -import Yesod.Request (RawRequest, getRawRequest) +import Yesod.Request (Request, getRequest) type Template = StringTemplate Text type TemplateGroup = STGroup Text class Yesod y => YesodTemplate y where getTemplateGroup :: y -> TemplateGroup - defaultTemplateAttribs :: y -> RawRequest -> HtmlTemplate + defaultTemplateAttribs :: y -> Request -> HtmlTemplate -> IO HtmlTemplate getTemplateGroup' :: YesodTemplate y => Handler y TemplateGroup @@ -56,7 +56,7 @@ templateHtml tn f = do t <- case getStringTemplate tn tg of Nothing -> failure $ NoSuchTemplate tn Just x -> return x - rr <- getRawRequest + rr <- getRequest return $ RepHtml $ ioTextToContent $ fmap (render . unHtmlTemplate) $ join @@ -79,7 +79,7 @@ templateHtmlJson :: YesodTemplate y templateHtmlJson tn ho f = do tg <- getTemplateGroup' y <- getYesod - rr <- getRawRequest + rr <- getRequest t <- case getStringTemplate tn tg of Nothing -> failure $ NoSuchTemplate tn Just x -> return x diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 81cc7706..a50556ef 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -46,14 +46,14 @@ class Yesod a where -- | Applies some form of layout to and <body> contents of a page. applyLayout :: a - -> RawRequest + -> Request -> String -- ^ title -> Html -- ^ body -> Content applyLayout _ _ t b = cs (cs (Tag "title" [] $ cs t, b) :: HtmlDoc) -- | Gets called at the beginning of each request. Useful for logging. - onRequest :: a -> RawRequest -> IO () + onRequest :: a -> Request -> IO () onRequest _ _ = return () class Yesod a => YesodApproot a where @@ -67,7 +67,7 @@ applyLayout' :: Yesod y -> Handler y ChooseRep applyLayout' t b = do y <- getYesod - rr <- getRawRequest + rr <- getRequest return $ chooseRep [ (TypeHtml, applyLayout y rr t b) ] @@ -80,7 +80,7 @@ applyLayoutJson :: Yesod y -> Handler y ChooseRep applyLayoutJson t b = do y <- getYesod - rr <- getRawRequest + rr <- getRequest return $ chooseRep [ (TypeHtml, applyLayout y rr t $ cs b) , (TypeJson, cs $ unJsonDoc $ cs b) diff --git a/examples/fact.lhs b/examples/fact.lhs index 301143eb..8918a25a 100644 --- a/examples/fact.lhs +++ b/examples/fact.lhs @@ -89,7 +89,7 @@ one piece of data. > factRedirect :: Handler y () > factRedirect = do -> rr <- getRawRequest +> rr <- getRequest > let i = case getParams rr "num" of -- FIXME > [] -> "1" > (x:_) -> x diff --git a/examples/pretty-yaml.hs b/examples/pretty-yaml.hs index 132ff5a2..1f20a054 100644 --- a/examples/pretty-yaml.hs +++ b/examples/pretty-yaml.hs @@ -22,8 +22,8 @@ homepageH = templateHtml "pretty-yaml" return showYamlH :: Handler PY RepHtmlJson showYamlH = do - rr <- getRawRequest - (_, files) <- liftIO $ rawRequestBody rr + rr <- getRequest + (_, files) <- liftIO $ reqRequestBody rr fi <- case lookup "yaml" files of Nothing -> invalidArgs [("yaml", "Missing input")] Just x -> return x diff --git a/yesod.cabal b/yesod.cabal index d155f460..ce26b0ab 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -38,7 +38,7 @@ library authenticate >= 0.4.0 && < 0.5, predicates >= 0.1 && < 0.2, bytestring >= 0.9.1.4 && < 0.10, - web-encodings >= 0.4.0 && < 0.5, + web-encodings >= 0.2.4 && < 0.3, data-object >= 0.2.0 && < 0.3, data-object-yaml >= 0.2.0 && < 0.3, directory >= 1 && < 1.1, @@ -107,3 +107,19 @@ executable fact Buildable: False ghc-options: -Wall main-is: examples/fact.lhs + +executable i18n + if flag(buildsamples) + Buildable: True + else + Buildable: False + ghc-options: -Wall + main-is: examples/i18n.hs + +executable pretty-yaml + if flag(buildsamples) + Buildable: True + else + Buildable: False + ghc-options: -Wall + main-is: examples/pretty-yaml.hs