yesod-core 0.9.4.1 → 0.10.1
raw patch · 27 files changed
+769/−1431 lines, 27 filesdep +conduitdep +lifted-basedep +yesod-routesdep −data-objectdep −data-object-yamldep −enumeratordep ~aesondep ~basedep ~case-insensitive
Dependencies added: conduit, lifted-base, yesod-routes
Dependencies removed: data-object, data-object-yaml, enumerator
Dependency ranges changed: aeson, base, case-insensitive, cookie, failure, fast-logger, hamlet, monad-control, path-pieces, shakespeare-js, time, transformers-base, wai, wai-extra, wai-logger, wai-test
Files
- Yesod/Config.hs +0/−113
- Yesod/Content.hs +2/−2
- Yesod/Core.hs +12/−4
- Yesod/Dispatch.hs +65/−70
- Yesod/Handler.hs +272/−233
- Yesod/Internal.hs +5/−5
- Yesod/Internal/Core.hs +142/−89
- Yesod/Internal/Dispatch.hs +0/−322
- Yesod/Internal/Request.hs +28/−5
- Yesod/Internal/RouteParsing.hs +0/−354
- Yesod/Internal/Session.hs +7/−6
- Yesod/Internal/TestApi.hs +0/−16
- Yesod/Logger.hs +47/−20
- Yesod/Message.hs +1/−0
- Yesod/Request.hs +5/−5
- Yesod/Widget.hs +104/−117
- test/YesodCoreTest/Cache.hs +1/−1
- test/YesodCoreTest/CleanPath.hs +6/−6
- test/YesodCoreTest/ErrorHandling.hs +1/−14
- test/YesodCoreTest/Exceptions.hs +3/−2
- test/YesodCoreTest/InternalRequest.hs +24/−15
- test/YesodCoreTest/Links.hs +1/−2
- test/YesodCoreTest/Media.hs +3/−6
- test/YesodCoreTest/MediaData.hs +12/−0
- test/YesodCoreTest/NoOverloadedStrings.hs +1/−3
- test/YesodCoreTest/Widget.hs +10/−1
- yesod-core.cabal +17/−20
− Yesod/Config.hs
@@ -1,113 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Yesod.Config- {-# DEPRECATED "This code has been moved to yesod-default. This module will be removed in the next major version bump." #-}- ( AppConfig(..)- , loadConfig- , withYamlEnvironment- ) where--import Control.Monad (join)-import Data.Maybe (fromMaybe)-import Data.Object-import Data.Object.Yaml--import Data.Text (Text)-import qualified Data.Text as T---- | Dynamic per-environment configuration which can be loaded at--- run-time negating the need to recompile between environments.-data AppConfig e = AppConfig- { appEnv :: e- , appPort :: Int- , appRoot :: Text- } deriving (Show)---- | Load an @'AppConfig'@ from @config\/settings.yml@.------ Some examples:------ > -- typical local development--- > Development:--- > host: localhost--- > port: 3000--- >--- > -- ssl: will default false--- > -- approot: will default to "http://localhost:3000"------ > -- typical outward-facing production box--- > Production:--- > host: www.example.com--- >--- > -- ssl: will default false--- > -- port: will default 80--- > -- approot: will default "http://www.example.com"------ > -- maybe you're reverse proxying connections to the running app--- > -- on some other port--- > Production:--- > port: 8080--- > approot: "http://example.com"--- >--- > -- approot is specified so that the non-80 port is not appended--- > -- automatically.----loadConfig :: Show e => e -> IO (AppConfig e)-loadConfig env = withYamlEnvironment "config/settings.yml" env $ \e' -> do- e <- maybe (fail "Expected map") return $ fromMapping e'- let mssl = lookupScalar "ssl" e- let mhost = lookupScalar "host" e- let mport = lookupScalar "port" e- let mapproot = lookupScalar "approot" e-- -- set some default arguments- let ssl = maybe False toBool mssl- port <- safeRead "port" $ fromMaybe (if ssl then "443" else "80") mport-- approot <- case (mhost, mapproot) of- (_ , Just ar) -> return ar- (Just host, _ ) -> return $ T.concat- [ if ssl then "https://" else "http://"- , host- , addPort ssl port- ]- _ -> fail "You must supply either a host or approot"-- return $ AppConfig- { appEnv = env- , appPort = port- , appRoot = approot- }-- where- toBool :: Text -> Bool- toBool = (`elem` ["true", "TRUE", "yes", "YES", "Y", "1"])-- addPort :: Bool -> Int -> Text- addPort True 443 = ""- addPort False 80 = ""- addPort _ p = T.pack $ ':' : show p---- | Loads the configuration block in the passed file named by the--- passed environment, yeilds to the passed function as a mapping.------ Errors in the case of a bad load or if your function returns--- @Nothing@.-withYamlEnvironment :: Show e- => FilePath -- ^ the yaml file- -> e -- ^ the environment you want to load- -> (TextObject -> IO a) -- ^ what to do with the mapping- -> IO a-withYamlEnvironment fp env f = do- obj <- join $ decodeFile fp- envs <- fromMapping obj- conf <- maybe (fail $ "Could not find environment: " ++ show env) return- $ lookup (T.pack $ show env) envs- f conf---- | Returns 'fail' if read fails-safeRead :: Monad m => String -> Text -> m Int-safeRead name t = case reads s of- (i, _):_ -> return i- [] -> fail $ concat ["Invalid value for ", name, ": ", s]- where- s = T.unpack t
Yesod/Content.hs view
@@ -54,7 +54,6 @@ import qualified Data.Text.Encoding import qualified Data.Text.Lazy.Encoding -import Data.Enumerator (Enumerator) import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString) import Data.Monoid (mempty) @@ -62,9 +61,10 @@ import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder) import Data.String (IsString (fromString)) import Network.Wai (FilePart)+import Data.Conduit (Source, Flush) data Content = ContentBuilder Builder (Maybe Int) -- ^ The content and optional content length.- | ContentEnum (forall a. Enumerator Builder IO a)+ | ContentSource (Source IO (Flush Builder)) | ContentFile FilePath (Maybe FilePart) -- | Zero-length enumerator.
Yesod/Core.hs view
@@ -8,6 +8,8 @@ -- ** Breadcrumbs , YesodBreadcrumbs (..) , breadcrumbs+ -- * Types+ , Approot (..) -- * Utitlities , maybeAuthorized , widgetToPageContent@@ -15,6 +17,7 @@ , defaultErrorHandler -- * Data types , AuthResult (..)+ , unauthorizedI -- * Logging , LogLevel (..) , formatLogMessage@@ -34,7 +37,6 @@ , module Yesod.Request , module Yesod.Widget , module Yesod.Message- , module Yesod.Config ) where import Yesod.Internal.Core@@ -44,17 +46,17 @@ import Yesod.Request import Yesod.Widget import Yesod.Message-import Yesod.Config import Language.Haskell.TH.Syntax+import qualified Language.Haskell.TH.Syntax as TH import Data.Text (Text) logTH :: LogLevel -> Q Exp logTH level =- [|messageLoggerHandler $(qLocation >>= liftLoc) $(lift level)|]+ [|messageLoggerHandler $(qLocation >>= liftLoc) $(TH.lift level)|] where liftLoc :: Loc -> Q Exp- liftLoc (Loc a b c d e) = [|Loc $(lift a) $(lift b) $(lift c) $(lift d) $(lift e)|]+ liftLoc (Loc a b c d e) = [|Loc $(TH.lift a) $(TH.lift b) $(TH.lift c) $(TH.lift d) $(TH.lift e)|] -- | Generates a function that takes a 'Text' and logs a 'LevelDebug' message. Usage: --@@ -77,3 +79,9 @@ -- > $(logOther "My new level") "This is a log message" logOther :: Text -> Q Exp logOther = logTH . LevelOther++-- | Return an 'Unauthorized' value, with the given i18n message.+unauthorizedI :: RenderMessage master msg => msg -> GHandler sub master AuthResult+unauthorizedI msg =do+ mr <- getMessageRender+ return $ Unauthorized $ mr msg
Yesod/Dispatch.hs view
@@ -15,8 +15,8 @@ , mkYesodDispatch , mkYesodSubDispatch -- ** Path pieces- , SinglePiece (..)- , MultiPiece (..)+ , PathPiece (..)+ , PathMultiPiece (..) , Texts -- * Convert to WAI , toWaiApp@@ -24,15 +24,12 @@ ) where import Data.Functor ((<$>))-import Data.Either (partitionEithers) import Prelude hiding (exp) import Yesod.Internal.Core-import Yesod.Handler-import Yesod.Internal.Dispatch+import Yesod.Handler hiding (lift) import Yesod.Widget (GWidget) -import Web.PathPieces (SinglePiece (..), MultiPiece (..))-import Yesod.Internal.RouteParsing (THResource, Pieces (..), createRoutes, createRender, Resource (..), parseRoutes, parseRoutesNoCheck, parseRoutesFile, parseRoutesFileNoCheck)+import Web.PathPieces import Language.Haskell.TH.Syntax import qualified Network.Wai as W@@ -42,8 +39,16 @@ import Data.ByteString.Lazy.Char8 () import Web.ClientSession-import Data.Char (isUpper) import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import Data.Monoid (mappend)+import qualified Data.ByteString as S+import qualified Blaze.ByteString.Builder+import Network.HTTP.Types (status301)+import Yesod.Routes.TH+import Yesod.Content (chooseRep)+import Yesod.Routes.Parse type Texts = [Text] @@ -51,7 +56,7 @@ -- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter. -- Use 'parseRoutes' to create the 'Resource's. mkYesod :: String -- ^ name of the argument datatype- -> [Resource]+ -> [Resource String] -> Q [Dec] mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False @@ -62,7 +67,7 @@ -- be embedded in other sites. mkYesodSub :: String -- ^ name of the argument datatype -> Cxt- -> [Resource]+ -> [Resource String] -> Q [Dec] mkYesodSub name clazzes = fmap (uncurry (++)) . mkYesodGeneral name' rest clazzes True@@ -73,60 +78,44 @@ -- your handlers elsewhere. For example, this is the only way to break up a -- monolithic file into smaller parts. Use this function, paired with -- 'mkYesodDispatch', to do just that.-mkYesodData :: String -> [Resource] -> Q [Dec]+mkYesodData :: String -> [Resource String] -> Q [Dec] mkYesodData name res = mkYesodDataGeneral name [] False res -mkYesodSubData :: String -> Cxt -> [Resource] -> Q [Dec]+mkYesodSubData :: String -> Cxt -> [Resource String] -> Q [Dec] mkYesodSubData name clazzes res = mkYesodDataGeneral name clazzes True res -mkYesodDataGeneral :: String -> Cxt -> Bool -> [Resource] -> Q [Dec]+mkYesodDataGeneral :: String -> Cxt -> Bool -> [Resource String] -> Q [Dec] mkYesodDataGeneral name clazzes isSub res = do let (name':rest) = words name (x, _) <- mkYesodGeneral name' rest clazzes isSub res let rname = mkName $ "resources" ++ name eres <- lift res- let y = [ SigD rname $ ListT `AppT` ConT ''Resource+ let y = [ SigD rname $ ListT `AppT` (ConT ''Resource `AppT` ConT ''String) , FunD rname [Clause [] (NormalB eres) []] ] return $ x ++ y -- | See 'mkYesodData'.-mkYesodDispatch :: String -> [Resource] -> Q [Dec]+mkYesodDispatch :: String -> [Resource String] -> Q [Dec] mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False -mkYesodSubDispatch :: String -> Cxt -> [Resource] -> Q [Dec]+mkYesodSubDispatch :: String -> Cxt -> [Resource String] -> Q [Dec] mkYesodSubDispatch name clazzes = fmap snd . mkYesodGeneral name' rest clazzes True where (name':rest) = words name -mkYesodGeneral :: String -- ^ foundation name- -> [String] -- ^ parameters for foundation+mkYesodGeneral :: String -- ^ foundation type+ -> [String] -> Cxt -- ^ classes -> Bool -- ^ is subsite?- -> [Resource]+ -> [Resource String] -> Q ([Dec], [Dec])-mkYesodGeneral name args clazzes isSub res = do+mkYesodGeneral name args clazzes isSub resS = do let args' = map mkName args arg = foldl AppT (ConT name') $ map VarT args'- th' <- mapM thResourceFromResource res- let th = map fst th'- w' <- createRoutes th- let routesName = mkName $ name ++ "Route"- let w = DataD [] routesName [] w' [''Show, ''Read, ''Eq]- let x = TySynInstD ''Route [arg] $ ConT routesName-- render <- createRender th- let x' = InstanceD [] (ConT ''RenderRoute `AppT` ConT routesName)- [ FunD (mkName "renderRoute") render- ]+ let res = map (fmap parseType) resS+ renderRouteDec <- mkRenderRouteInstance arg res - let splitter :: (THResource, Maybe String)- -> Either- (THResource, Maybe String)- (THResource, Maybe String)- splitter a@((_, SubSite{}), _) = Left a- splitter a = Right a- let (resSub, resLoc) = partitionEithers $ map splitter th'- yd <- mkYesodDispatch' resSub resLoc+ disp <- mkDispatchClause [|yesodRunner|] [|yesodDispatch|] [|fmap chooseRep|] res let master = mkName "master" let ctx = if isSub then ClassP (mkName "Yesod") [VarT master] : clazzes@@ -134,8 +123,10 @@ let ytyp = if isSub then ConT ''YesodDispatch `AppT` arg `AppT` VarT master else ConT ''YesodDispatch `AppT` arg `AppT` arg- let y = InstanceD ctx ytyp [FunD (mkName "yesodDispatch") [yd]]- return ([w, x, x'] ++ masterTypSyns, [y])+ let yesodDispatch' =+ InstanceD ctx ytyp [FunD (mkName "yesodDispatch") [disp]]++ return (renderRouteDec : masterTypSyns, [yesodDispatch']) where name' = mkName name masterTypSyns@@ -151,45 +142,49 @@ (ConT ''GWidget `AppT` ConT name' `AppT` ConT name' `AppT` TupleT 0) ] -thResourceFromResource :: Resource -> Q (THResource, Maybe String)-thResourceFromResource (Resource n ps atts)- | all (all isUpper) atts = return ((n, Simple ps atts), Nothing)-thResourceFromResource (Resource n ps [stype, toSubArg]) = do- let stype' = ConT $ mkName stype- parse <- [|error "ssParse"|]- dispatch <- [|error "ssDispatch"|]- render <- [|renderRoute|]- tmg <- [|error "ssToMasterArg"|]- return ((n, SubSite- { ssType = ConT ''Route `AppT` stype'- , ssParse = parse- , ssRender = render- , ssDispatch = dispatch- , ssToMasterArg = tmg- , ssPieces = ps- }), Just toSubArg)--thResourceFromResource (Resource n _ _) =- error $ "Invalid attributes for resource: " ++ n- -- | Convert the given argument into a WAI application, executable with any WAI -- handler. This is the same as 'toWaiAppPlain', except it includes two -- middlewares: GZIP compression and autohead. This is the -- recommended approach for most users.-toWaiApp :: (Yesod y, YesodDispatch y y) => y -> IO W.Application-toWaiApp y = gzip (gzipCompressFiles y) . autohead <$> toWaiAppPlain y+toWaiApp :: ( Yesod master+ , YesodDispatch master master+ ) => master -> IO W.Application+toWaiApp y = gzip (gzipSettings y) . autohead <$> toWaiAppPlain y -- | Convert the given argument into a WAI application, executable with any WAI -- handler. This differs from 'toWaiApp' in that it uses no middlewares.-toWaiAppPlain :: (Yesod y, YesodDispatch y y) => y -> IO W.Application+toWaiAppPlain :: ( Yesod master+ , YesodDispatch master master+ ) => master -> IO W.Application toWaiAppPlain a = toWaiApp' a <$> encryptKey a -toWaiApp' :: (Yesod y, YesodDispatch y y)- => y+toWaiApp' :: ( Yesod master+ , YesodDispatch master master+ )+ => master -> Maybe Key -> W.Application toWaiApp' y key' env =- case yesodDispatch y key' (W.pathInfo env) y id of- Just app -> app env- Nothing -> yesodRunner y y id key' Nothing notFound env+ case cleanPath y $ W.pathInfo env of+ Left pieces -> sendRedirect y pieces env+ Right pieces ->+ yesodDispatch y y id app404 handler405 method pieces key' env+ where+ app404 = yesodRunner notFound y y Nothing id+ handler405 route = yesodRunner badMethod y y (Just route) id+ method = decodeUtf8With lenientDecode $ W.requestMethod env++sendRedirect :: Yesod master => master -> [Text] -> W.Application+sendRedirect y segments' env =+ return $ W.responseLBS status301+ [ ("Content-Type", "text/plain")+ , ("Location", Blaze.ByteString.Builder.toByteString dest')+ ] "Redirecting"+ where+ dest = joinPath y (resolveApproot y env) segments' []+ dest' =+ if S.null (W.rawQueryString env)+ then dest+ else (dest `mappend`+ Blaze.ByteString.Builder.fromByteString (W.rawQueryString env))
Yesod/Handler.hs view
@@ -16,7 +16,7 @@ -- License : BSD3 -- -- Maintainer : Michael Snoyman <michael@snoyman.com>--- Stability : unstable+-- Stability : stable -- Portability : portable -- -- Define Handler stuff.@@ -24,11 +24,9 @@ --------------------------------------------------------- module Yesod.Handler ( -- * Type families- Route- , YesodSubRoute (..)+ YesodSubRoute (..) -- * Handler monad , GHandler- , GGHandler -- ** Read information from handler , getYesod , getYesodSub@@ -41,11 +39,9 @@ , runRequestBody -- * Special responses -- ** Redirecting- , RedirectType (..)+ , RedirectUrl (..) , redirect- , redirectParams- , redirectString- , redirectText+ , redirectWith , redirectToPost -- ** Errors , notFound@@ -63,6 +59,7 @@ , sendWaiResponse -- * Setting headers , setCookie+ , getExpires , deleteCookie , setHeader , setLanguage@@ -74,14 +71,14 @@ -- * Session , SessionMap , lookupSession+ , lookupSessionBS , getSession , setSession+ , setSessionBS , deleteSession -- ** Ultimate destination , setUltDest- , setUltDestString- , setUltDestText- , setUltDest'+ , setUltDestCurrent , setUltDestReferer , redirectUltDest , clearUltDest@@ -95,7 +92,8 @@ , hamletToRepHtml -- ** Misc , newIdent- , liftIOHandler+ -- * Lifting+ , MonadLift (..) -- * i18n , getMessageRender -- * Per-request caching@@ -123,7 +121,7 @@ import Prelude hiding (catch) import Yesod.Internal.Request import Yesod.Internal-import Data.Time (UTCTime)+import Data.Time (UTCTime, getCurrentTime, addUTCTime) import Control.Exception hiding (Handler, catch, finally) import Control.Applicative@@ -131,13 +129,12 @@ import Control.Monad (liftM) import Control.Monad.IO.Class-import Control.Monad.Trans.Class-import Control.Monad.Trans.Reader+import Control.Monad.Trans.Class (MonadTrans)+import qualified Control.Monad.Trans.Class import System.IO import qualified Network.Wai as W import qualified Network.HTTP.Types as H-import Control.Failure (Failure (failure)) import Text.Hamlet import qualified Text.Blaze.Renderer.Text@@ -148,8 +145,6 @@ import qualified Data.Map as Map import qualified Data.ByteString as S-import Data.ByteString (ByteString)-import Data.Enumerator (Iteratee (..), run_, ($$)) import Network.Wai.Parse (parseHttpAccept) import Yesod.Content@@ -160,20 +155,22 @@ import Data.Monoid (mappend, mempty, Endo (..)) import qualified Data.ByteString.Char8 as S8 import Data.CaseInsensitive (CI)+import qualified Data.CaseInsensitive as CI import Blaze.ByteString.Builder (toByteString) import Data.Text (Text) import Yesod.Message (RenderMessage (..)) import Text.Blaze (toHtml, preEscapedText)-import Yesod.Internal.TestApi (catchIter) import qualified Yesod.Internal.Cache as Cache import Yesod.Internal.Cache (mkCacheKey, CacheKey) import Data.Typeable (Typeable) import qualified Data.IORef as I---- | The type-safe URLs associated with a site argument.-type family Route a+import Control.Monad.Trans.Resource+import Control.Exception.Lifted (catch)+import Control.Monad.Trans.Control+import Control.Monad.Base+import Yesod.Routes.Class class YesodSubRoute s y where fromSubRoute :: s -> y -> Route s -> Route y@@ -206,22 +203,22 @@ , handlerRoute = route } -get :: MonadIO monad => GGHandler sub master monad GHState+get :: GHandler sub master GHState get = do hd <- ask liftIO $ I.readIORef $ handlerState hd -put :: MonadIO monad => GHState -> GGHandler sub master monad ()+put :: GHState -> GHandler sub master () put g = do hd <- ask liftIO $ I.writeIORef (handlerState hd) g -modify :: MonadIO monad => (GHState -> GHState) -> GGHandler sub master monad ()+modify :: (GHState -> GHState) -> GHandler sub master () modify f = do hd <- ask liftIO $ I.atomicModifyIORef (handlerState hd) $ \g -> (f g, ()) -tell :: MonadIO monad => Endo [Header] -> GGHandler sub master monad ()+tell :: Endo [Header] -> GHandler sub master () tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs } -- | Used internally for promoting subsite handler functions to master site@@ -229,19 +226,19 @@ toMasterHandler :: (Route sub -> Route master) -> (master -> sub) -> Route sub- -> GGHandler sub master mo a- -> GGHandler sub' master mo a-toMasterHandler tm ts route = withReaderT (handlerSubData tm ts route)+ -> GHandler sub master a+ -> GHandler sub' master a+toMasterHandler tm ts route = local (handlerSubData tm ts route) -toMasterHandlerDyn :: Monad mo- => (Route sub -> Route master)- -> GGHandler sub' master mo sub+-- | FIXME do we need this?+toMasterHandlerDyn :: (Route sub -> Route master)+ -> GHandler sub' master sub -> Route sub- -> GGHandler sub master mo a- -> GGHandler sub' master mo a+ -> GHandler sub master a+ -> GHandler sub' master a toMasterHandlerDyn tm getSub route h = do sub <- getSub- withReaderT (handlerSubData tm (const sub) route) h+ local (handlerSubData tm (const sub) route) h class SubsiteGetter g m s | g -> s where runSubsiteGetter :: g -> m s@@ -258,18 +255,15 @@ toMasterHandlerMaybe :: (Route sub -> Route master) -> (master -> sub) -> Maybe (Route sub)- -> GGHandler sub master mo a- -> GGHandler sub' master mo a-toMasterHandlerMaybe tm ts route = withReaderT (handlerSubDataMaybe tm ts route)+ -> GHandler sub master a+ -> GHandler sub' master a+toMasterHandlerMaybe tm ts route = local (handlerSubDataMaybe tm ts route) -- | A generic handler monad, which can have a different subsite and master--- site. This monad is a combination of 'ReaderT' for basic arguments, a--- 'WriterT' for headers and session, and an 'MEitherT' monad for handling--- special responses. It is declared as a newtype to make compiler errors more--- readable.-type GGHandler sub master = ReaderT (HandlerData sub master)--type GHandler sub master = GGHandler sub master (Iteratee ByteString IO)+-- site. We define a newtype for better error message.+newtype GHandler sub master a = GHandler+ { unGHandler :: HandlerData sub master -> ResourceT IO a+ } data GHState = GHState { ghsSession :: SessionMap@@ -279,7 +273,7 @@ , ghsHeaders :: Endo [Header] } -type SessionMap = Map.Map Text Text+type SessionMap = Map.Map Text S.ByteString -- | An extension of the basic WAI 'W.Application' datatype to provide extra -- features needed by Yesod. Users should never need to use this directly, as@@ -290,7 +284,7 @@ -> Request -> [ContentType] -> SessionMap- -> Iteratee ByteString IO YesodAppResult+ -> ResourceT IO YesodAppResult } data YesodAppResult@@ -301,7 +295,7 @@ HCContent H.Status ChooseRep | HCError ErrorResponse | HCSendFile ContentType FilePath (Maybe W.FilePart) -- FIXME replace FilePath with opaque type from system-filepath?- | HCRedirect RedirectType Text+ | HCRedirect H.Status Text | HCCreated Text | HCWai W.Response deriving Typeable@@ -310,11 +304,11 @@ show _ = "Cannot show a HandlerContents" instance Exception HandlerContents -getRequest :: Monad mo => GGHandler s m mo Request+getRequest :: GHandler s m Request getRequest = handlerRequest `liftM` ask -instance MonadIO monad => Failure ErrorResponse (GGHandler sub master monad) where- failure = liftIO . throwIO . HCError+hcError :: ErrorResponse -> GHandler sub master a+hcError = liftIO . throwIO . HCError runRequestBody :: GHandler s m RequestBodyContents runRequestBody = do@@ -327,44 +321,42 @@ put x { ghsRBC = Just rbc } return rbc -rbHelper :: W.Request -> Iteratee ByteString IO RequestBodyContents+rbHelper :: W.Request -> ResourceT IO RequestBodyContents rbHelper req =- (map fix1 *** map fix2) <$> iter+ (map fix1 *** map fix2) <$> (NWP.parseRequestBody NWP.lbsBackEnd req) where- iter = NWP.parseRequestBody NWP.lbsSink req fix1 = go *** go fix2 (x, NWP.FileInfo a b c) = (go x, FileInfo (go a) (go b) c) go = decodeUtf8With lenientDecode -- | Get the sub application argument.-getYesodSub :: Monad m => GGHandler sub master m sub+getYesodSub :: GHandler sub master sub getYesodSub = handlerSub `liftM` ask -- | Get the master site appliation argument.-getYesod :: Monad m => GGHandler sub master m master+getYesod :: GHandler sub master master getYesod = handlerMaster `liftM` ask -- | Get the URL rendering function.-getUrlRender :: Monad m => GGHandler sub master m (Route master -> Text)+getUrlRender :: GHandler sub master (Route master -> Text) getUrlRender = do x <- handlerRender `liftM` ask return $ flip x [] -- | The URL rendering function with query-string parameters. getUrlRenderParams- :: Monad m- => GGHandler sub master m (Route master -> [(Text, Text)] -> Text)+ :: GHandler sub master (Route master -> [(Text, Text)] -> Text) getUrlRenderParams = handlerRender `liftM` ask -- | Get the route requested by the user. If this is a 404 response- where the -- user requested an invalid route- this function will return 'Nothing'.-getCurrentRoute :: Monad m => GGHandler sub master m (Maybe (Route sub))+getCurrentRoute :: GHandler sub master (Maybe (Route sub)) getCurrentRoute = handlerRoute `liftM` ask -- | Get the function to promote a route for a subsite to a route for the -- master site.-getRouteToMaster :: Monad m => GGHandler sub master m (Route sub -> Route master)+getRouteToMaster :: GHandler sub master (Route sub -> Route master) getRouteToMaster = handlerToMaster `liftM` ask -- | Function used internally by Yesod in the process of converting a@@ -377,7 +369,7 @@ -> master -> sub -> YesodApp-runHandler handler mrender sroute tomr ma sa =+runHandler handler mrender sroute tomr master sub = YesodApp $ \eh rr cts initSession -> do let toErrorHandler e = case fromException e of@@ -392,14 +384,14 @@ } let hd = HandlerData { handlerRequest = rr- , handlerSub = sa- , handlerMaster = ma+ , handlerSub = sub+ , handlerMaster = master , handlerRoute = sroute , handlerRender = mrender , handlerToMaster = tomr , handlerState = istate }- contents' <- catchIter (fmap Right $ runReaderT handler hd)+ contents' <- catch (fmap Right $ unGHandler handler hd) (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id $ fromException e) state <- liftIO $ I.readIORef istate@@ -420,12 +412,12 @@ (ct, c) <- liftIO $ a cts return $ YARPlain status (appEndo headers []) ct c finalSession HCError e -> handleError e- HCRedirect rt loc -> do+ HCRedirect status loc -> do let hs = Header "Location" (encodeUtf8 loc) : appEndo headers [] return $ YARPlain- (getRedirectStatus rt) hs typePlain emptyContent+ status hs typePlain emptyContent finalSession- HCSendFile ct fp p -> catchIter+ HCSendFile ct fp p -> catch (sendFile' ct fp p) (handleError . toErrorHandler) HCCreated loc -> do@@ -449,22 +441,26 @@ session -- | Redirect to the given route.-redirect :: MonadIO mo => RedirectType -> Route master -> GGHandler sub master mo a-redirect rt url = redirectParams rt url []---- | Redirects to the given route with the associated query-string parameters.-redirectParams :: MonadIO mo- => RedirectType -> Route master -> [(Text, Text)]- -> GGHandler sub master mo a-redirectParams rt url params = do- r <- getUrlRenderParams- redirectString rt $ r url params+-- HTTP status code 303 for HTTP 1.1 clients and 302 for HTTP 1.0+-- This is the appropriate choice for a get-following-post+-- technique, which should be the usual use case.+--+-- If you want direct control of the final status code, or need a different+-- status code, please use 'redirectWith'.+redirect :: RedirectUrl master url => url -> GHandler sub master a+redirect url = do+ req <- waiRequest+ let status =+ if W.httpVersion req == H.http11+ then H.status303+ else H.status302+ redirectWith status url --- | Redirect to the given URL.-redirectString, redirectText :: MonadIO mo => RedirectType -> Text -> GGHandler sub master mo a-redirectText rt = liftIO . throwIO . HCRedirect rt-redirectString = redirectText-{-# DEPRECATED redirectString "Use redirectText instead" #-}+-- | Redirect to the given URL with the specified status code.+redirectWith :: RedirectUrl master url => H.Status -> url -> GHandler sub master a+redirectWith status url = do+ urlText <- toTextUrl url+ liftIO $ throwIO $ HCRedirect status urlText ultDestKey :: Text ultDestKey = "_ULT"@@ -473,38 +469,29 @@ -- -- An ultimate destination is stored in the user session and can be loaded -- later by 'redirectUltDest'.-setUltDest :: MonadIO mo => Route master -> GGHandler sub master mo ()-setUltDest dest = do- render <- getUrlRender- setUltDestString $ render dest---- | Same as 'setUltDest', but use the given string.-setUltDestText :: MonadIO mo => Text -> GGHandler sub master mo ()-setUltDestText = setSession ultDestKey--setUltDestString :: MonadIO mo => Text -> GGHandler sub master mo ()-setUltDestString = setSession ultDestKey-{-# DEPRECATED setUltDestString "Use setUltDestText instead" #-}+setUltDest :: RedirectUrl master url => url -> GHandler sub master ()+setUltDest url = do+ urlText <- toTextUrl url+ setSession ultDestKey urlText -- | Same as 'setUltDest', but uses the current page. -- -- If this is a 404 handler, there is no current page, and then this call does -- nothing.-setUltDest' :: MonadIO mo => GGHandler sub master mo ()-setUltDest' = do+setUltDestCurrent :: GHandler sub master ()+setUltDestCurrent = do route <- getCurrentRoute case route of Nothing -> return () Just r -> do tm <- getRouteToMaster gets' <- reqGetParams `liftM` handlerRequest `liftM` ask- render <- getUrlRenderParams- setUltDestString $ render (tm r) gets'+ setUltDest (tm r, gets') -- | Sets the ultimate destination to the referer request header, if present. -- -- This function will not overwrite an existing ultdest.-setUltDestReferer :: MonadIO mo => GGHandler sub master mo ()+setUltDestReferer :: GHandler sub master () setUltDestReferer = do mdest <- lookupSession ultDestKey maybe@@ -512,23 +499,25 @@ (const $ return ()) mdest where- setUltDestBS = setUltDestText . T.pack . S8.unpack+ setUltDestBS = setUltDest . T.pack . S8.unpack -- | Redirect to the ultimate destination in the user's session. Clear the -- value from the session. -- -- The ultimate destination is set with 'setUltDest'.-redirectUltDest :: MonadIO mo- => RedirectType- -> Route master -- ^ default destination if nothing in session- -> GGHandler sub master mo a-redirectUltDest rt def = do+--+-- This function uses 'redirect', and thus will perform a temporary redirect to+-- a GET request.+redirectUltDest :: RedirectUrl master url+ => url -- ^ default destination if nothing in session+ -> GHandler sub master a+redirectUltDest def = do mdest <- lookupSession ultDestKey deleteSession ultDestKey- maybe (redirect rt def) (redirectText rt) mdest+ maybe (redirect def) redirect mdest -- | Remove a previously set ultimate destination. See 'setUltDest'.-clearUltDest :: MonadIO mo => GGHandler sub master mo ()+clearUltDest :: GHandler sub master () clearUltDest = deleteSession ultDestKey msgKey :: Text@@ -537,13 +526,13 @@ -- | Sets a message in the user's session. -- -- See 'getMessage'.-setMessage :: MonadIO mo => Html -> GGHandler sub master mo ()+setMessage :: Html -> GHandler sub master () setMessage = setSession msgKey . T.concat . TL.toChunks . Text.Blaze.Renderer.Text.renderHtml -- | Sets a message in the user's session. -- -- See 'getMessage'.-setMessageI :: (RenderMessage y msg, MonadIO mo) => msg -> GGHandler sub y mo ()+setMessageI :: (RenderMessage y msg) => msg -> GHandler sub y () setMessageI msg = do mr <- getMessageRender setMessage $ toHtml $ mr msg@@ -552,7 +541,7 @@ -- variable. -- -- See 'setMessage'.-getMessage :: MonadIO mo => GGHandler sub master mo (Maybe Html)+getMessage :: GHandler sub master (Maybe Html) getMessage = do mmsg <- liftM (fmap preEscapedText) $ lookupSession msgKey deleteSession msgKey@@ -562,34 +551,33 @@ -- -- For some backends, this is more efficient than reading in the file to -- memory, since they can optimize file sending via a system call to sendfile.-sendFile :: MonadIO mo => ContentType -> FilePath -> GGHandler sub master mo a+sendFile :: ContentType -> FilePath -> GHandler sub master a sendFile ct fp = liftIO . throwIO $ HCSendFile ct fp Nothing -- | Same as 'sendFile', but only sends part of a file.-sendFilePart :: MonadIO mo- => ContentType+sendFilePart :: ContentType -> FilePath -> Integer -- ^ offset -> Integer -- ^ count- -> GGHandler sub master mo a+ -> GHandler sub master a sendFilePart ct fp off count = liftIO . throwIO $ HCSendFile ct fp $ Just $ W.FilePart off count -- | Bypass remaining handler code and output the given content with a 200 -- status code.-sendResponse :: (MonadIO mo, HasReps c) => c -> GGHandler sub master mo a+sendResponse :: HasReps c => c -> GHandler sub master a sendResponse = liftIO . throwIO . HCContent H.status200 . chooseRep -- | Bypass remaining handler code and output the given content with the given -- status code.-sendResponseStatus :: (MonadIO mo, HasReps c) => H.Status -> c -> GGHandler s m mo a+sendResponseStatus :: HasReps c => H.Status -> c -> GHandler s m a sendResponseStatus s = liftIO . throwIO . HCContent s . chooseRep -- | Send a 201 "Created" response with the given route as the Location -- response header.-sendResponseCreated :: MonadIO mo => Route m -> GGHandler s m mo a+sendResponseCreated :: Route m -> GHandler s m a sendResponseCreated url = do r <- getUrlRender liftIO . throwIO $ HCCreated $ r url@@ -599,105 +587,124 @@ -- that you have already specified. This function short-circuits. It should be -- considered only for very specific needs. If you are not sure if you need it, -- you don't.-sendWaiResponse :: MonadIO mo => W.Response -> GGHandler s m mo b+sendWaiResponse :: W.Response -> GHandler s m b sendWaiResponse = liftIO . throwIO . HCWai -- | Return a 404 not found page. Also denotes no handler available.-notFound :: Failure ErrorResponse m => m a-notFound = failure NotFound+notFound :: GHandler sub master a+notFound = hcError NotFound -- | Return a 405 method not supported page.-badMethod :: MonadIO mo => GGHandler s m mo a+badMethod :: GHandler sub master a badMethod = do w <- waiRequest- failure $ BadMethod $ W.requestMethod w+ hcError $ BadMethod $ W.requestMethod w -- | Return a 403 permission denied page.-permissionDenied :: Failure ErrorResponse m => Text -> m a-permissionDenied = failure . PermissionDenied+permissionDenied :: Text -> GHandler sub master a+permissionDenied = hcError . PermissionDenied -- | Return a 403 permission denied page.-permissionDeniedI :: (RenderMessage y msg, MonadIO mo) => msg -> GGHandler s y mo a+permissionDeniedI :: RenderMessage master msg => msg -> GHandler sub master a permissionDeniedI msg = do mr <- getMessageRender permissionDenied $ mr msg -- | Return a 400 invalid arguments page.-invalidArgs :: Failure ErrorResponse m => [Text] -> m a-invalidArgs = failure . InvalidArgs+invalidArgs :: [Text] -> GHandler sub master a+invalidArgs = hcError . InvalidArgs -- | Return a 400 invalid arguments page.-invalidArgsI :: (RenderMessage y msg, MonadIO mo) => [msg] -> GGHandler s y mo a+invalidArgsI :: RenderMessage y msg => [msg] -> GHandler s y a invalidArgsI msg = do mr <- getMessageRender invalidArgs $ map mr msg ------- Headers -- | Set the cookie on the client.-setCookie :: MonadIO mo- => Int -- ^ minutes to timeout- -> H.Ascii -- ^ key- -> H.Ascii -- ^ value- -> GGHandler sub master mo ()-setCookie a b = addHeader . AddCookie a b +setCookie :: SetCookie+ -> GHandler sub master ()+setCookie = addHeader . AddCookie++-- | Helper function for setCookieExpires value+getExpires :: Int -- ^ minutes+ -> IO UTCTime+getExpires m = do+ now <- liftIO getCurrentTime+ return $ fromIntegral (m * 60) `addUTCTime` now++ -- | Unset the cookie on the client.-deleteCookie :: MonadIO mo => H.Ascii -> GGHandler sub master mo ()-deleteCookie = addHeader . DeleteCookie+--+-- Note: although the value used for key and path is 'Text', you should only+-- use ASCII values to be HTTP compliant.+deleteCookie :: Text -- ^ key + -> Text -- ^ path+ -> GHandler sub master ()+deleteCookie a = addHeader . DeleteCookie (encodeUtf8 a) . encodeUtf8 + -- | Set the language in the user session. Will show up in 'languages' on the -- next request.-setLanguage :: MonadIO mo => Text -> GGHandler sub master mo ()+setLanguage :: Text -> GHandler sub master () setLanguage = setSession langKey -- | Set an arbitrary response header.-setHeader :: MonadIO mo- => CI H.Ascii -> H.Ascii -> GGHandler sub master mo ()-setHeader a = addHeader . Header a+--+-- Note that, while the data type used here is 'Text', you must provide only+-- ASCII value to be HTTP compliant.+setHeader :: Text -> Text -> GHandler sub master ()+setHeader a = addHeader . Header (encodeUtf8 a) . encodeUtf8 -- | Set the Cache-Control header to indicate this response should be cached -- for the given number of seconds.-cacheSeconds :: MonadIO mo => Int -> GGHandler s m mo ()-cacheSeconds i = setHeader "Cache-Control" $ S8.pack $ concat+cacheSeconds :: Int -> GHandler s m ()+cacheSeconds i = setHeader "Cache-Control" $ T.concat [ "max-age="- , show i+ , T.pack $ show i , ", public" ] -- | Set the Expires header to some date in 2037. In other words, this content -- is never (realistically) expired.-neverExpires :: MonadIO mo => GGHandler s m mo ()+neverExpires :: GHandler s m () neverExpires = setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT" -- | Set an Expires header in the past, meaning this content should not be -- cached.-alreadyExpired :: MonadIO mo => GGHandler s m mo ()+alreadyExpired :: GHandler s m () alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT" -- | Set an Expires header to the given date.-expiresAt :: MonadIO mo => UTCTime -> GGHandler s m mo ()-expiresAt = setHeader "Expires" . encodeUtf8 . formatRFC1123+expiresAt :: UTCTime -> GHandler s m ()+expiresAt = setHeader "Expires" . formatRFC1123 -- | Set a variable in the user's session. -- -- The session is handled by the clientsession package: it sets an encrypted -- and hashed cookie on the client. This ensures that all data is secure and -- not tampered with.-setSession :: MonadIO mo- => Text -- ^ key+setSession :: Text -- ^ key -> Text -- ^ value- -> GGHandler sub master mo ()-setSession k = modify . modSession . Map.insert k+ -> GHandler sub master ()+setSession k = setSessionBS k . encodeUtf8 +-- | Same as 'setSession', but uses binary data for the value.+setSessionBS :: Text+ -> S.ByteString+ -> GHandler sub master ()+setSessionBS k = modify . modSession . Map.insert k+ -- | Unsets a session variable. See 'setSession'.-deleteSession :: MonadIO mo => Text -> GGHandler sub master mo ()+deleteSession :: Text -> GHandler sub master () deleteSession = modify . modSession . Map.delete modSession :: (SessionMap -> SessionMap) -> GHState -> GHState modSession f x = x { ghsSession = f $ ghsSession x } -- | Internal use only, not to be confused with 'setHeader'.-addHeader :: MonadIO mo => Header -> GGHandler sub master mo ()+addHeader :: Header -> GHandler sub master () addHeader = tell . Endo . (:) getStatus :: ErrorResponse -> H.Status@@ -707,42 +714,56 @@ getStatus (PermissionDenied _) = H.status403 getStatus (BadMethod _) = H.status405 -getRedirectStatus :: RedirectType -> H.Status-getRedirectStatus RedirectPermanent = H.status301-getRedirectStatus RedirectTemporary = H.status302-getRedirectStatus RedirectSeeOther = H.status303+-- | Some value which can be turned into a URL for redirects.+class RedirectUrl master a where+ -- | Converts the value to the URL and a list of query-string parameters.+ toTextUrl :: a -> GHandler sub master Text --- | Different types of redirects.-data RedirectType = RedirectPermanent- | RedirectTemporary- | RedirectSeeOther- deriving (Show, Eq)+instance RedirectUrl master Text where+ toTextUrl = return -localNoCurrent :: Monad mo => GGHandler s m mo a -> GGHandler s m mo a+instance RedirectUrl master String where+ toTextUrl = toTextUrl . T.pack++instance RedirectUrl master (Route master) where+ toTextUrl u = do+ r <- getUrlRender+ return $ r u++instance t ~ Text => RedirectUrl master (Route master, [(t, t)]) where+ toTextUrl (u, ps) = do+ r <- getUrlRenderParams+ return $ r u ps++localNoCurrent :: GHandler s m a -> GHandler s m a localNoCurrent = local (\hd -> hd { handlerRoute = Nothing }) -- | Lookup for session data.-lookupSession :: MonadIO mo => Text -> GGHandler s m mo (Maybe Text)-lookupSession n = do+lookupSession :: Text -> GHandler s m (Maybe Text)+lookupSession = (fmap . fmap) (decodeUtf8With lenientDecode) . lookupSessionBS++-- | Lookup for session data in binary format.+lookupSessionBS :: Text -> GHandler s m (Maybe S.ByteString)+lookupSessionBS n = do m <- liftM ghsSession get return $ Map.lookup n m -- | Get all session variables.-getSession :: MonadIO mo => GGHandler s m mo SessionMap+getSession :: GHandler sub master SessionMap getSession = liftM ghsSession get handlerToYAR :: (HasReps a, HasReps b)- => m -- ^ master site foundation- -> s -- ^ sub site foundation- -> (Route s -> Route m)- -> (Route m -> [(Text, Text)] -> Text)- -> (ErrorResponse -> GHandler s m a)+ => master -- ^ master site foundation+ -> sub -- ^ sub site foundation+ -> (Route sub -> Route master)+ -> (Route master -> [(Text, Text)] -> Text) -- route renderer+ -> (ErrorResponse -> GHandler sub master a) -> Request- -> Maybe (Route s)+ -> Maybe (Route sub) -> SessionMap- -> GHandler s m b- -> Iteratee ByteString IO YesodAppResult+ -> GHandler sub master b+ -> ResourceT IO YesodAppResult handlerToYAR y s toMasterRoute render errorHandler rr murl sessionMap h = unYesodApp ya eh' rr types sessionMap where@@ -764,32 +785,13 @@ let hs' = maybe finalHeaders finalHeaders' mlen in W.ResponseBuilder s hs' b ContentFile fp p -> W.ResponseFile s finalHeaders fp p- ContentEnum e ->- W.ResponseEnumerator $ \iter -> run_ $ e $$ iter s finalHeaders+ ContentSource body -> W.ResponseSource s finalHeaders body where finalHeaders = renderHeaders hs ct sessionFinal finalHeaders' len = ("Content-Length", S8.pack $ show len) : finalHeaders- {-- getExpires m = fromIntegral (m * 60) `addUTCTime` now- sessionVal =- case key' of- Nothing -> B.empty- Just key'' -> encodeSession key'' exp' host- $ Map.toList- $ Map.insert nonceKey (reqNonce rr) sessionFinal- hs' =- case key' of- Nothing -> hs- Just _ -> AddCookie- (clientSessionDuration y)- sessionName- (bsToChars sessionVal)- : hs- hs'' = map (headerToPair getExpires) hs'- hs''' = ("Content-Type", charsToBs ct) : hs''- -} + httpAccept :: W.Request -> [ContentType] httpAccept = parseHttpAccept . fromMaybe mempty@@ -797,40 +799,28 @@ . W.requestHeaders -- | Convert Header to a key/value pair.-headerToPair :: S.ByteString -- ^ cookie path- -> (Int -> UTCTime) -- ^ minutes -> expiration time- -> Header+headerToPair :: Header -> (CI H.Ascii, H.Ascii)-headerToPair cp getExpires (AddCookie minutes key value) =- ("Set-Cookie", toByteString $ renderSetCookie $ SetCookie- { setCookieName = key- , setCookieValue = value- , setCookiePath = Just cp- , setCookieExpires =- if minutes == 0- then Nothing- else Just $ getExpires minutes- , setCookieDomain = Nothing- , setCookieHttpOnly = True- })-headerToPair cp _ (DeleteCookie key) =+headerToPair (AddCookie sc) =+ ("Set-Cookie", toByteString $ renderSetCookie $ sc)+headerToPair (DeleteCookie key path) = ( "Set-Cookie"- , key `mappend` "=; path=" `mappend` cp `mappend` "; expires=Thu, 01-Jan-1970 00:00:00 GMT"+ , S.concat+ [ key+ , "=; path="+ , path+ , "; expires=Thu, 01-Jan-1970 00:00:00 GMT"+ ] )-headerToPair _ _ (Header key value) = (key, value)+headerToPair (Header key value) = (CI.mk key, value) -- | Get a unique identifier.-newIdent :: MonadIO mo => GGHandler sub master mo String -- FIXME use Text+newIdent :: GHandler sub master Text newIdent = do x <- get let i' = ghsIdent x + 1 put x { ghsIdent = i' }- return $ 'h' : show i'--liftIOHandler :: MonadIO mo- => GGHandler sub master IO a- -> GGHandler sub master mo a-liftIOHandler (ReaderT m) = ReaderT $ \r -> liftIO $ m r+ return $ T.pack $ 'h' : show i' -- | Redirect to a POST resource. --@@ -838,8 +828,10 @@ -- POST form, and some Javascript to automatically submit the form. This can be -- useful when you need to post a plain link somewhere that needs to cause -- changes on the server.-redirectToPost :: MonadIO mo => Route master -> GGHandler sub master mo a-redirectToPost dest = hamletToRepHtml+redirectToPost :: RedirectUrl master url => url -> GHandler sub master a+redirectToPost url = do+ urlText <- toTextUrl url+ hamletToRepHtml #if GHC7 [hamlet| #else@@ -851,7 +843,7 @@ <head> <title>Redirecting... <body onload="document.getElementById('form').submit()">- <form id="form" method="post" action="@{dest}">+ <form id="form" method="post" action=#{urlText}> <noscript> <p>Javascript has been disabled; please click on the button below to be redirected. <input type="submit" value="Continue">@@ -859,36 +851,83 @@ -- | Converts the given Hamlet template into 'Content', which can be used in a -- Yesod 'Response'.-hamletToContent :: Monad mo- => HtmlUrl (Route master) -> GGHandler sub master mo Content+hamletToContent :: HtmlUrl (Route master) -> GHandler sub master Content hamletToContent h = do render <- getUrlRenderParams return $ toContent $ h render -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.-hamletToRepHtml :: Monad mo- => HtmlUrl (Route master) -> GGHandler sub master mo RepHtml+hamletToRepHtml :: HtmlUrl (Route master) -> GHandler sub master RepHtml hamletToRepHtml = liftM RepHtml . hamletToContent -- | Get the request\'s 'W.Request' value.-waiRequest :: Monad mo => GGHandler sub master mo W.Request+waiRequest :: GHandler sub master W.Request waiRequest = reqWaiRequest `liftM` getRequest -getMessageRender :: (Monad mo, RenderMessage master message) => GGHandler s master mo (message -> Text)+getMessageRender :: RenderMessage master message => GHandler s master (message -> Text) getMessageRender = do m <- getYesod l <- reqLangs `liftM` getRequest return $ renderMessage m l -cacheLookup :: MonadIO mo => CacheKey a -> GGHandler sub master mo (Maybe a)+cacheLookup :: CacheKey a -> GHandler sub master (Maybe a) cacheLookup k = do gs <- get return $ Cache.lookup k $ ghsCache gs -cacheInsert :: MonadIO mo => CacheKey a -> a -> GGHandler sub master mo ()+cacheInsert :: CacheKey a -> a -> GHandler sub master () cacheInsert k v = modify $ \gs -> gs { ghsCache = Cache.insert k v $ ghsCache gs } -cacheDelete :: MonadIO mo => CacheKey a -> GGHandler sub master mo ()+cacheDelete :: CacheKey a -> GHandler sub master () cacheDelete k = modify $ \gs -> gs { ghsCache = Cache.delete k $ ghsCache gs }++ask :: GHandler sub master (HandlerData sub master)+ask = GHandler return++local :: (HandlerData sub' master' -> HandlerData sub master)+ -> GHandler sub master a+ -> GHandler sub' master' a+local f (GHandler x) = GHandler $ \r -> x $ f r++-- | The standard @MonadTrans@ class only allows lifting for monad+-- transformers. While @GHandler@ and @GWidget@ should allow lifting, their+-- types do not express that they actually are transformers. This replacement+-- class accounts for this.+class MonadLift base m | m -> base where+ lift :: base a -> m a+instance (Monad m, MonadTrans t) => MonadLift m (t m) where+ lift = Control.Monad.Trans.Class.lift+instance MonadLift (ResourceT IO) (GHandler sub master) where+ lift = GHandler . const++-- Instances for GHandler+instance Functor (GHandler sub master) where+ fmap f (GHandler x) = GHandler $ \r -> fmap f (x r)+instance Applicative (GHandler sub master) where+ pure = GHandler . const . pure+ GHandler f <*> GHandler x = GHandler $ \r -> f r <*> x r+instance Monad (GHandler sub master) where+ return = pure+ GHandler x >>= f = GHandler $ \r -> x r >>= \x' -> unGHandler (f x') r+instance MonadIO (GHandler sub master) where+ liftIO = GHandler . const . lift+instance MonadBase IO (GHandler sub master) where+ liftBase = GHandler . const . lift+instance MonadBaseControl IO (GHandler sub master) where+ data StM (GHandler sub master) a = StH (StM (ResourceT IO) a)+ liftBaseWith f = GHandler $ \reader ->+ liftBaseWith $ \runInBase ->+ f $ liftM StH . runInBase . (\(GHandler r) -> r reader)+ restoreM (StH base) = GHandler $ const $ restoreM base++instance Resource (GHandler sub master) where+ type Base (GHandler sub master) = IO+ resourceLiftBase = liftIO+ resourceBracket_ a b c = control $ \run -> resourceBracket_ a b (run c)+instance ResourceUnsafeIO (GHandler sub master) where+ unsafeFromIO = liftIO+instance ResourceThrow (GHandler sub master) where+ resourceThrow = liftIO . throwIO+instance ResourceIO (GHandler sub master)
Yesod/Internal.hs view
@@ -39,11 +39,11 @@ import Control.Exception (Exception) import qualified Network.HTTP.Types as H-import qualified Network.HTTP.Types as A-import Data.CaseInsensitive (CI) import Data.String (IsString) import qualified Data.Map as Map import Data.Text.Lazy.Builder (Builder)+import Network.HTTP.Types (Ascii)+import Web.Cookie (SetCookie (..)) #if GHC7 #define HAMLET hamlet@@ -65,9 +65,9 @@ ----- header stuff -- | Headers to be added to a 'Result'. data Header =- AddCookie Int A.Ascii A.Ascii- | DeleteCookie A.Ascii- | Header (CI A.Ascii) A.Ascii+ AddCookie SetCookie+ | DeleteCookie Ascii Ascii+ | Header Ascii Ascii deriving (Eq, Show) langKey :: IsString a => a
Yesod/Internal/Core.hs view
@@ -28,11 +28,15 @@ -- * Misc , yesodVersion , yesodRender+ , resolveApproot+ , Approot (..) ) where import Yesod.Content-import Yesod.Handler+import Yesod.Handler hiding (lift, getExpires) +import Yesod.Routes.Class+ import Control.Arrow ((***)) import Control.Monad (forM) import Yesod.Widget@@ -46,7 +50,6 @@ import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.Monoid-import Control.Monad.Trans.Writer (runWriterT) import Text.Hamlet import Text.Julius import Text.Blaze ((!), customAttribute, textTag, toValue, unsafeLazyByteString)@@ -67,6 +70,7 @@ import Blaze.ByteString.Builder.Char.Utf8 (fromText) import Data.List (foldl') import qualified Network.HTTP.Types as H+import Web.Cookie (SetCookie (..)) import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.IO import qualified Data.Text.Lazy.Builder as TB@@ -75,6 +79,7 @@ import Data.Aeson (Value (Array, String)) import Data.Aeson.Encode (encode) import qualified Data.Vector as Vector+import Network.Wai.Middleware.Gzip (GzipSettings, def) -- mega repo can't access this #ifndef MEGA@@ -93,42 +98,61 @@ #define HAMLET $hamlet #endif -class Eq u => RenderRoute u where- renderRoute :: u -> ([Text], [(Text, Text)])- -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly.-class YesodDispatch a master where+class YesodDispatch sub master where yesodDispatch :: Yesod master- => a+ => master+ -> sub+ -> (Route sub -> Route master)+ -> (Maybe CS.Key -> W.Application) -- ^ 404 handler+ -> (Route sub -> Maybe CS.Key -> W.Application) -- ^ 405 handler+ -> Text -- ^ request method+ -> [Text] -- ^ pieces -> Maybe CS.Key- -> [Text]- -> master- -> (Route a -> Route master)- -> Maybe W.Application+ -> W.Application yesodRunner :: Yesod master- => a+ => GHandler sub master ChooseRep -> master- -> (Route a -> Route master)- -> Maybe CS.Key -> Maybe (Route a) -> GHandler a master ChooseRep -> W.Application+ -> sub+ -> Maybe (Route sub)+ -> (Route sub -> Route master)+ -> Maybe CS.Key+ -> W.Application yesodRunner = defaultYesodRunner --- | Define settings for a Yesod applications. The only required setting is--- 'approot'; other than that, there are intelligent defaults.-class RenderRoute (Route a) => Yesod a where+-- | How to determine the root of the application for constructing URLs.+--+-- Note that future versions of Yesod may add new constructors without bumping+-- the major version number. As a result, you should /not/ pattern match on+-- @Approot@ values.+data Approot master = ApprootRelative -- ^ No application root.+ | ApprootStatic Text+ | ApprootMaster (master -> Text)+ | ApprootRequest (master -> W.Request -> Text)++type ResolvedApproot = Text++-- | Define settings for a Yesod applications. All methods have intelligent+-- defaults, and therefore no implementation is required.+class RenderRoute a => Yesod a where -- | An absolute URL to the root of the application. Do not include -- trailing slash. --- -- If you want to be lazy, you can supply an empty string under the- -- following conditions:+ -- Default value: 'ApprootRelative'. This is valid under the following+ -- conditions: -- -- * Your application is served from the root of the domain. -- -- * You do not use any features that require absolute URLs, such as Atom -- feeds and XML sitemaps.- approot :: a -> Text+ --+ -- If this is not true, you should override with a different+ -- implementation.+ approot :: Approot a+ approot = ApprootRelative -- | The encryption key to be used for encrypting client sessions. -- Returning 'Nothing' disables sessions.@@ -247,10 +271,16 @@ -> GHandler sub a (Maybe (Either Text (Route a, [(Text, Text)]))) addStaticContent _ _ _ = return Nothing + {- Temporarily disabled until we have a better interface. -- | Whether or not to tie a session to a specific IP address. Defaults to- -- 'True'.+ -- 'False'.+ --+ -- Note: This setting has two known problems: it does not work correctly+ -- when behind a reverse proxy (including load balancers), and it may not+ -- function correctly if the user is behind a proxy. sessionIpAddress :: a -> Bool- sessionIpAddress _ = True+ sessionIpAddress _ = False+ -} -- | The path value to set for cookies. By default, uses \"\/\", meaning -- cookies will be sent to every page on the current domain.@@ -267,21 +297,29 @@ -> LogLevel -> Text -- ^ message -> IO ()- messageLogger _ loc level msg =- formatLogMessage loc level msg >>=- Data.Text.Lazy.IO.putStrLn+ messageLogger a loc level msg =+ if level < logLevel a+ then return ()+ else+ formatLogMessage loc level msg >>=+ Data.Text.Lazy.IO.putStrLn - -- | Apply gzip compression to files. Default is false.- gzipCompressFiles :: a -> Bool- gzipCompressFiles _ = False+ -- | The logging level in place for this application. Any messages below+ -- this level will simply be ignored.+ logLevel :: a -> LogLevel+ logLevel _ = LevelInfo + -- | GZIP settings.+ gzipSettings :: a -> GzipSettings+ gzipSettings _ = def+ -- | Location of yepnope.js, if any. If one is provided, then all -- Javascript files will be loaded asynchronously. yepnopeJs :: a -> Maybe (Either Text (Route a)) yepnopeJs _ = Nothing -messageLoggerHandler :: (Yesod m, MonadIO mo)- => Loc -> LogLevel -> Text -> GGHandler s m mo ()+messageLoggerHandler :: Yesod m+ => Loc -> LogLevel -> Text -> GHandler s m () messageLoggerHandler loc level msg = do y <- getYesod liftIO $ messageLogger y loc level msg@@ -323,15 +361,15 @@ char = show . snd . loc_start defaultYesodRunner :: Yesod master- => a+ => GHandler sub master ChooseRep -> master- -> (Route a -> Route master)+ -> sub+ -> Maybe (Route sub)+ -> (Route sub -> Route master) -> Maybe CS.Key- -> Maybe (Route a)- -> GHandler a master ChooseRep -> W.Application-defaultYesodRunner _ m toMaster _ murl _ req- | maximumContentLength m (fmap toMaster murl) < len =+defaultYesodRunner _ master _ murl toMaster _ req+ | maximumContentLength master (fmap toMaster murl) < len = return $ W.responseLBS (H.Status 413 "Too Large") [("Content-Type", "text/plain")]@@ -342,12 +380,12 @@ case reads $ S8.unpack s of [] -> Nothing (x, _):_ -> Just x-defaultYesodRunner s master toMasterRoute mkey murl handler req = do+defaultYesodRunner handler master sub murl toMasterRoute mkey req = do now <- {-# SCC "getCurrentTime" #-} liftIO getCurrentTime let getExpires m = {-# SCC "getExpires" #-} fromIntegral (m * 60) `addUTCTime` now let exp' = {-# SCC "exp'" #-} getExpires $ clientSessionDuration master- let rh = {-# SCC "rh" #-} takeWhile (/= ':') $ show $ W.remoteHost req- let host = if sessionIpAddress master then S8.pack rh else ""+ --let rh = {-# SCC "rh" #-} takeWhile (/= ':') $ show $ W.remoteHost req+ let host = "" -- FIXME if sessionIpAddress master then S8.pack rh else "" let session' = {-# SCC "session'" #-} case mkey of Nothing -> []@@ -369,13 +407,14 @@ Nothing -> permissionDenied "Authentication required" Just url' -> do- setUltDest'- redirect RedirectTemporary url'+ setUltDestCurrent+ redirect url' Unauthorized s' -> permissionDenied s' handler let sessionMap = Map.fromList $ filter (\(x, _) -> x /= nonceKey) session'- yar <- handlerToYAR master s toMasterRoute (yesodRender master) errorHandler rr murl sessionMap h+ let ra = resolveApproot master req+ yar <- handlerToYAR master sub toMasterRoute (yesodRender master ra) errorHandler rr murl sessionMap h let mnonce = reqNonce rr -- FIXME should we be caching this IV value and reusing it for efficiency? iv <- {-# SCC "iv" #-} maybe (return $ error "Should not be used") (const $ liftIO CS.randomIV) mkey@@ -389,17 +428,21 @@ (Just key, Just nonce) -> encodeSession key iv exp' host $ Map.toList- $ Map.insert nonceKey nonce sm+ $ Map.insert nonceKey (TE.encodeUtf8 nonce) sm _ -> mempty hs' = case mkey of Nothing -> hs- Just _ -> AddCookie- (clientSessionDuration master)- sessionName- sessionVal+ Just _ -> AddCookie def+ { setCookieName = sessionName+ , setCookieValue = sessionVal+ , setCookiePath = Just (cookiePath master)+ , setCookieExpires = Just $ getExpires (clientSessionDuration master)+ , setCookieDomain = Nothing+ , setCookieHttpOnly = True+ } : hs- hs'' = map (headerToPair (cookiePath master) getExpires) hs'+ hs'' = map headerToPair hs' hs''' = ("Content-Type", ct) : hs'' data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text@@ -499,12 +542,12 @@ widgetToPageContent :: (Eq (Route master), Yesod master) => GWidget sub master () -> GHandler sub master (PageContent (Route master))-widgetToPageContent (GWidget w) = do+widgetToPageContent w = do master <- getYesod- ((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- runWriterT w+ ((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- unGWidget w let title = maybe mempty unTitle mTitle- let scripts = runUniqueList scripts'- let stylesheets = runUniqueList stylesheets'+ scripts = runUniqueList scripts'+ stylesheets = runUniqueList stylesheets' render <- getUrlRenderParams let renderLoc x =@@ -528,22 +571,11 @@ $ encodeUtf8 $ renderJavascriptUrl render s return $ renderLoc x - let addAttr x (y, z) = x ! customAttribute (textTag y) (toValue z)- let renderLoc' render' (Local url) = render' url []- renderLoc' _ (Remote s) = s- let mkScriptTag (Script loc attrs) render' =- foldl' addAttr TBH.script (("src", renderLoc' render' loc) : attrs) $ return ()- let mkLinkTag (Stylesheet loc attrs) render' =- foldl' addAttr TBH.link- ( ("rel", "stylesheet")- : ("href", renderLoc' render' loc)- : attrs- )- let left (Left x) = Just x- left _ = Nothing- right (Right x) = Just x- right _ = Nothing- let head'' = [HAMLET|+ -- modernizr should be at the end of the <head> http://www.modernizr.com/docs/#installing+ -- the asynchronous loader means your page doesn't have to wait for all the js to load+ let (mcomplete, ynscripts) = ynHelper render scripts jscript jsLoc+ headAll = [HAMLET|+\^{head'} $forall s <- stylesheets ^{mkLinkTag s} $forall s <- css@@ -557,20 +589,6 @@ <style media=#{media}>#{content} $nothing <style>#{content}-$maybe _ <- yepnopeJs master-$nothing- $forall s <- scripts- ^{mkScriptTag s}- $maybe j <- jscript- $maybe s <- jsLoc- <script src="#{s}">- $nothing- <script>^{jelper j}-\^{head'}-|]- let (mcomplete, ynscripts) = ynHelper render scripts jscript jsLoc- let bodyYN = [HAMLET|-^{body} $maybe eyn <- yepnopeJs master $maybe yn <- left eyn <script src=#{yn}>@@ -580,9 +598,35 @@ <script>yepnope({load:#{ynscripts},complete:function(){^{complete}}}) $nothing <script>yepnope({load:#{ynscripts}})+$nothing+ $forall s <- scripts+ ^{mkScriptTag s}+ $maybe j <- jscript+ $maybe s <- jsLoc+ <script src="#{s}">+ $nothing+ <script>^{jelper j} |]- return $ PageContent title head'' bodyYN+ return $ PageContent title headAll body+ where+ left (Left x) = Just x+ left _ = Nothing+ right (Right x) = Just x+ right _ = Nothing + renderLoc' render' (Local url) = render' url []+ renderLoc' _ (Remote s) = s++ addAttr x (y, z) = x ! customAttribute (textTag y) (toValue z)+ mkScriptTag (Script loc attrs) render' =+ foldl' addAttr TBH.script (("src", renderLoc' render' loc) : attrs) $ return ()+ mkLinkTag (Stylesheet loc attrs) render' =+ foldl' addAttr TBH.link+ ( ("rel", "stylesheet")+ : ("href", renderLoc' render' loc)+ : attrs+ )+ ynHelper :: (url -> [x] -> Text) -> [Script (url)] -> Maybe (JavascriptUrl (url))@@ -608,14 +652,23 @@ yesodRender :: Yesod y => y+ -> ResolvedApproot -> Route y- -> [(Text, Text)]+ -> [(Text, Text)] -- ^ url query string -> Text-yesodRender y u qs =+yesodRender y ar url params = TE.decodeUtf8 $ toByteString $ fromMaybe- (joinPath y (approot y) ps- $ qs ++ qs')- (urlRenderOverride y u)+ (joinPath y ar ps+ $ params ++ params')+ (urlRenderOverride y url) where- (ps, qs') = renderRoute u+ (ps, params') = renderRoute url++resolveApproot :: Yesod master => master -> W.Request -> ResolvedApproot+resolveApproot master req =+ case approot of+ ApprootRelative -> ""+ ApprootStatic t -> t+ ApprootMaster f -> f master+ ApprootRequest f -> f master req
− Yesod/Internal/Dispatch.hs
@@ -1,322 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE OverloadedStrings #-}--- | A bunch of Template Haskell used in the Yesod.Dispatch module.-module Yesod.Internal.Dispatch- ( mkYesodDispatch'- ) where--import Prelude hiding (exp)-import Language.Haskell.TH.Syntax-import Web.PathPieces-import Yesod.Internal.RouteParsing-import Control.Monad (foldM)-import Yesod.Handler (badMethod)-import Yesod.Content (chooseRep)-import qualified Network.Wai as W-import Yesod.Internal.Core (yesodRunner, yesodDispatch)-import Data.List (foldl')-import Data.Char (toLower)-import qualified Data.ByteString as S-import Yesod.Internal.Core (Yesod (joinPath, approot, cleanPath))-import Network.HTTP.Types (status301)-import Data.Text (Text)-import Data.Monoid (mappend)-import qualified Blaze.ByteString.Builder-import qualified Data.ByteString.Char8 as S8-import qualified Data.Text--{-|--Alright, let's explain how routing works. We want to take a [String] and found-out which route it applies to. For static pieces, we need to ensure an exact-match against the segment. For a single or multi piece, we need to check the-result of fromSinglePiece/fromMultiPiece, respectively.--We want to create a tree of case statements basically resembling:--case testRoute1 of- Just app -> Just app- Nothing ->- case testRoute2 of- Just app -> Just app- Nothing ->- case testRoute3 of- Just app -> Just app- Nothing -> Nothing--Each testRoute* will look something like this (example of parsing a route /name/#String/age/#Int):--case segments of- "name" : as ->- case as of- [] -> Nothing- b:bs ->- case fromSinglePiece b of- Left _ -> Nothing- Right name ->- case bs of- "age":cs ->- case cs of- [] -> Nothing- d:ds ->- case fromSinglePiece d of- Left _ -> Nothing- Right age ->- case ds of- [] -> Just $ yesodRunner (PersonR name age) (getPersonR name age)...- _ -> Nothing- _ -> Nothing- _ -> Nothing--Obviously we would never want to write code by hand like this, but generating it is not too bad.--This function generates a clause for the yesodDispatch function based on a set of routes.--NOTE: We deal with subsites first; if none of those match, we try to apply-cleanPath. If that indicates a redirect, we perform it. Otherwise, we match-local routes.---}--sendRedirect :: Yesod master => master -> [Text] -> W.Application-sendRedirect y segments' env =- return $ W.responseLBS status301- [ ("Content-Type", "text/plain")- , ("Location", Blaze.ByteString.Builder.toByteString dest')- ] "Redirecting"- where- dest = joinPath y (approot y) segments' []- dest' =- if S.null (W.rawQueryString env)- then dest- else (dest `mappend`- Blaze.ByteString.Builder.fromByteString (W.rawQueryString env))--mkYesodDispatch' :: [((String, Pieces), Maybe String)]- -> [((String, Pieces), Maybe String)]- -> Q Clause-mkYesodDispatch' resSub resLoc = do- sub <- newName "sub"- master <- newName "master"- mkey <- newName "mkey"- segments <- newName "segments"- segments' <- newName "segmentsClean"- toMasterRoute <- newName "toMasterRoute"- nothing <- [|Nothing|]- bodyLoc <- foldM (go master (VarE sub) (VarE toMasterRoute) mkey segments') nothing resLoc- cp <- [|cleanPath|]- sr <- [|sendRedirect|]- just <- [|Just|]- let bodyLoc' =- CaseE (cp `AppE` VarE master `AppE` VarE segments)- [ Match (ConP (mkName "Left") [VarP segments'])- (NormalB $ just `AppE`- (sr `AppE` VarE master `AppE` VarE segments'))- []- , Match (ConP (mkName "Right") [VarP segments'])- (NormalB bodyLoc)- []- ]- body <- foldM (go master (VarE sub) (VarE toMasterRoute) mkey segments) bodyLoc' resSub- return $ Clause- [VarP sub, VarP mkey, VarP segments, VarP master, VarP toMasterRoute]- (NormalB body)- []- where- go master sub toMasterRoute mkey segments onFail ((constr, SubSite { ssPieces = pieces }), Just toSub) = do- test <- mkSubsiteExp segments pieces id (master, sub, toMasterRoute, mkey, constr, VarE $ mkName toSub)- app <- newName "app"- return $ CaseE test- [ Match (ConP (mkName "Nothing") []) (NormalB onFail) []- , Match (ConP (mkName "Just") [VarP app]) (NormalB $ VarE app) []- ]- go master sub toMasterRoute mkey segments onFail ((constr, Simple pieces methods), Nothing) = do- test <- mkSimpleExp (VarE segments) pieces id (master, sub, toMasterRoute, mkey, constr, methods)- just <- [|Just|]- app <- newName "app"- return $ CaseE test- [ Match (ConP (mkName "Nothing") []) (NormalB onFail) []- , Match (ConP (mkName "Just") [VarP app]) (NormalB $ just `AppE` VarE app) []- ]- go _ _ _ _ _ _ _ = error "Invalid combination"--mkSimpleExp :: Exp -- ^ segments- -> [Piece]- -> ([Exp] -> [Exp]) -- ^ variables already parsed- -> (Name, Exp, Exp, Name, String, [String]) -- ^ master, sub, toMasterRoute, mkey, constructor, methods- -> Q Exp-mkSimpleExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, methods) = do- just <- [|Just|]- nothing <- [|Nothing|]- onSuccess <- newName "onSuccess"- req <- newName "req"- badMethod' <- [|badMethod|]- rm <- [|S8.unpack . W.requestMethod|]- let caseExp = rm `AppE` VarE req- yr <- [|yesodRunner|]- cr <- [|fmap chooseRep|]- eq <- [|(==)|]- let url = foldl' AppE (ConE $ mkName constr) $ frontVars []- let runHandlerVars h = runHandler' $ cr `AppE` foldl' AppE (VarE $ mkName h) (frontVars [])- runHandler' h = yr `AppE` sub- `AppE` VarE master- `AppE` toMasterRoute- `AppE` VarE mkey- `AppE` (just `AppE` url)- `AppE` h- `AppE` VarE req- let match :: String -> Q Match- match m = do- x <- newName "x"- return $ Match- (VarP x)- (GuardedB- [ ( NormalG $ InfixE (Just $ VarE x) eq (Just $ LitE $ StringL m) -- FIXME need to pack, right?- , runHandlerVars $ map toLower m ++ constr- )- ])- []- clauses <-- case methods of- [] -> return [Clause [VarP req] (NormalB $ runHandlerVars $ "handle" ++ constr) []]- _ -> do- matches <- mapM match methods- return [Clause [VarP req] (NormalB $ CaseE caseExp $ matches ++- [Match WildP (NormalB $ runHandler' badMethod') []]) []]- let exp = CaseE segments- [ Match- (ConP (mkName "[]") [])- (NormalB $ just `AppE` VarE onSuccess)- [FunD onSuccess clauses]- , Match- WildP- (NormalB nothing)- []- ]- return exp-mkSimpleExp segments (StaticPiece s:pieces) frontVars x = do- srest <- newName "segments"- innerExp <- mkSimpleExp (VarE srest) pieces frontVars x- nothing <- [|Nothing|]- y <- newName "y"- pack <- [|Data.Text.pack|]- eq <- [|(==)|]- let exp = CaseE segments- [ Match- (InfixP (VarP y) (mkName ":") (VarP srest))- (GuardedB- [ ( NormalG $ InfixE (Just $ VarE y) eq (Just $ pack `AppE` (LitE $ StringL s))- , innerExp- )- ])- []- , Match WildP (NormalB nothing) []- ]- return exp-mkSimpleExp segments (SinglePiece _:pieces) frontVars x = do- srest <- newName "segments"- next' <- newName "next'"- innerExp <- mkSimpleExp (VarE srest) pieces (frontVars . (:) (VarE next')) x- nothing <- [|Nothing|]- next <- newName "next"- fsp <- [|fromSinglePiece|]- let exp' = CaseE (fsp `AppE` VarE next)- [ Match- (ConP (mkName "Nothing") [])- (NormalB nothing)- []- , Match- (ConP (mkName "Just") [VarP next'])- (NormalB innerExp)- []- ]- let exp = CaseE segments- [ Match- (InfixP (VarP next) (mkName ":") (VarP srest))- (NormalB exp')- []- , Match WildP (NormalB nothing) []- ]- return exp-mkSimpleExp segments [MultiPiece _] frontVars x = do- next' <- newName "next'"- srest <- [|[]|]- innerExp <- mkSimpleExp srest [] (frontVars . (:) (VarE next')) x- nothing <- [|Nothing|]- fmp <- [|fromMultiPiece|]- let exp = CaseE (fmp `AppE` segments)- [ Match- (ConP (mkName "Nothing") [])- (NormalB nothing)- []- , Match- (ConP (mkName "Just") [VarP next'])- (NormalB innerExp)- []- ]- return exp-mkSimpleExp _ (MultiPiece _:_) _ _ = error "MultiPiece must be last piece"--mkSubsiteExp :: Name -- ^ segments- -> [Piece]- -> ([Exp] -> [Exp]) -- ^ variables already parsed- -> (Name, Exp, Exp, Name, String, Exp) -- ^ master, sub, toMasterRoute, mkey, constructor, toSub- -> Q Exp-mkSubsiteExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, toSub) = do- yd <- [|yesodDispatch|]- dot <- [|(.)|]- let con = InfixE (Just toMasterRoute) dot $ Just $ foldl' AppE (ConE $ mkName constr) $ frontVars []- -- proper handling for sub-subsites- let sub' = foldl' AppE (toSub `AppE` sub) $ frontVars []- let app = yd `AppE` sub'- `AppE` VarE mkey- `AppE` VarE segments- `AppE` VarE master- `AppE` con- just <- [|Just|]- return $ just `AppE` app-mkSubsiteExp _ (MultiPiece _:_) _ _ = error "Subsites cannot have MultiPiece"-mkSubsiteExp segments (StaticPiece s:pieces) frontVars x = do- srest <- newName "segments"- innerExp <- mkSubsiteExp srest pieces frontVars x- nothing <- [|Nothing|]- y <- newName "y"- pack <- [|Data.Text.pack|]- eq <- [|(==)|]- let exp = CaseE (VarE segments)- [ Match- (InfixP (VarP y) (mkName ":") (VarP srest))- (GuardedB- [ ( NormalG $ InfixE (Just $ VarE y) eq (Just $ pack `AppE` (LitE $ StringL s))- , innerExp- )- ])- []- , Match WildP (NormalB nothing) []- ]- return exp-mkSubsiteExp segments (SinglePiece _:pieces) frontVars x = do- srest <- newName "segments"- next' <- newName "next'"- innerExp <- mkSubsiteExp srest pieces (frontVars . (:) (VarE next')) x- nothing <- [|Nothing|]- next <- newName "next"- fsp <- [|fromSinglePiece|]- let exp' = CaseE (fsp `AppE` VarE next)- [ Match- (ConP (mkName "Nothing") [])- (NormalB nothing)- []- , Match- (ConP (mkName "Just") [VarP next'])- (NormalB innerExp)- []- ]- let exp = CaseE (VarE segments)- [ Match- (InfixP (VarP next) (mkName ":") (VarP srest))- (NormalB exp')- []- , Match WildP (NormalB nothing) []- ]- return exp
Yesod/Internal/Request.hs view
@@ -17,12 +17,17 @@ import qualified Network.Wai as W import System.Random (RandomGen, newStdGen, randomRs) import Web.Cookie (parseCookiesText)+import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 import Data.Text (Text, pack) import Network.HTTP.Types (queryToQueryText) import Control.Monad (join) import Data.Maybe (fromMaybe, catMaybes) import qualified Data.ByteString.Lazy as L+import qualified Data.Set as Set+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode) -- | The parsed request information. data Request = Request@@ -36,18 +41,18 @@ } parseWaiRequest :: W.Request- -> [(Text, Text)] -- ^ session+ -> [(Text, ByteString)] -- ^ session -> Maybe a -> IO Request parseWaiRequest env session' key' = parseWaiRequest' env session' key' <$> newStdGen parseWaiRequest' :: RandomGen g => W.Request- -> [(Text, Text)] -- ^ session+ -> [(Text, ByteString)] -- ^ session -> Maybe a -> g -> Request-parseWaiRequest' env session' key' gen = Request gets'' cookies' env langs' nonce+parseWaiRequest' env session' key' gen = Request gets'' cookies' env langs'' nonce where gets' = queryToQueryText $ W.queryString env gets'' = map (second $ fromMaybe "") gets'@@ -55,19 +60,37 @@ cookies' = maybe [] parseCookiesText reqCookie acceptLang = lookup "Accept-Language" $ W.requestHeaders env langs = map (pack . S8.unpack) $ maybe [] NWP.parseHttpAccept acceptLang++ lookupText k = fmap (decodeUtf8With lenientDecode) . lookup k+ -- The language preferences are prioritized as follows: langs' = catMaybes [ join $ lookup langKey gets' -- Query _LANG , lookup langKey cookies' -- Cookie _LANG- , lookup langKey session' -- Session _LANG+ , lookupText langKey session' -- Session _LANG ] ++ langs -- Accept-Language(s)++ -- Github issue #195. We want to add an extra two-letter version of any+ -- language in the list.+ langs'' = addTwoLetters (id, Set.empty) langs'+ -- If sessions are disabled nonces should not be used (any -- nonceKey present in the session is ignored). If sessions -- are enabled and a session has no nonceKey a new one is -- generated. nonce = case (key', lookup nonceKey session') of (Nothing, _) -> Nothing- (_, Just x) -> Just x+ (_, Just x) -> Just $ decodeUtf8With lenientDecode x _ -> Just $ pack $ randomString 10 gen++addTwoLetters :: ([Text] -> [Text], Set.Set Text) -> [Text] -> [Text]+addTwoLetters (toAdd, exist) [] =+ filter (flip Set.notMember exist) $ toAdd []+addTwoLetters (toAdd, exist) (l:ls) =+ l : addTwoLetters (toAdd', exist') ls+ where+ (toAdd', exist')+ | T.length l > 2 = (toAdd . (T.take 2 l:), exist)+ | otherwise = (toAdd, Set.insert l exist) -- | Generate a random String of alphanumerical characters -- (a-z, A-Z, and 0-9) of the given length using the given
− Yesod/Internal/RouteParsing.hs
@@ -1,354 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter-module Yesod.Internal.RouteParsing- ( createRoutes- , createRender- , createParse- , createDispatch- , Pieces (..)- , THResource- , parseRoutes- , parseRoutesFile- , parseRoutesNoCheck- , parseRoutesFileNoCheck- , Resource (..)- , Piece (..)- ) where--import Web.PathPieces-import Language.Haskell.TH.Syntax-import Data.Maybe-import Data.Either-import Data.List-import Data.Char (toLower)-import qualified Data.Text-import Language.Haskell.TH.Quote-import Data.Data-import qualified System.IO as SIO--data Pieces =- SubSite- { ssType :: Type- , ssParse :: Exp- , ssRender :: Exp- , ssDispatch :: Exp- , ssToMasterArg :: Exp- , ssPieces :: [Piece]- }- | Simple [Piece] [String] -- ^ methods- deriving Show-type THResource = (String, Pieces)--createRoutes :: [THResource] -> Q [Con]-createRoutes res =- return $ map go res- where- go (n, SubSite{ssType = s, ssPieces = pieces}) =- NormalC (mkName n) $ mapMaybe go' pieces ++ [(NotStrict, s)]- go (n, Simple pieces _) = NormalC (mkName n) $ mapMaybe go' pieces- go' (SinglePiece x) = Just (NotStrict, ConT $ mkName x)- go' (MultiPiece x) = Just (NotStrict, ConT $ mkName x)- go' (StaticPiece _) = Nothing---- | Generates the set of clauses necesary to parse the given 'Resource's. See 'quasiParse'.-createParse :: [THResource] -> Q [Clause]-createParse res = do- final' <- final- clauses <- mapM go res- return $ if areResourcesComplete res- then clauses- else clauses ++ [final']- where- cons x y = ConP (mkName ":") [x, y]- go (constr, SubSite{ssParse = p, ssPieces = ps}) = do- ri <- [|Right|]- be <- [|ape|]- (pat', parse) <- mkPat' be ps $ ri `AppE` ConE (mkName constr)- - x <- newName "x"- let pat = init pat' ++ [VarP x]-- --let pat = foldr (\a b -> cons [LitP (StringL a), b]) (VarP x) pieces- let eitherSub = p `AppE` VarE x- let bod = be `AppE` parse `AppE` eitherSub- --let bod = fmape' `AppE` ConE (mkName constr) `AppE` eitherSub- return $ Clause [foldr1 cons pat] (NormalB bod) []- go (n, Simple ps _) = do- ri <- [|Right|]- be <- [|ape|]- (pat, parse) <- mkPat' be ps $ ri `AppE` ConE (mkName n)- return $ Clause [foldr1 cons pat] (NormalB parse) []- final = do- no <- [|Left "Invalid URL"|]- return $ Clause [WildP] (NormalB no) []- mkPat' :: Exp -> [Piece] -> Exp -> Q ([Pat], Exp)- mkPat' be [MultiPiece s] parse = do- v <- newName $ "var" ++ s- fmp <- [|fromMultiPiece|]- let parse' = InfixE (Just parse) be $ Just $ fmp `AppE` VarE v- return ([VarP v], parse')- mkPat' _ (MultiPiece _:_) _parse = error "MultiPiece must be last"- mkPat' be (StaticPiece s:rest) parse = do- (x, parse') <- mkPat' be rest parse- let sp = LitP $ StringL s- return (sp : x, parse')- mkPat' be (SinglePiece s:rest) parse = do- fsp <- [|fromSinglePiece|]- v <- newName $ "var" ++ s- let parse' = InfixE (Just parse) be $ Just $ fsp `AppE` VarE v- (x, parse'') <- mkPat' be rest parse'- return (VarP v : x, parse'')- mkPat' _ [] parse = return ([ListP []], parse)---- | 'ap' for 'Either'-ape :: Either String (a -> b) -> Either String a -> Either String b-ape (Left e) _ = Left e-ape (Right _) (Left e) = Left e-ape (Right f) (Right a) = Right $ f a---- | Generates the set of clauses necesary to render the given 'Resource's. See--- 'quasiRender'.-createRender :: [THResource] -> Q [Clause]-createRender = mapM go- where- go (n, Simple ps _) = do- let ps' = zip [1..] ps- let pat = ConP (mkName n) $ mapMaybe go' ps'- bod <- mkBod ps'- return $ Clause [pat] (NormalB $ TupE [bod, ListE []]) []- go (n, SubSite{ssRender = r, ssPieces = pieces}) = do- cons' <- [|\a (b, c) -> (a ++ b, c)|]- let cons a b = cons' `AppE` a `AppE` b- x <- newName "x"- let r' = r `AppE` VarE x- let pieces' = zip [1..] pieces- let pat = ConP (mkName n) $ mapMaybe go' pieces' ++ [VarP x]- bod <- mkBod pieces'- return $ Clause [pat] (NormalB $ cons bod r') []- go' (_, StaticPiece _) = Nothing- go' (i, _) = Just $ VarP $ mkName $ "var" ++ show (i :: Int)- mkBod :: (Show t) => [(t, Piece)] -> Q Exp- mkBod [] = lift ([] :: [String])- mkBod ((_, StaticPiece x):xs) = do- x' <- lift x- pack <- [|Data.Text.pack|]- xs' <- mkBod xs- return $ ConE (mkName ":") `AppE` (pack `AppE` x') `AppE` xs'- mkBod ((i, SinglePiece _):xs) = do- let x' = VarE $ mkName $ "var" ++ show i- tsp <- [|toSinglePiece|]- let x'' = tsp `AppE` x'- xs' <- mkBod xs- return $ ConE (mkName ":") `AppE` x'' `AppE` xs'- mkBod ((i, MultiPiece _):_) = do- let x' = VarE $ mkName $ "var" ++ show i- tmp <- [|toMultiPiece|]- return $ tmp `AppE` x'---- | Whether the set of resources cover all possible URLs.-areResourcesComplete :: [THResource] -> Bool-areResourcesComplete res =- let (slurps, noSlurps) = partitionEithers $ mapMaybe go res- in case slurps of- [] -> False- _ -> let minSlurp = minimum slurps- in helper minSlurp $ reverse $ sort noSlurps- where- go :: THResource -> Maybe (Either Int Int)- go (_, Simple ps _) =- case reverse ps of- [] -> Just $ Right 0- (MultiPiece _:rest) -> go' Left rest- x -> go' Right x- go (n, SubSite{ssPieces = ps}) =- go (n, Simple (ps ++ [MultiPiece ""]) [])- go' b x = if all isSingle x then Just (b $ length x) else Nothing- helper 0 _ = True- helper _ [] = False- helper m (i:is)- | i >= m = helper m is- | i + 1 == m = helper i is- | otherwise = False- isSingle (SinglePiece _) = True- isSingle _ = False--notStatic :: Piece -> Bool-notStatic StaticPiece{} = False-notStatic _ = True--createDispatch :: Exp -- ^ modify a master handler- -> Exp -- ^ convert a subsite handler to a master handler- -> [THResource]- -> Q [Clause]-createDispatch modMaster toMaster = mapM go- where- go :: (String, Pieces) -> Q Clause- go (n, Simple ps methods) = do- meth <- newName "method"- xs <- mapM newName $ replicate (length $ filter notStatic ps) "x"- let pat = [ ConP (mkName n) $ map VarP xs- , if null methods then WildP else VarP meth- ]- bod <- go' n meth xs methods- return $ Clause pat (NormalB bod) []- go (n, SubSite{ssDispatch = d, ssToMasterArg = tma, ssPieces = ps}) = do- meth <- newName "method"- x <- newName "x"- xs <- mapM newName $ replicate (length $ filter notStatic ps) "x"- let pat = [ConP (mkName n) $ map VarP xs ++ [VarP x], VarP meth]- let bod = d `AppE` VarE x `AppE` VarE meth- fmap' <- [|fmap|]- let routeToMaster = foldl AppE (ConE (mkName n)) $ map VarE xs- tma' = foldl AppE tma $ map VarE xs- let toMaster' = toMaster `AppE` routeToMaster `AppE` tma' `AppE` VarE x- let bod' = InfixE (Just toMaster') fmap' (Just bod)- let bod'' = InfixE (Just modMaster) fmap' (Just bod')- return $ Clause pat (NormalB bod'') []- go' n _ xs [] = do- jus <- [|Just|]- let bod = foldl AppE (VarE $ mkName $ "handle" ++ n) $ map VarE xs- return $ jus `AppE` (modMaster `AppE` bod)- go' n meth xs methods = do- noth <- [|Nothing|]- j <- [|Just|]- let noMatch = Match WildP (NormalB noth) []- return $ CaseE (VarE meth) $ map (go'' n xs j) methods ++ [noMatch]- go'' n xs j method =- let pat = LitP $ StringL method- func = map toLower method ++ n- bod = foldl AppE (VarE $ mkName func) $ map VarE xs- in Match pat (NormalB $ j `AppE` (modMaster `AppE` bod)) []---- | A quasi-quoter to parse a string into a list of 'Resource's. Checks for--- overlapping routes, failing if present; use 'parseRoutesNoCheck' to skip the--- checking. See documentation site for details on syntax.-parseRoutes :: QuasiQuoter-parseRoutes = QuasiQuoter- { quoteExp = x- , quotePat = y- }- where- x s = do- let res = resourcesFromString s- case findOverlaps res of- [] -> lift res- z -> error $ "Overlapping routes: " ++ unlines (map show z)- y = dataToPatQ (const Nothing) . resourcesFromString--parseRoutesFile :: FilePath -> Q Exp-parseRoutesFile fp = do- s <- qRunIO $ readUtf8File fp- quoteExp parseRoutes s--parseRoutesFileNoCheck :: FilePath -> Q Exp-parseRoutesFileNoCheck fp = do- s <- qRunIO $ readUtf8File fp- quoteExp parseRoutesNoCheck s--readUtf8File :: FilePath -> IO String-readUtf8File fp = do- h <- SIO.openFile fp SIO.ReadMode- SIO.hSetEncoding h SIO.utf8_bom- SIO.hGetContents h---- | Same as 'parseRoutes', but performs no overlap checking.-parseRoutesNoCheck :: QuasiQuoter-parseRoutesNoCheck = QuasiQuoter- { quoteExp = x- , quotePat = y- }- where- x = lift . resourcesFromString- y = dataToPatQ (const Nothing) . resourcesFromString--instance Lift Resource where- lift (Resource s ps h) = do- r <- [|Resource|]- s' <- lift s- ps' <- lift ps- h' <- lift h- return $ r `AppE` s' `AppE` ps' `AppE` h'---- | A single resource pattern.------ First argument is the name of the constructor, second is the URL pattern to--- match, third is how to dispatch.-data Resource = Resource String [Piece] [String]- deriving (Read, Show, Eq, Data, Typeable)---- | A single piece of a URL, delimited by slashes.------ In the case of StaticPiece, the argument is the value of the piece; for the--- other constructors, it is the name of the parameter represented by this--- piece. That value is not used here, but may be useful elsewhere.-data Piece = StaticPiece String- | SinglePiece String- | MultiPiece String- deriving (Read, Show, Eq, Data, Typeable)--instance Lift Piece where- lift (StaticPiece s) = do- c <- [|StaticPiece|]- s' <- lift s- return $ c `AppE` s'- lift (SinglePiece s) = do- c <- [|SinglePiece|]- s' <- lift s- return $ c `AppE` s'- lift (MultiPiece s) = do- c <- [|MultiPiece|]- s' <- lift s- return $ c `AppE` s'---- | Convert a multi-line string to a set of resources. See documentation for--- the format of this string. This is a partial function which calls 'error' on--- invalid input.-resourcesFromString :: String -> [Resource]-resourcesFromString =- mapMaybe go . lines- where- go s =- case takeWhile (/= "--") $ words s of- (pattern:constr:rest) ->- let pieces = piecesFromString $ drop1Slash pattern- in Just $ Resource constr pieces rest- [] -> Nothing- _ -> error $ "Invalid resource line: " ++ s--drop1Slash :: String -> String-drop1Slash ('/':x) = x-drop1Slash x = x--piecesFromString :: String -> [Piece]-piecesFromString "" = []-piecesFromString x =- let (y, z) = break (== '/') x- in pieceFromString y : piecesFromString (drop1Slash z)--pieceFromString :: String -> Piece-pieceFromString ('#':x) = SinglePiece x-pieceFromString ('*':x) = MultiPiece x-pieceFromString x = StaticPiece x---- n^2, should be a way to speed it up-findOverlaps :: [Resource] -> [(Resource, Resource)]-findOverlaps = go . map justPieces- where- justPieces :: Resource -> ([Piece], Resource)- justPieces r@(Resource _ ps _) = (ps, r)-- go [] = []- go (x:xs) = mapMaybe (mOverlap x) xs ++ go xs-- mOverlap :: ([Piece], Resource) -> ([Piece], Resource) ->- Maybe (Resource, Resource)- mOverlap (StaticPiece x:xs, xr) (StaticPiece y:ys, yr)- | x == y = mOverlap (xs, xr) (ys, yr)- | otherwise = Nothing- mOverlap (MultiPiece _:_, xr) (_, yr) = Just (xr, yr)- mOverlap (_, xr) (MultiPiece _:_, yr) = Just (xr, yr)- mOverlap ([], xr) ([], yr) = Just (xr, yr)- mOverlap ([], _) (_, _) = Nothing- mOverlap (_, _) ([], _) = Nothing- mOverlap (_:xs, xr) (_:ys, yr) = mOverlap (xs, xr) (ys, yr)
Yesod/Internal/Session.hs view
@@ -9,13 +9,14 @@ import Data.ByteString (ByteString) import Control.Monad (guard) import Data.Text (Text, pack, unpack)-import Control.Arrow ((***))+import Control.Arrow (first)+import Control.Applicative ((<$>)) encodeSession :: CS.Key -> CS.IV -> UTCTime -- ^ expire time -> ByteString -- ^ remote host- -> [(Text, Text)] -- ^ session+ -> [(Text, ByteString)] -- ^ session -> ByteString -- ^ cookie value encodeSession key iv expire rhost session' = CS.encrypt key iv $ encode $ SessionCookie expire rhost session'@@ -24,7 +25,7 @@ -> UTCTime -- ^ current time -> ByteString -- ^ remote host field -> ByteString -- ^ cookie value- -> Maybe [(Text, Text)]+ -> Maybe [(Text, ByteString)] decodeSession key now rhost encrypted = do decrypted <- CS.decrypt key encrypted SessionCookie expire rhost' session' <-@@ -33,14 +34,14 @@ guard $ rhost' == rhost return session' -data SessionCookie = SessionCookie UTCTime ByteString [(Text, Text)]+data SessionCookie = SessionCookie UTCTime ByteString [(Text, ByteString)] deriving (Show, Read) instance Serialize SessionCookie where- put (SessionCookie a b c) = putTime a >> put b >> put (map (unpack *** unpack) c)+ put (SessionCookie a b c) = putTime a >> put b >> put (map (first unpack) c) get = do a <- getTime b <- get- c <- map (pack *** pack) `fmap` get+ c <- map (first pack) <$> get return $ SessionCookie a b c putTime :: Putter UTCTime
Yesod/Internal/TestApi.hs view
@@ -6,22 +6,6 @@ -- module Yesod.Internal.TestApi ( randomString, parseWaiRequest'- , catchIter ) where import Yesod.Internal.Request (randomString, parseWaiRequest')-import Control.Exception (Exception, catch)-import Data.Enumerator (Iteratee (..), Step (..))-import Data.ByteString (ByteString)-import Prelude hiding (catch)--catchIter :: Exception e- => Iteratee ByteString IO a- -> (e -> Iteratee ByteString IO a)- -> Iteratee ByteString IO a-catchIter (Iteratee mstep) f = Iteratee $ do- step <- mstep `catch` (runIteratee . f)- return $ case step of- Continue k -> Continue $ \s -> catchIter (k s) f- Yield b s -> Yield b s- Error e -> Error e
Yesod/Logger.hs view
@@ -1,17 +1,21 @@ {-# LANGUAGE BangPatterns #-} module Yesod.Logger ( Logger- , makeLogger- , makeLoggerWithHandle- , makeDefaultLogger+ , handle+ , developmentLogger, productionLogger+ , defaultDevelopmentLogger, defaultProductionLogger+ , toProduction , flushLogger- , timed , logText , logLazyText , logString , logBS , logMsg , formatLogText+ , timed+ -- * Deprecated+ , makeLoggerWithHandle+ , makeDefaultLogger ) where import System.IO (Handle, stdout, hFlush)@@ -36,39 +40,62 @@ import Yesod.Core (LogLevel, fileLocationToString) data Logger = Logger {- loggerHandle :: Handle- , loggerDateRef :: DateRef+ loggerLogFun :: [LogStr] -> IO ()+ , loggerHandle :: Handle+ , loggerDateRef :: DateRef } -makeLogger :: IO Logger-makeLogger = makeDefaultLogger-{-# DEPRECATED makeLogger "Use makeDefaultLogger instead" #-}+handle :: Logger -> Handle+handle = loggerHandle -makeLoggerWithHandle :: Handle -> IO Logger-makeLoggerWithHandle handle = dateInit >>= return . Logger handle+flushLogger :: Logger -> IO ()+flushLogger = hFlush . loggerHandle --- | uses stdout handle makeDefaultLogger :: IO Logger-makeDefaultLogger = makeLoggerWithHandle stdout+makeDefaultLogger = defaultDevelopmentLogger+{-# DEPRECATED makeDefaultLogger "Use defaultProductionLogger or defaultDevelopmentLogger instead" #-} -flushLogger :: Logger -> IO ()-flushLogger = hFlush . loggerHandle+makeLoggerWithHandle, developmentLogger, productionLogger :: Handle -> IO Logger+makeLoggerWithHandle = productionLogger+{-# DEPRECATED makeLoggerWithHandle "Use productionLogger or developmentLogger instead" #-} +-- | uses stdout handle+defaultProductionLogger, defaultDevelopmentLogger :: IO Logger+defaultProductionLogger = productionLogger stdout+defaultDevelopmentLogger = developmentLogger stdout+++productionLogger h = mkLogger h (handleToLogFun h)+-- | a development logger gets automatically flushed+developmentLogger h = mkLogger h (\bs -> (handleToLogFun h) bs >> hFlush h)++mkLogger :: Handle -> ([LogStr] -> IO ()) -> IO Logger+mkLogger h logFun = do+ initHandle h+ dateInit >>= return . Logger logFun h++-- convert (a development) logger to production settings+toProduction :: Logger -> Logger+toProduction (Logger _ h d) = Logger (handleToLogFun h) h d++handleToLogFun :: Handle -> ([LogStr] -> IO ())+handleToLogFun = hPutLogStr+ logMsg :: Logger -> [LogStr] -> IO ()-logMsg = hPutLogStr . loggerHandle+logMsg = hPutLogStr . handle logLazyText :: Logger -> TL.Text -> IO ()-logLazyText logger msg = logMsg logger $+logLazyText logger msg = loggerLogFun logger $ map LB (toChunks $ TLE.encodeUtf8 msg) ++ [newLine] logText :: Logger -> Text -> IO () logText logger = logBS logger . encodeUtf8 logBS :: Logger -> ByteString -> IO ()-logBS logger msg = logMsg logger [LB msg, newLine]+logBS logger msg = loggerLogFun logger $ [LB msg, newLine] logString :: Logger -> String -> IO ()-logString logger msg = logMsg logger [LS msg, newLine]+logString logger msg = loggerLogFun logger $ [LS msg, newLine] formatLogText :: Logger -> Loc -> LogLevel -> Text -> IO [LogStr] formatLogText logger loc level msg = formatLogMsg logger loc level (toLB msg)@@ -91,7 +118,7 @@ ] newLine :: LogStr-newLine = LB $ pack "\"\n"+newLine = LB $ pack "\n" -- | Execute a monadic action and log the duration --
Yesod/Message.hs view
@@ -1,3 +1,4 @@+-- | This module has moved to "Text.Shakespeare.I18N" module Yesod.Message ( module Text.Shakespeare.I18N ) where
Yesod/Request.hs view
@@ -52,20 +52,20 @@ -- * Accept-Language HTTP header. -- -- This is handled by parseWaiRequest (not exposed).-languages :: Monad mo => GGHandler s m mo [Text]+languages :: GHandler s m [Text] languages = reqLangs `liftM` getRequest lookup' :: Eq a => a -> [(a, b)] -> [b] lookup' a = map snd . filter (\x -> a == fst x) -- | Lookup for GET parameters.-lookupGetParams :: Monad mo => Text -> GGHandler s m mo [Text]+lookupGetParams :: Text -> GHandler s m [Text] lookupGetParams pn = do rr <- getRequest return $ lookup' pn $ reqGetParams rr -- | Lookup for GET parameters.-lookupGetParam :: Monad mo => Text -> GGHandler s m mo (Maybe Text)+lookupGetParam :: Text -> GHandler s m (Maybe Text) lookupGetParam = liftM listToMaybe . lookupGetParams -- | Lookup for POST parameters.@@ -91,11 +91,11 @@ return $ lookup' pn files -- | Lookup for cookie data.-lookupCookie :: Monad mo => Text -> GGHandler s m mo (Maybe Text)+lookupCookie :: Text -> GHandler s m (Maybe Text) lookupCookie = liftM listToMaybe . lookupCookies -- | Lookup for cookie data.-lookupCookies :: Monad mo => Text -> GGHandler s m mo [Text]+lookupCookies :: Text -> GHandler s m [Text] lookupCookies pn = do rr <- getRequest return $ lookup' pn $ reqCookies rr
Yesod/Widget.hs view
@@ -6,12 +6,13 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE CPP #-}+-- FIXME Should we remove the older names here (addJulius, etc)?+ -- | Widgets combine HTML with JS and CSS dependencies with a unique identifier -- generator, allowing you to create truly modular HTML components. module Yesod.Widget ( -- * Datatype GWidget- , GGWidget (..) , PageContent (..) -- * Special Hamlet quasiquoter/TH for Widgets , whamlet@@ -45,33 +46,29 @@ -- ** Javascript , addJulius , addJuliusBody- , addCoffee- , addCoffeeBody , addScript , addScriptAttrs , addScriptRemote , addScriptRemoteAttrs , addScriptEither- -- * Utilities- , extractBody+ -- * Internal+ , unGWidget ) where import Data.Monoid-import Control.Monad.Trans.Writer import qualified Text.Blaze.Html5 as H import Text.Hamlet import Text.Cassius import Text.Julius-import Text.Coffee+import Yesod.Routes.Class import Yesod.Handler- (Route, GHandler, GGHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod- , getMessageRender, getUrlRenderParams+ ( GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod+ , getMessageRender, getUrlRenderParams, MonadLift (..) ) import Yesod.Message (RenderMessage) import Yesod.Content (RepHtml (..), toContent)-import Control.Applicative (Applicative)+import Control.Applicative (Applicative (..), (<$>)) import Control.Monad.IO.Class (MonadIO (liftIO))-import Control.Monad.Trans.Class (MonadTrans (lift)) import Yesod.Internal import Control.Monad (liftM) import Data.Text (Text)@@ -79,50 +76,23 @@ import Language.Haskell.TH.Quote (QuasiQuoter) import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE), Pat (VarP), newName) -#if MIN_VERSION_monad_control(0, 3, 0)-import Control.Monad.Trans.Control (MonadTransControl (..), MonadBaseControl (..), defaultLiftBaseWith, defaultRestoreM, ComposeSt)-#else-import Control.Monad.IO.Control (MonadControlIO)-#endif+import Control.Monad.Trans.Control (MonadBaseControl (..), control)+import Control.Monad.Trans.Resource+import Control.Exception (throwIO) import qualified Text.Hamlet as NP import Data.Text.Lazy.Builder (fromLazyText) import Text.Blaze (toHtml, preEscapedLazyText) import Control.Monad.Base (MonadBase (liftBase))+import Control.Arrow (first) -- | A generic widget, allowing specification of both the subsite and master--- site datatypes. This is basically a large 'WriterT' stack keeping track of--- dependencies along with a 'StateT' to track unique identifiers.-newtype GGWidget m monad a = GWidget { unGWidget :: GWInner m monad a }- deriving (Functor, Applicative, Monad, MonadIO-#if !MIN_VERSION_monad_control(0, 3, 0)- , MonadControlIO-#endif- )--instance MonadBase b m => MonadBase b (GGWidget master m) where- liftBase = lift . liftBase-#if MIN_VERSION_monad_control(0, 3, 0)-instance MonadTransControl (GGWidget master) where- newtype StT (GGWidget master) a =- StWidget {unStWidget :: StT (GWInner master) a}- liftWith f = GWidget $ liftWith $ \run ->- f $ liftM StWidget . run . unGWidget- restoreT = GWidget . restoreT . liftM unStWidget- {-# INLINE liftWith #-}- {-# INLINE restoreT #-}-instance MonadBaseControl b m => MonadBaseControl b (GGWidget master m) where- newtype StM (GGWidget master m) a = StMT {unStMT :: ComposeSt (GGWidget master) m a}- liftBaseWith = defaultLiftBaseWith StMT- restoreM = defaultRestoreM unStMT-#endif--instance MonadTrans (GGWidget m) where- lift = GWidget . lift--type GWidget s m = GGWidget m (GHandler s m)-type GWInner master = WriterT (GWData (Route master))+-- site datatypes. While this is simply a @WriterT@, we define a newtype for+-- better error messages.+newtype GWidget sub master a = GWidget+ { unGWidget :: GHandler sub master (a, GWData (Route master))+ } -instance (Monad monad, a ~ ()) => Monoid (GGWidget master monad a) where+instance (a ~ ()) => Monoid (GWidget sub master a) where mempty = return () mappend x y = x >> y @@ -130,8 +100,8 @@ addSubWidget sub (GWidget w) = do master <- lift getYesod let sr = fromSubRoute sub master- (a, w') <- lift $ toMasterHandlerMaybe sr (const sub) Nothing $ runWriterT w- GWidget $ tell w'+ (a, w') <- lift $ toMasterHandlerMaybe sr (const sub) Nothing w+ tell w' return a class ToWidget sub master a where@@ -153,8 +123,6 @@ toWidget = id instance ToWidget sub master Html where toWidget = addHtml-instance render ~ RY master => ToWidget sub master (render -> Coffeescript) where- toWidget = addCoffee class ToWidgetBody sub master a where toWidgetBody :: a -> GWidget sub master ()@@ -165,8 +133,6 @@ toWidgetBody = addJuliusBody instance ToWidgetBody sub master Html where toWidgetBody = addHtml-instance render ~ RY master => ToWidgetBody sub master (render -> Coffeescript) where- toWidgetBody = addCoffeeBody class ToWidgetHead sub master a where toWidgetHead :: a -> GWidget sub master ()@@ -179,129 +145,103 @@ toWidgetHead = addJulius instance ToWidgetHead sub master Html where toWidgetHead = addHtmlHead-instance render ~ RY master => ToWidgetHead sub master (render -> Coffeescript) where- toWidgetHead = addCoffee -- | Set the page title. Calling 'setTitle' multiple times overrides previously -- set values.-setTitle :: Monad m => Html -> GGWidget master m ()-setTitle x = GWidget $ tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty+setTitle :: Html -> GWidget sub master ()+setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty -- | Set the page title. Calling 'setTitle' multiple times overrides previously -- set values.-setTitleI :: (RenderMessage master msg, Monad m) => msg -> GGWidget master (GGHandler sub master m) ()+setTitleI :: RenderMessage master msg => msg -> GWidget sub master () setTitleI msg = do mr <- lift getMessageRender setTitle $ toHtml $ mr msg -- | Add a 'Hamlet' to the head tag.-addHamletHead :: Monad m => HtmlUrl (Route master) -> GGWidget master m ()-addHamletHead = GWidget . tell . GWData mempty mempty mempty mempty mempty mempty . Head+addHamletHead :: HtmlUrl (Route master) -> GWidget sub master ()+addHamletHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head -- | Add a 'Html' to the head tag.-addHtmlHead :: Monad m => Html -> GGWidget master m ()+addHtmlHead :: Html -> GWidget sub master () addHtmlHead = addHamletHead . const -- | Add a 'Hamlet' to the body tag.-addHamlet :: Monad m => HtmlUrl (Route master) -> GGWidget master m ()-addHamlet x = GWidget $ tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty+addHamlet :: HtmlUrl (Route master) -> GWidget sub master ()+addHamlet x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty -- | Add a 'Html' to the body tag.-addHtml :: Monad m => Html -> GGWidget master m ()+addHtml :: Html -> GWidget sub master () addHtml = addHamlet . const -- | Add another widget. This is defined as 'id', by can help with types, and -- makes widget blocks look more consistent.-addWidget :: Monad mo => GGWidget m mo () -> GGWidget m mo ()+addWidget :: GWidget sub master () -> GWidget sub master () addWidget = id -- | Add some raw CSS to the style tag. Applies to all media types.-addCassius :: Monad m => CssUrl (Route master) -> GGWidget master m ()-addCassius x = GWidget $ tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ \r -> fromLazyText $ renderCss $ x r) mempty mempty+addCassius :: CssUrl (Route master) -> GWidget sub master ()+addCassius x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ \r -> fromLazyText $ renderCss $ x r) mempty mempty -- | Identical to 'addCassius'.-addLucius :: Monad m => CssUrl (Route master) -> GGWidget master m ()+addLucius :: CssUrl (Route master) -> GWidget sub master () addLucius = addCassius -- | Add some raw CSS to the style tag, for a specific media type.-addCassiusMedia :: Monad m => Text -> CssUrl (Route master) -> GGWidget master m ()-addCassiusMedia m x = GWidget $ tell $ GWData mempty mempty mempty mempty (Map.singleton (Just m) $ \r -> fromLazyText $ renderCss $ x r) mempty mempty+addCassiusMedia :: Text -> CssUrl (Route master) -> GWidget sub master ()+addCassiusMedia m x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just m) $ \r -> fromLazyText $ renderCss $ x r) mempty mempty -- | Identical to 'addCassiusMedia'.-addLuciusMedia :: Monad m => Text -> CssUrl (Route master) -> GGWidget master m ()+addLuciusMedia :: Text -> CssUrl (Route master) -> GWidget sub master () addLuciusMedia = addCassiusMedia -- | Link to the specified local stylesheet.-addStylesheet :: Monad m => Route master -> GGWidget master m ()+addStylesheet :: Route master -> GWidget sub master () addStylesheet = flip addStylesheetAttrs [] -- | Link to the specified local stylesheet.-addStylesheetAttrs :: Monad m => Route master -> [(Text, Text)] -> GGWidget master m ()-addStylesheetAttrs x y = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty+addStylesheetAttrs :: Route master -> [(Text, Text)] -> GWidget sub master ()+addStylesheetAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty -- | Link to the specified remote stylesheet.-addStylesheetRemote :: Monad m => Text -> GGWidget master m ()+addStylesheetRemote :: Text -> GWidget sub master () addStylesheetRemote = flip addStylesheetRemoteAttrs [] -- | Link to the specified remote stylesheet.-addStylesheetRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> GGWidget master m ()-addStylesheetRemoteAttrs x y = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty+addStylesheetRemoteAttrs :: Text -> [(Text, Text)] -> GWidget sub master ()+addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty -addStylesheetEither :: Monad m => Either (Route master) Text -> GGWidget master m ()+addStylesheetEither :: Either (Route master) Text -> GWidget sub master () addStylesheetEither = either addStylesheet addStylesheetRemote -addScriptEither :: Monad m => Either (Route master) Text -> GGWidget master m ()+addScriptEither :: Either (Route master) Text -> GWidget sub master () addScriptEither = either addScript addScriptRemote -- | Link to the specified local script.-addScript :: Monad m => Route master -> GGWidget master m ()+addScript :: Route master -> GWidget sub master () addScript = flip addScriptAttrs [] -- | Link to the specified local script.-addScriptAttrs :: Monad m => Route master -> [(Text, Text)] -> GGWidget master m ()-addScriptAttrs x y = GWidget $ tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty+addScriptAttrs :: Route master -> [(Text, Text)] -> GWidget sub master ()+addScriptAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty -- | Link to the specified remote script.-addScriptRemote :: Monad m => Text -> GGWidget master m ()+addScriptRemote :: Text -> GWidget sub master () addScriptRemote = flip addScriptRemoteAttrs [] -- | Link to the specified remote script.-addScriptRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> GGWidget master m ()-addScriptRemoteAttrs x y = GWidget $ tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty+addScriptRemoteAttrs :: Text -> [(Text, Text)] -> GWidget sub master ()+addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty -- | Include raw Javascript in the page's script tag.-addJulius :: Monad m => JavascriptUrl (Route master) -> GGWidget master m ()-addJulius x = GWidget $ tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty+addJulius :: JavascriptUrl (Route master) -> GWidget sub master ()+addJulius x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty -- | Add a new script tag to the body with the contents of this 'Julius' -- template.-addJuliusBody :: Monad m => JavascriptUrl (Route master) -> GGWidget master m ()+addJuliusBody :: JavascriptUrl (Route master) -> GWidget sub master () addJuliusBody j = addHamlet $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j --- | Add Coffesscript to the page's script tag. Requires the coffeescript--- executable to be present at runtime.-addCoffee :: MonadIO m => CoffeeUrl (Route master) -> GGWidget master (GGHandler sub master m) ()-addCoffee c = do- render <- lift getUrlRenderParams- t <- liftIO $ renderCoffee render c- addJulius $ const $ Javascript $ fromLazyText t---- | Add a new script tag to the body with the contents of this Coffesscript--- template. Requires the coffeescript executable to be present at runtime.-addCoffeeBody :: MonadIO m => CoffeeUrl (Route master) -> GGWidget master (GGHandler sub master m) ()-addCoffeeBody c = do- render <- lift getUrlRenderParams- t <- liftIO $ renderCoffee render c- addJuliusBody $ const $ Javascript $ fromLazyText t---- | Pull out the HTML tag contents and return it. Useful for performing some--- manipulations. It can be easier to use this sometimes than 'wrapWidget'.-extractBody :: Monad mo => GGWidget m mo () -> GGWidget m mo (HtmlUrl (Route m))-extractBody (GWidget w) =- GWidget $ mapWriterT (liftM go) w- where- go ((), GWData (Body h) b c d e f g) = (h, GWData (Body mempty) b c d e f g)- -- | Content for a web page. By providing this datatype, we can easily create -- generic site templates, which would have the type signature: --@@ -330,16 +270,63 @@ return $ InfixE (Just g) bind (Just e') let ur f = do let env = NP.Env- (Just $ helper [|lift getUrlRenderParams|])- (Just $ helper [|liftM (toHtml .) $ lift getMessageRender|])+ (Just $ helper [|liftW getUrlRenderParams|])+ (Just $ helper [|liftM (toHtml .) $ liftW getMessageRender|]) f env return $ NP.HamletRules ah ur $ \_ b -> return b -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.-ihamletToRepHtml :: (Monad mo, RenderMessage master message)+ihamletToRepHtml :: RenderMessage master message => HtmlUrlI18n message (Route master)- -> GGHandler sub master mo RepHtml+ -> GHandler sub master RepHtml ihamletToRepHtml ih = do urender <- getUrlRenderParams mrender <- getMessageRender return $ RepHtml $ toContent $ ih (toHtml . mrender) urender++tell :: GWData (Route master) -> GWidget sub master ()+tell w = GWidget $ return ((), w)++instance MonadLift (GHandler sub master) (GWidget sub master) where+ lift = GWidget . fmap (\x -> (x, mempty))++-- | Type-restricted version of @lift@+liftW :: GHandler sub master a -> GWidget sub master a+liftW = lift++-- Instances for GWidget+instance Functor (GWidget sub master) where+ fmap f (GWidget x) = GWidget (fmap (first f) x)+instance Applicative (GWidget sub master) where+ pure a = GWidget $ pure (a, mempty)+ GWidget f <*> GWidget v =+ GWidget $ k <$> f <*> v+ where+ k (a, wa) (b, wb) = (a b, wa `mappend` wb)+instance Monad (GWidget sub master) where+ return = pure+ GWidget x >>= f = GWidget $ do+ (a, wa) <- x+ (b, wb) <- unGWidget (f a)+ return (b, wa `mappend` wb)+instance MonadIO (GWidget sub master) where+ liftIO = GWidget . fmap (\a -> (a, mempty)) . liftIO+instance MonadBase IO (GWidget sub master) where+ liftBase = GWidget . fmap (\a -> (a, mempty)) . liftBase+instance MonadBaseControl IO (GWidget sub master) where+ data StM (GWidget sub master) a =+ StW (StM (GHandler sub master) (a, GWData (Route master)))+ liftBaseWith f = GWidget $ liftBaseWith $ \runInBase ->+ liftM (\x -> (x, mempty))+ (f $ liftM StW . runInBase . unGWidget)+ restoreM (StW base) = GWidget $ restoreM base++instance Resource (GWidget sub master) where+ type Base (GWidget sub master) = IO+ resourceLiftBase = liftIO+ resourceBracket_ a b c = control $ \run -> resourceBracket_ a b (run c)+instance ResourceUnsafeIO (GWidget sub master) where+ unsafeFromIO = liftIO+instance ResourceThrow (GWidget sub master) where+ resourceThrow = liftIO . throwIO+instance ResourceIO (GWidget sub master)
test/YesodCoreTest/Cache.hs view
@@ -21,7 +21,7 @@ mkYesod "C" [parseRoutes|/ RootR GET|] -instance Yesod C where approot _ = ""+instance Yesod C getRootR :: Handler () getRootR = do
test/YesodCoreTest/CleanPath.hs view
@@ -20,14 +20,13 @@ getSubsite :: a -> Subsite getSubsite = const Subsite -data SubsiteRoute = SubsiteRoute [TS.Text]- deriving (Eq, Show, Read)-type instance Route Subsite = SubsiteRoute-instance RenderRoute SubsiteRoute where+instance RenderRoute Subsite where+ data Route Subsite = SubsiteRoute [TS.Text]+ deriving (Eq, Show, Read) renderRoute (SubsiteRoute x) = (x, []) instance YesodDispatch Subsite master where- yesodDispatch _ _ pieces _ _ = Just $ const $ return $ responseLBS+ yesodDispatch _ _ _ _ _ _ pieces _ _ = return $ responseLBS status200 [ ("Content-Type", "SUBSITE") ] $ L8.pack $ show pieces@@ -42,7 +41,8 @@ |] instance Yesod Y where- approot _ = "http://test"+ approot = ApprootStatic "http://test"+ cleanPath _ s@("subsite":_) = Right s cleanPath _ ["bar", ""] = Right ["bar"] cleanPath _ ["bar"] = Left ["bar", ""] cleanPath _ s =
test/YesodCoreTest/ErrorHandling.hs view
@@ -11,10 +11,6 @@ import Text.Hamlet (hamlet) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as S8-import Yesod.Internal.TestApi-import qualified Data.Enumerator as E-import qualified Data.Enumerator.List as EL-import Control.Exception (SomeException) data App = App @@ -25,7 +21,7 @@ /after_runRequestBody AfterRunRequestBodyR POST |] -instance Yesod App where approot _ = ""+instance Yesod App getHomeR :: Handler RepHtml getHomeR = defaultLayout $ toWidget [hamlet|@@ -61,7 +57,6 @@ [ it "says not found" caseNotFound , it "says 'There was an error' before runRequestBody" caseBefore , it "says 'There was an error' after runRequestBody" caseAfter- , it "catchIter handles internal exceptions" caseCatchIter ] runner :: Session () -> IO ()@@ -101,11 +96,3 @@ } assertStatus 500 res assertBodyContains "bin12345" res--caseCatchIter :: IO ()-caseCatchIter = E.run_ $ E.enumList 8 (replicate 1000 "foo") E.$$ flip catchIter ignorer $ do- _ <- EL.consume- error "foo"- where- ignorer :: SomeException -> E.Iteratee a IO ()- ignorer _ = return ()
test/YesodCoreTest/Exceptions.hs view
@@ -9,6 +9,7 @@ import Yesod.Core hiding (Request) import Network.Wai import Network.Wai.Test+import Network.HTTP.Types (status301) data Y = Y mkYesod "Y" [parseRoutes|@@ -17,7 +18,7 @@ |] instance Yesod Y where- approot _ = "http://test"+ approot = ApprootStatic "http://test" errorHandler (InternalError e) = return $ chooseRep $ RepPlain $ toContent e errorHandler x = defaultErrorHandler x @@ -27,7 +28,7 @@ getRedirR :: Handler () getRedirR = do setHeader "foo" "bar"- redirect RedirectPermanent RootR+ redirectWith status301 RootR exceptionsTest :: [Spec] exceptionsTest = describe "Test.Exceptions"
test/YesodCoreTest/InternalRequest.hs view
@@ -18,8 +18,10 @@ -- NOTE: this testcase may break on other systems/architectures if -- mkStdGen is not identical everywhere (is it?).+looksRandom :: Bool looksRandom = randomString 20 (mkStdGen 0) == "VH9SkhtptqPs6GqtofVg" +noRepeat :: Int -> Int -> Bool noRepeat len n = length (nub $ map (randomString len . mkStdGen) [1..n]) == n @@ -36,15 +38,19 @@ , it "generates a new nonce for sessions without nonce" generateNonce ] +noDisabledNonce :: Bool noDisabledNonce = reqNonce r == Nothing where r = parseWaiRequest' defaultRequest [] Nothing g +ignoreDisabledNonce :: Bool ignoreDisabledNonce = reqNonce r == Nothing where r = parseWaiRequest' defaultRequest [("_NONCE", "old")] Nothing g +useOldNonce :: Bool useOldNonce = reqNonce r == Just "old" where r = parseWaiRequest' defaultRequest [("_NONCE", "old")] (Just undefined) g +generateNonce :: Bool generateNonce = reqNonce r /= Nothing where r = parseWaiRequest' defaultRequest [("_NONCE", "old")] (Just undefined) g @@ -58,28 +64,33 @@ , it "prioritizes correctly" prioritizeLangs ] -respectAcceptLangs = reqLangs r == ["accept1", "accept2"] where+respectAcceptLangs :: Bool+respectAcceptLangs = reqLangs r == ["en-US", "es", "en"] where r = parseWaiRequest' defaultRequest- { requestHeaders = [("Accept-Language", "accept1, accept2")] } [] Nothing g+ { requestHeaders = [("Accept-Language", "en-US, es")] } [] Nothing g -respectSessionLang = reqLangs r == ["session"] where- r = parseWaiRequest' defaultRequest [("_LANG", "session")] Nothing g+respectSessionLang :: Bool+respectSessionLang = reqLangs r == ["en"] where+ r = parseWaiRequest' defaultRequest [("_LANG", "en")] Nothing g -respectCookieLang = reqLangs r == ["cookie"] where+respectCookieLang :: Bool+respectCookieLang = reqLangs r == ["en"] where r = parseWaiRequest' defaultRequest- { requestHeaders = [("Cookie", "_LANG=cookie")]+ { requestHeaders = [("Cookie", "_LANG=en")] } [] Nothing g -respectQueryLang = reqLangs r == ["query"] where- r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "query")] } [] Nothing g+respectQueryLang :: Bool+respectQueryLang = reqLangs r == ["en-US", "en"] where+ r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "en-US")] } [] Nothing g -prioritizeLangs = reqLangs r == ["query", "cookie", "session", "accept1", "accept2"] where+prioritizeLangs :: Bool+prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "es"] where r = parseWaiRequest' defaultRequest- { requestHeaders = [ ("Accept-Language", "accept1, accept2")- , ("Cookie", "_LANG=cookie")+ { requestHeaders = [ ("Accept-Language", "en, es")+ , ("Cookie", "_LANG=en-COOKIE") ]- , queryString = [("_LANG", Just "query")]- } [("_LANG", "session")] Nothing g+ , queryString = [("_LANG", Just "en-QUERY")]+ } [("_LANG", "en-SESSION")] Nothing g internalRequestTest :: [Spec]@@ -87,5 +98,3 @@ , nonceSpecs , langSpecs ]--main = hspec internalRequestTest
test/YesodCoreTest/Links.hs view
@@ -15,8 +15,7 @@ / RootR GET |] -instance Yesod Y where- approot _ = ""+instance Yesod Y getRootR :: Handler RepHtml getRootR = defaultLayout $ addHamlet [hamlet|<a href=@{RootR}>|]
test/YesodCoreTest/Media.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module YesodCoreTest.Media (mediaTest, Widget) where import Test.Hspec@@ -9,15 +10,11 @@ import Network.Wai import Network.Wai.Test import Text.Lucius+import YesodCoreTest.MediaData -data Y = Y-mkYesod "Y" [parseRoutes|-/ RootR GET-/static StaticR GET-|]+mkYesodDispatch "Y" resourcesY instance Yesod Y where- approot _ = "" addStaticContent _ _ content = do tm <- getRouteToMaster route <- getCurrentRoute
+ test/YesodCoreTest/MediaData.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+module YesodCoreTest.MediaData where++import Yesod.Core++data Y = Y+mkYesodData "Y" [parseRoutes|+/ RootR GET+/static StaticR GET+|]
test/YesodCoreTest/NoOverloadedStrings.hs view
@@ -8,7 +8,6 @@ import Yesod.Core hiding (Request) import Network.Wai.Test import Data.Monoid (mempty)-import Data.String (fromString) data Subsite = Subsite @@ -29,8 +28,7 @@ /subsite SubsiteR Subsite getSubsite |] -instance Yesod Y where- approot _ = fromString ""+instance Yesod Y getRootR :: Handler () getRootR = return ()
test/YesodCoreTest/Widget.hs view
@@ -28,7 +28,7 @@ |] instance Yesod Y where- approot _ = "http://test"+ approot = ApprootStatic "http://test" getRootR :: Handler RepHtml getRootR = defaultLayout $ toWidgetBody [julius|<not escaped>|]@@ -73,6 +73,7 @@ widgetTest = describe "Test.Widget" [ it "addJuliusBody" case_addJuliusBody , it "whamlet" case_whamlet+ , it "two letter lang codes" case_two_letter_lang ] runner :: Session () -> IO ()@@ -88,5 +89,13 @@ res <- request defaultRequest { pathInfo = ["whamlet"] , requestHeaders = [("Accept-Language", "es")]+ }+ assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><h1>Test</h1><h2>http://test/whamlet</h2><h3>Adios</h3><h3>String</h3><h4>Embed</h4></body></html>" res++case_two_letter_lang :: IO ()+case_two_letter_lang = runner $ do+ res <- request defaultRequest+ { pathInfo = ["whamlet"]+ , requestHeaders = [("Accept-Language", "es-ES")] } assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><h1>Test</h1><h2>http://test/whamlet</h2><h3>Adios</h3><h3>String</h3><h4>Embed</h4></body></html>" res
yesod-core.cabal view
@@ -1,5 +1,5 @@ name: yesod-core-version: 0.9.4.1+version: 0.10.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -18,6 +18,7 @@ test/en.msg test/YesodCoreTest/NoOverloadedStrings.hs test/YesodCoreTest/Media.hs+ test/YesodCoreTest/MediaData.hs test/YesodCoreTest/Exceptions.hs test/YesodCoreTest/Widget.hs test/YesodCoreTest/CleanPath.hs@@ -46,15 +47,16 @@ build-depends: wai-test build-depends: time >= 1.1.4- , wai >= 0.4 && < 0.5- , wai-extra >= 0.4.1 && < 0.5+ , yesod-routes >= 0.0.1 && < 0.1+ , wai >= 1.1 && < 1.2+ , wai-extra >= 1.1 && < 1.2 , bytestring >= 0.9.1.4 && < 0.10 , text >= 0.7 && < 0.12 , template-haskell- , path-pieces >= 0.0 && < 0.1- , hamlet >= 0.10.6 && < 0.11+ , path-pieces >= 0.1 && < 0.2+ , hamlet >= 0.10.7 && < 0.11 , shakespeare >= 0.10 && < 0.11- , shakespeare-js >= 0.10.4 && < 0.11+ , shakespeare-js >= 0.11 && < 0.12 , shakespeare-css >= 0.10.5 && < 0.11 , shakespeare-i18n >= 0.0 && < 0.1 , blaze-builder >= 0.2.1.4 && < 0.4@@ -63,23 +65,22 @@ , random >= 1.0.0.2 && < 1.1 , cereal >= 0.3 && < 0.4 , old-locale >= 1.0.0.2 && < 1.1- , failure >= 0.1 && < 0.2+ , failure >= 0.2 && < 0.3 , containers >= 0.2 && < 0.5- , monad-control >= 0.2 && < 0.4+ , monad-control >= 0.3 && < 0.4 , transformers-base >= 0.4- , enumerator >= 0.4.8 && < 0.5- , cookie >= 0.3 && < 0.4+ , cookie >= 0.4 && < 0.5 , blaze-html >= 0.4.1.3 && < 0.5 , http-types >= 0.6.5 && < 0.7 , case-insensitive >= 0.2 , parsec >= 2 && < 3.2 , directory >= 1 && < 1.2- , data-object >= 0.3 && < 0.4- , data-object-yaml >= 0.3 && < 0.4 , vector >= 0.9 && < 0.10- , aeson >= 0.3- , fast-logger >= 0.0.1+ , aeson >= 0.5+ , fast-logger >= 0.0.2 , wai-logger >= 0.0.1+ , conduit >= 0.2 && < 0.3+ , lifted-base >= 0.1 && < 0.2 exposed-modules: Yesod.Content Yesod.Core@@ -89,15 +90,12 @@ Yesod.Request Yesod.Widget Yesod.Message- Yesod.Config Yesod.Internal.TestApi other-modules: Yesod.Internal Yesod.Internal.Cache Yesod.Internal.Core Yesod.Internal.Session Yesod.Internal.Request- Yesod.Internal.Dispatch- Yesod.Internal.RouteParsing Paths_yesod_core ghc-options: -Wall @@ -117,7 +115,7 @@ main-is: test.hs cpp-options: -DTEST build-depends: hspec >= 0.8 && < 0.10- ,wai-test >= 0.1.2 && < 0.2+ ,wai-test ,wai ,yesod-core ,bytestring@@ -129,9 +127,8 @@ , random ,HUnit ,QuickCheck >= 2 && < 3- , enumerator ghc-options: -Wall source-repository head type: git- location: git://github.com/yesodweb/yesod.git+ location: https://github.com/yesodweb/yesod