yesod-core 0.10.3 → 1.0.0
raw patch · 15 files changed
+303/−250 lines, 15 filesdep +resourcetdep ~conduitdep ~hamletdep ~shakespeare
Dependencies added: resourcet
Dependency ranges changed: conduit, hamlet, shakespeare, shakespeare-css, shakespeare-i18n, shakespeare-js, transformers, wai, wai-extra, yesod-routes
Files
- Yesod/Content.hs +2/−2
- Yesod/Core.hs +8/−0
- Yesod/Dispatch.hs +20/−5
- Yesod/Handler.hs +16/−27
- Yesod/Internal.hs +5/−11
- Yesod/Internal/Core.hs +103/−101
- Yesod/Internal/Request.hs +17/−13
- Yesod/Internal/Session.hs +35/−15
- Yesod/Widget.hs +38/−34
- test/YesodCoreTest/ErrorHandling.hs +1/−1
- test/YesodCoreTest/InternalRequest.hs +25/−25
- test/YesodCoreTest/Links.hs +1/−1
- test/YesodCoreTest/Media.hs +2/−2
- test/YesodCoreTest/Widget.hs +17/−0
- yesod-core.cabal +13/−13
Yesod/Content.hs view
@@ -62,10 +62,10 @@ import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder) import Data.String (IsString (fromString)) import Network.Wai (FilePart)-import Data.Conduit (Source, Flush)+import Data.Conduit (Source, ResourceT, Flush) data Content = ContentBuilder Builder (Maybe Int) -- ^ The content and optional content length.- | ContentSource (Source IO (Flush Builder))+ | ContentSource (Source (ResourceT IO) (Flush Builder)) | ContentFile FilePath (Maybe FilePart) -- | Zero-length enumerator.
Yesod/Core.hs view
@@ -27,6 +27,13 @@ , logWarn , logError , logOther+ -- * Sessions+ , SessionBackend (..)+ , defaultClientSessionBackend+ , clientSessionBackend+ , loadClientSession+ , Header(..)+ , BackendSession -- * JS loaders , loadJsYepnope , ScriptLoadPosition (..)@@ -44,6 +51,7 @@ ) where import Yesod.Internal.Core+import Yesod.Internal (Header(..)) import Yesod.Content import Yesod.Dispatch import Yesod.Handler
Yesod/Dispatch.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} module Yesod.Dispatch ( -- * Quasi-quoted routing parseRoutes@@ -21,6 +24,8 @@ -- * Convert to WAI , toWaiApp , toWaiAppPlain+ -- * WAI subsites+ , WaiSubsite (..) ) where import Data.Functor ((<$>))@@ -38,7 +43,6 @@ import Data.ByteString.Lazy.Char8 () -import Web.ClientSession import Data.Text (Text) import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode)@@ -156,20 +160,20 @@ toWaiAppPlain :: ( Yesod master , YesodDispatch master master ) => master -> IO W.Application-toWaiAppPlain a = toWaiApp' a <$> encryptKey a+toWaiAppPlain a = toWaiApp' a <$> makeSessionBackend a toWaiApp' :: ( Yesod master , YesodDispatch master master ) => master- -> Maybe Key+ -> Maybe (SessionBackend master) -> W.Application-toWaiApp' y key' env =+toWaiApp' y sb 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+ yesodDispatch y y id app404 handler405 method pieces sb env where app404 = yesodRunner notFound y y Nothing id handler405 route = yesodRunner badMethod y y (Just route) id@@ -188,3 +192,14 @@ then dest else (dest `mappend` Blaze.ByteString.Builder.fromByteString (W.rawQueryString env))++-- | Wrap up a normal WAI application as a Yesod subsite.+newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application }++instance RenderRoute WaiSubsite where+ data Route WaiSubsite = WaiSubsiteRoute [Text] [(Text, Text)]+ deriving (Show, Eq, Read, Ord)+ renderRoute (WaiSubsiteRoute ps qs) = (ps, qs)++instance YesodDispatch WaiSubsite master where+ yesodDispatch _master (WaiSubsite app) _tomaster _404 _405 _method _pieces _session = app
Yesod/Handler.hs view
@@ -166,9 +166,9 @@ import Yesod.Internal.Cache (mkCacheKey, CacheKey) import Data.Typeable (Typeable) import qualified Data.IORef as I-import Control.Monad.Trans.Resource import Control.Exception.Lifted (catch) import Control.Monad.Trans.Control+import Control.Monad.Trans.Resource import Control.Monad.Base import Yesod.Routes.Class @@ -772,14 +772,9 @@ types = httpAccept $ reqWaiRequest rr errorHandler' = localNoCurrent . errorHandler -type HeaderRenderer = [Header]- -> ContentType- -> SessionMap- -> [(CI H.Ascii, H.Ascii)]--yarToResponse :: HeaderRenderer -> YesodAppResult -> W.Response-yarToResponse _ (YARWai a) = a-yarToResponse renderHeaders (YARPlain s hs ct c sessionFinal) =+yarToResponse :: YesodAppResult -> [(CI H.Ascii, H.Ascii)] -> W.Response+yarToResponse (YARWai a) _ = a+yarToResponse (YARPlain s hs _ c _) extraHeaders = case c of ContentBuilder b mlen -> let hs' = maybe finalHeaders finalHeaders' mlen@@ -787,11 +782,10 @@ ContentFile fp p -> W.ResponseFile s finalHeaders fp p ContentSource body -> W.ResponseSource s finalHeaders body where- finalHeaders = renderHeaders hs ct sessionFinal+ finalHeaders = extraHeaders ++ map headerToPair hs finalHeaders' len = ("Content-Length", S8.pack $ show len) : finalHeaders - httpAccept :: W.Request -> [ContentType] httpAccept = parseHttpAccept . fromMaybe mempty@@ -831,13 +825,8 @@ redirectToPost :: RedirectUrl master url => url -> GHandler sub master a redirectToPost url = do urlText <- toTextUrl url- hamletToRepHtml-#if GHC7- [hamlet|-#else- [$hamlet|-#endif-\<!DOCTYPE html>+ hamletToRepHtml [hamlet|+$doctype 5 <html> <head>@@ -922,12 +911,12 @@ 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)+instance MonadUnsafeIO (GHandler sub master) where+ unsafeLiftIO = liftIO+instance MonadThrow (GHandler sub master) where+ monadThrow = liftIO . throwIO+instance MonadResource (GHandler sub master) where+ allocate a = lift . allocate a+ register = lift . register+ release = lift . release+ resourceMask = lift . resourceMask
Yesod/Internal.hs view
@@ -25,7 +25,7 @@ , toUnique -- * Names , sessionName- , nonceKey+ , tokenKey ) where import Text.Hamlet (HtmlUrl, hamlet, Html)@@ -45,12 +45,6 @@ import Network.HTTP.Types (Ascii) import Web.Cookie (SetCookie (..)) -#if GHC7-#define HAMLET hamlet-#else-#define HAMLET $hamlet-#endif- -- | Responses to indicate some form of an error occurred. These are different -- from 'SpecialResponse' in that they allow for custom error pages. data ErrorResponse =@@ -76,9 +70,9 @@ data Location url = Local url | Remote Text deriving (Show, Eq) locationToHtmlUrl :: Location url -> HtmlUrl url-locationToHtmlUrl (Local url) = [HAMLET|\@{url}+locationToHtmlUrl (Local url) = [hamlet|\@{url} |]-locationToHtmlUrl (Remote s) = [HAMLET|\#{s}+locationToHtmlUrl (Remote s) = [hamlet|\#{s} |] newtype UniqueList x = UniqueList ([x] -> [x])@@ -101,8 +95,8 @@ newtype Body url = Body (HtmlUrl url) deriving Monoid -nonceKey :: IsString a => a-nonceKey = "_NONCE"+tokenKey :: IsString a => a+tokenKey = "_TOKEN" sessionName :: IsString a => a sessionName = "_SESSION"
Yesod/Internal/Core.hs view
@@ -25,6 +25,12 @@ , formatLogMessage , fileLocationToString , messageLoggerHandler+ -- * Sessions+ , SessionBackend (..)+ , defaultClientSessionBackend+ , clientSessionBackend+ , loadClientSession+ , BackendSession -- * jsLoader , ScriptLoadPosition (..) , BottomOfHeadAsync@@ -49,7 +55,6 @@ import Yesod.Internal import Yesod.Internal.Session import Yesod.Internal.Request-import Web.ClientSession (getKey, defaultKeyFile) import qualified Web.ClientSession as CS import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L@@ -60,7 +65,7 @@ import qualified Text.Blaze.Html5 as TBH import Data.Text.Lazy.Builder (toLazyText) import Data.Text.Lazy.Encoding (encodeUtf8)-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, isJust) import Control.Monad.IO.Class (MonadIO (liftIO)) import Web.Cookie (parseCookies) import qualified Data.Map as Map@@ -84,24 +89,12 @@ 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 import qualified Paths_yesod_core import Data.Version (showVersion)+ yesodVersion :: String yesodVersion = showVersion Paths_yesod_core.version-#else-yesodVersion :: String-yesodVersion = "0.9.4"-#endif -#if GHC7-#define HAMLET hamlet-#else-#define HAMLET $hamlet-#endif- -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. class YesodDispatch sub master where@@ -110,11 +103,11 @@ => master -> sub -> (Route sub -> Route master)- -> (Maybe CS.Key -> W.Application) -- ^ 404 handler- -> (Route sub -> Maybe CS.Key -> W.Application) -- ^ 405 handler+ -> (Maybe (SessionBackend master) -> W.Application) -- ^ 404 handler+ -> (Route sub -> Maybe (SessionBackend master) -> W.Application) -- ^ 405 handler -> Text -- ^ request method -> [Text] -- ^ pieces- -> Maybe CS.Key+ -> Maybe (SessionBackend master) -> W.Application yesodRunner :: Yesod master@@ -123,7 +116,7 @@ -> sub -> Maybe (Route sub) -> (Route sub -> Route master)- -> Maybe CS.Key+ -> Maybe (SessionBackend master) -> W.Application yesodRunner = defaultYesodRunner @@ -158,16 +151,6 @@ approot :: Approot a approot = ApprootRelative - -- | The encryption key to be used for encrypting client sessions.- -- Returning 'Nothing' disables sessions.- encryptKey :: a -> IO (Maybe CS.Key)- encryptKey _ = fmap Just $ getKey defaultKeyFile-- -- | Number of minutes before a client session times out. Defaults to- -- 120 (2 hours).- clientSessionDuration :: a -> Int- clientSessionDuration = const 120- -- | Output error response pages. errorHandler :: ErrorResponse -> GHandler sub a ChooseRep errorHandler = defaultErrorHandler@@ -177,8 +160,8 @@ defaultLayout w = do p <- widgetToPageContent w mmsg <- getMessage- hamletToRepHtml [HAMLET|-!!!+ hamletToRepHtml [hamlet|+$doctype 5 <html> <head>@@ -323,23 +306,24 @@ gzipSettings :: a -> GzipSettings gzipSettings _ = def - -- | Deprecated. Use 'jsloader'. To use yepnope: jsLoader = BottomOfHeadAsync (loadJsYepnope eyn)- -- 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-- -- | Where to Load sripts from. We recommend changing this to 'BottomOfBody'- -- Alternatively use the built in async yepnope loader:+ -- | Where to Load sripts from. We recommend the default value,+ -- 'BottomOfBody'. Alternatively use the built in async yepnope loader: -- -- > BottomOfHeadAsync $ loadJsYepnope $ Right $ StaticR js_modernizr_js -- -- Or write your own async js loader: see 'loadJsYepnope' jsLoader :: a -> ScriptLoadPosition a- jsLoader y = case yepnopeJs y of- Nothing -> BottomOfHeadBlocking- Just eyn -> BottomOfHeadAsync (loadJsYepnope eyn)+ jsLoader _ = BottomOfBody + -- | Create a session backend. Returning `Nothing' disables sessions.+ --+ -- Default: Uses clientsession with a 2 hour timeout.+ makeSessionBackend :: a -> IO (Maybe (SessionBackend a))+ makeSessionBackend _ = do+ key <- CS.getKey CS.defaultKeyFile+ return $ Just $ clientSessionBackend key 120++ messageLoggerHandler :: Yesod m => Loc -> LogLevel -> Text -> GHandler s m () messageLoggerHandler loc level msg = do@@ -388,7 +372,7 @@ -> sub -> Maybe (Route sub) -> (Route sub -> Route master)- -> Maybe CS.Key+ -> Maybe (SessionBackend master) -> W.Application defaultYesodRunner _ master _ murl toMaster _ req | maximumContentLength master (fmap toMaster murl) < len =@@ -402,20 +386,12 @@ case reads $ S8.unpack s of [] -> Nothing (x, _):_ -> Just x-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 = "" -- FIXME if sessionIpAddress master then S8.pack rh else ""- let session' = {-# SCC "session'" #-}- case mkey of- Nothing -> []- Just key -> fromMaybe [] $ do- raw <- lookup "Cookie" $ W.requestHeaders req- val <- lookup sessionName $ parseCookies raw- decodeSession key now host val- rr <- liftIO $ parseWaiRequest req session' mkey+defaultYesodRunner handler master sub murl toMasterRoute msb req = do+ now <- liftIO getCurrentTime+ let dontSaveSession _ _ = return []+ (session, saveSession) <- liftIO $+ maybe (return ([], dontSaveSession)) (\sb -> sbLoadSession sb master req now) msb+ rr <- liftIO $ parseWaiRequest req session (isJust msb) let h = {-# SCC "h" #-} do case murl of Nothing -> handler@@ -433,39 +409,20 @@ redirect url' Unauthorized s' -> permissionDenied s' handler- let sessionMap = Map.fromList- $ filter (\(x, _) -> x /= nonceKey) session'+ let sessionMap = Map.fromList . filter ((/=) tokenKey . fst) $ session 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- return $ yarToResponse (hr iv mnonce getExpires host exp') yar- where- hr iv mnonce getExpires host exp' hs ct sm =- hs'''- where- sessionVal =- case (mkey, mnonce) of- (Just key, Just nonce)- -> encodeSession key iv exp' host- $ Map.toList- $ Map.insert nonceKey (TE.encodeUtf8 nonce) sm- _ -> mempty- hs' =- case mkey of- Nothing -> hs- Just _ -> AddCookie def- { setCookieName = sessionName- , setCookieValue = sessionVal- , setCookiePath = Just (cookiePath master)- , setCookieExpires = Just $ getExpires (clientSessionDuration master)- , setCookieDomain = cookieDomain master- , setCookieHttpOnly = True- }- : hs- hs'' = map headerToPair hs'- hs''' = ("Content-Type", ct) : hs''+ yar <- handlerToYAR master sub toMasterRoute+ (yesodRender master ra) errorHandler rr murl sessionMap h+ extraHeaders <- case yar of+ (YARPlain _ _ ct _ newSess) -> do+ let nsToken = Map.toList $ maybe+ newSess+ (\n -> Map.insert tokenKey (TE.encodeUtf8 n) newSess)+ (reqToken rr)+ sessionHeaders <- liftIO (saveSession nsToken now)+ return $ ("Content-Type", ct) : map headerToPair sessionHeaders+ _ -> return []+ return $ yarToResponse yar extraHeaders data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text deriving (Eq, Show, Read)@@ -503,7 +460,7 @@ -> GHandler sub master ChooseRep applyLayout' title body = fmap chooseRep $ defaultLayout $ do setTitle title- addHamlet body+ toWidget body -- | The default error handler for 'errorHandler'. defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep@@ -511,19 +468,19 @@ r <- waiRequest let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r applyLayout' "Not Found"- [HAMLET|+ [hamlet| <h1>Not Found <p>#{path'} |] defaultErrorHandler (PermissionDenied msg) = applyLayout' "Permission Denied"- [HAMLET|+ [hamlet| <h1>Permission denied <p>#{msg} |] defaultErrorHandler (InvalidArgs ia) = applyLayout' "Invalid Arguments"- [HAMLET|+ [hamlet| <h1>Invalid Arguments <ul> $forall msg <- ia@@ -531,13 +488,13 @@ |] defaultErrorHandler (InternalError e) = applyLayout' "Internal Server Error"- [HAMLET|+ [hamlet| <h1>Internal Server Error <p>#{e} |] defaultErrorHandler (BadMethod m) = applyLayout' "Bad Method"- [HAMLET|+ [hamlet| <h1>Method Not Supported <p>Method "#{S8.unpack m}" not supported |]@@ -596,7 +553,7 @@ -- 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, asyncScripts) = asyncHelper render scripts jscript jsLoc- regularScriptLoad = [HAMLET|+ regularScriptLoad = [hamlet| $forall s <- scripts ^{mkScriptTag s} $maybe j <- jscript@@ -606,16 +563,16 @@ <script>^{jelper j} |] - headAll = [HAMLET|+ headAll = [hamlet| \^{head'} $forall s <- stylesheets ^{mkLinkTag s} $forall s <- css $maybe t <- right $ snd s $maybe media <- fst s- <link rel=stylesheet media=#{media} href=#{t}+ <link rel=stylesheet media=#{media} href=#{t}> $nothing- <link rel=stylesheet href=#{t}+ <link rel=stylesheet href=#{t}> $maybe content <- left $ snd s $maybe media <- fst s <style media=#{media}>#{content}@@ -628,7 +585,7 @@ $of BottomOfHeadBlocking ^{regularScriptLoad} |]- let bodyScript = [HAMLET|+ let bodyScript = [hamlet| ^{body} ^{regularScriptLoad} |]@@ -674,7 +631,7 @@ -- | For use with setting 'jsLoader' to 'BottomOfHeadAsync' loadJsYepnope :: Yesod master => Either Text (Route master) -> [Text] -> Maybe (HtmlUrl (Route master)) -> (HtmlUrl (Route master)) loadJsYepnope eyn scripts mcomplete =- [HAMLET|+ [hamlet| $maybe yn <- left eyn <script src=#{yn}> $maybe yn <- right eyn@@ -730,3 +687,48 @@ ApprootStatic t -> t ApprootMaster f -> f master ApprootRequest f -> f master req++defaultClientSessionBackend :: Yesod master => IO (SessionBackend master)+defaultClientSessionBackend = do+ key <- CS.getKey CS.defaultKeyFile+ let timeout = 120 -- 120 minutes+ return $ clientSessionBackend key timeout++clientSessionBackend :: Yesod master+ => CS.Key -- ^ The encryption key+ -> Int -- ^ Inactive session valitity in minutes+ -> SessionBackend master+clientSessionBackend key timeout = SessionBackend+ { sbLoadSession = loadClientSession key timeout+ }++loadClientSession :: Yesod master+ => CS.Key+ -> Int+ -> master+ -> W.Request+ -> UTCTime+ -> IO (BackendSession, SaveSession)+loadClientSession key timeout master req now = return (sess, save)+ where+ sess = fromMaybe [] $ do+ raw <- lookup "Cookie" $ W.requestHeaders req+ val <- lookup sessionName $ parseCookies raw+ let host = "" -- fixme, properly lock sessions to client address+ decodeClientSession key now host val+ save sess' now' = do+ -- fixme should we be caching this?+ iv <- liftIO CS.randomIV+ return [AddCookie def+ { setCookieName = sessionName+ , setCookieValue = sessionVal iv+ , setCookiePath = Just (cookiePath master)+ , setCookieExpires = Just expires+ , setCookieDomain = cookieDomain master+ , setCookieHttpOnly = True+ }]+ where+ host = "" -- fixme, properly lock sessions to client address+ expires = fromIntegral (timeout * 60) `addUTCTime` now'+ sessionVal iv = encodeClientSession key iv expires host sess'+
Yesod/Internal/Request.hs view
@@ -36,23 +36,25 @@ , reqWaiRequest :: W.Request -- | Languages which the client supports. , reqLangs :: [Text]- -- | A random, session-specific nonce used to prevent CSRF attacks.- , reqNonce :: Maybe Text+ -- | A random, session-specific token used to prevent CSRF attacks.+ , reqToken :: Maybe Text } parseWaiRequest :: W.Request -> [(Text, ByteString)] -- ^ session- -> Maybe a+ -> Bool -> IO Request-parseWaiRequest env session' key' = parseWaiRequest' env session' key' <$> newStdGen+parseWaiRequest env session' useToken =+ parseWaiRequest' env session' useToken <$> newStdGen parseWaiRequest' :: RandomGen g => W.Request -> [(Text, ByteString)] -- ^ session- -> Maybe a+ -> Bool -> g -> Request-parseWaiRequest' env session' key' gen = Request gets'' cookies' env langs'' nonce+parseWaiRequest' env session' useToken gen = + Request gets'' cookies' env langs'' token where gets' = queryToQueryText $ W.queryString env gets'' = map (second $ fromMaybe "") gets'@@ -73,14 +75,16 @@ -- 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+ -- If sessions are disabled tokens should not be used (any+ -- tokenKey present in the session is ignored). If sessions+ -- are enabled and a session has no tokenKey a new one is -- generated.- nonce = case (key', lookup nonceKey session') of- (Nothing, _) -> Nothing- (_, Just x) -> Just $ decodeUtf8With lenientDecode x- _ -> Just $ pack $ randomString 10 gen+ token = if not useToken+ then Nothing+ else Just $ maybe+ (pack $ randomString 10 gen)+ (decodeUtf8With lenientDecode)+ (lookup tokenKey session') addTwoLetters :: ([Text] -> [Text], Set.Set Text) -> [Text] -> [Text] addTwoLetters (toAdd, exist) [] =
Yesod/Internal/Session.hs view
@@ -1,8 +1,12 @@ module Yesod.Internal.Session- ( encodeSession- , decodeSession+ ( encodeClientSession+ , decodeClientSession+ , BackendSession+ , SaveSession+ , SessionBackend(..) ) where +import Yesod.Internal (Header(..)) import qualified Web.ClientSession as CS import Data.Serialize import Data.Time@@ -12,21 +16,37 @@ import Control.Arrow (first) import Control.Applicative ((<$>)) -encodeSession :: CS.Key- -> CS.IV- -> UTCTime -- ^ expire time- -> ByteString -- ^ remote host- -> [(Text, ByteString)] -- ^ session- -> ByteString -- ^ cookie value-encodeSession key iv expire rhost session' =+import qualified Data.ByteString.Char8 as S8+import qualified Network.Wai as W++type BackendSession = [(Text, S8.ByteString)]++type SaveSession = BackendSession -> -- ^ The session contents after running the handler+ UTCTime -> -- ^ current time+ IO [Header]++newtype SessionBackend master = SessionBackend+ { sbLoadSession :: master+ -> W.Request+ -> UTCTime+ -> IO (BackendSession, SaveSession) -- ^ Return the session data and a function to save the session+ }++encodeClientSession :: CS.Key+ -> CS.IV+ -> UTCTime -- ^ expire time+ -> ByteString -- ^ remote host+ -> [(Text, ByteString)] -- ^ session+ -> ByteString -- ^ cookie value+encodeClientSession key iv expire rhost session' = CS.encrypt key iv $ encode $ SessionCookie expire rhost session' -decodeSession :: CS.Key- -> UTCTime -- ^ current time- -> ByteString -- ^ remote host field- -> ByteString -- ^ cookie value- -> Maybe [(Text, ByteString)]-decodeSession key now rhost encrypted = do+decodeClientSession :: CS.Key+ -> UTCTime -- ^ current time+ -> ByteString -- ^ remote host field+ -> ByteString -- ^ cookie value+ -> Maybe [(Text, ByteString)]+decodeClientSession key now rhost encrypted = do decrypted <- CS.decrypt key encrypted SessionCookie expire rhost' session' <- either (const Nothing) Just $ decode decrypted
Yesod/Widget.hs view
@@ -74,16 +74,16 @@ import Data.Text (Text) import qualified Data.Map as Map import Language.Haskell.TH.Quote (QuasiQuoter)-import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE), Pat (VarP), newName)+import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE, AppE), Pat (VarP), newName) -import Control.Monad.Trans.Control (MonadBaseControl (..), control)-import Control.Monad.Trans.Resource+import Control.Monad.Trans.Control (MonadBaseControl (..)) 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)+import Control.Monad.Trans.Resource -- | A generic widget, allowing specification of both the subsite and master -- site datatypes. While this is simply a @WriterT@, we define a newtype for@@ -114,37 +114,37 @@ type RY master = Route master -> [(Text, Text)] -> Text instance render ~ RY master => ToWidget sub master (render -> Html) where- toWidget = addHamlet+ toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty instance render ~ RY master => ToWidget sub master (render -> Css) where- toWidget = addCassius+ toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ \r -> fromLazyText $ renderCss $ x r) mempty mempty instance render ~ RY master => ToWidget sub master (render -> Javascript) where- toWidget = addJulius-instance ToWidget sub master (GWidget sub master ()) where+ toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty+instance (sub' ~ sub, master' ~ master) => ToWidget sub' master' (GWidget sub master ()) where toWidget = id instance ToWidget sub master Html where- toWidget = addHtml+ toWidget = toWidget . const class ToWidgetBody sub master a where toWidgetBody :: a -> GWidget sub master () instance render ~ RY master => ToWidgetBody sub master (render -> Html) where- toWidgetBody = addHamlet+ toWidgetBody = toWidget instance render ~ RY master => ToWidgetBody sub master (render -> Javascript) where- toWidgetBody = addJuliusBody+ toWidgetBody j = toWidget $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j instance ToWidgetBody sub master Html where- toWidgetBody = addHtml+ toWidgetBody = toWidget class ToWidgetHead sub master a where toWidgetHead :: a -> GWidget sub master () instance render ~ RY master => ToWidgetHead sub master (render -> Html) where- toWidgetHead = addHamletHead+ toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head instance render ~ RY master => ToWidgetHead sub master (render -> Css) where- toWidgetHead = addCassius+ toWidgetHead = toWidget instance render ~ RY master => ToWidgetHead sub master (render -> Javascript) where- toWidgetHead = addJulius+ toWidgetHead = toWidget instance ToWidgetHead sub master Html where- toWidgetHead = addHtmlHead+ toWidgetHead = toWidgetHead . const -- | Set the page title. Calling 'setTitle' multiple times overrides previously -- set values.@@ -158,21 +158,25 @@ mr <- lift getMessageRender setTitle $ toHtml $ mr msg +{-# DEPRECATED addHamletHead, addHtmlHead "Use toWidgetHead instead" #-}+{-# DEPRECATED addHamlet, addHtml, addCassius, addLucius, addJulius "Use toWidget instead" #-}+{-# DEPRECATED addJuliusBody "Use toWidgetBody instead" #-}+ -- | Add a 'Hamlet' to the head tag. addHamletHead :: HtmlUrl (Route master) -> GWidget sub master ()-addHamletHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head+addHamletHead = toWidgetHead -- | Add a 'Html' to the head tag. addHtmlHead :: Html -> GWidget sub master ()-addHtmlHead = addHamletHead . const+addHtmlHead = toWidgetHead . const -- | Add a 'Hamlet' to the body tag. addHamlet :: HtmlUrl (Route master) -> GWidget sub master ()-addHamlet x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty+addHamlet = toWidget -- | Add a 'Html' to the body tag. addHtml :: Html -> GWidget sub master ()-addHtml = addHamlet . const+addHtml = toWidget -- | Add another widget. This is defined as 'id', by can help with types, and -- makes widget blocks look more consistent.@@ -181,11 +185,11 @@ -- | Add some raw CSS to the style tag. Applies to all media types. 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+addCassius = toWidget -- | Identical to 'addCassius'. addLucius :: CssUrl (Route master) -> GWidget sub master ()-addLucius = addCassius+addLucius = toWidget -- | Add some raw CSS to the style tag, for a specific media type. addCassiusMedia :: Text -> CssUrl (Route master) -> GWidget sub master ()@@ -235,12 +239,12 @@ -- | Include raw Javascript in the page's script tag. addJulius :: JavascriptUrl (Route master) -> GWidget sub master ()-addJulius x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty+addJulius = toWidget -- | Add a new script tag to the body with the contents of this 'Julius' -- template. addJuliusBody :: JavascriptUrl (Route master) -> GWidget sub master ()-addJuliusBody j = addHamlet $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j+addJuliusBody = toWidgetBody -- | Content for a web page. By providing this datatype, we can easily create -- generic site templates, which would have the type signature:@@ -260,7 +264,7 @@ rules :: Q NP.HamletRules rules = do- ah <- [|addHtml|]+ ah <- [|toWidget|] let helper qg f = do x <- newName "urender" e <- f $ VarE x@@ -273,7 +277,7 @@ (Just $ helper [|liftW getUrlRenderParams|]) (Just $ helper [|liftM (toHtml .) $ liftW getMessageRender|]) f env- return $ NP.HamletRules ah ur $ \_ b -> return b+ return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. ihamletToRepHtml :: RenderMessage master message@@ -321,12 +325,12 @@ (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)+instance MonadUnsafeIO (GWidget sub master) where+ unsafeLiftIO = liftIO+instance MonadThrow (GWidget sub master) where+ monadThrow = liftIO . throwIO+instance MonadResource (GWidget sub master) where+ allocate a = lift . allocate a+ register = lift . register+ release = lift . release+ resourceMask = lift . resourceMask
test/YesodCoreTest/ErrorHandling.hs view
@@ -25,7 +25,7 @@ getHomeR :: Handler RepHtml getHomeR = defaultLayout $ toWidget [hamlet|-!!!+$doctype 5 <html> <body>
test/YesodCoreTest/InternalRequest.hs view
@@ -27,32 +27,32 @@ -- For convenience instead of "(undefined :: StdGen)". g :: StdGen-g = undefined+g = error "test/YesodCoreTest/InternalRequest.g" -nonceSpecs :: [Spec]-nonceSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqNonce)"- [ it "is Nothing if sessions are disabled" noDisabledNonce- , it "ignores pre-existing nonce if sessions are disabled" ignoreDisabledNonce- , it "uses preexisting nonce in session" useOldNonce- , it "generates a new nonce for sessions without nonce" generateNonce+tokenSpecs :: [Spec]+tokenSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqToken)"+ [ it "is Nothing if sessions are disabled" noDisabledToken+ , it "ignores pre-existing token if sessions are disabled" ignoreDisabledToken+ , it "uses preexisting token in session" useOldToken+ , it "generates a new token for sessions without token" generateToken ] -noDisabledNonce :: Bool-noDisabledNonce = reqNonce r == Nothing where- r = parseWaiRequest' defaultRequest [] Nothing g+noDisabledToken :: Bool+noDisabledToken = reqToken r == Nothing where+ r = parseWaiRequest' defaultRequest [] False g -ignoreDisabledNonce :: Bool-ignoreDisabledNonce = reqNonce r == Nothing where- r = parseWaiRequest' defaultRequest [("_NONCE", "old")] Nothing g+ignoreDisabledToken :: Bool+ignoreDisabledToken = reqToken r == Nothing where+ r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] False g -useOldNonce :: Bool-useOldNonce = reqNonce r == Just "old" where- r = parseWaiRequest' defaultRequest [("_NONCE", "old")] (Just undefined) g+useOldToken :: Bool+useOldToken = reqToken r == Just "old" where+ r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] True g -generateNonce :: Bool-generateNonce = reqNonce r /= Nothing where- r = parseWaiRequest' defaultRequest [("_NONCE", "old")] (Just undefined) g+generateToken :: Bool+generateToken = reqToken r /= Nothing where+ r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] True g langSpecs :: [Spec]@@ -67,21 +67,21 @@ respectAcceptLangs :: Bool respectAcceptLangs = reqLangs r == ["en-US", "es", "en"] where r = parseWaiRequest' defaultRequest- { requestHeaders = [("Accept-Language", "en-US, es")] } [] Nothing g+ { requestHeaders = [("Accept-Language", "en-US, es")] } [] False g respectSessionLang :: Bool respectSessionLang = reqLangs r == ["en"] where- r = parseWaiRequest' defaultRequest [("_LANG", "en")] Nothing g+ r = parseWaiRequest' defaultRequest [("_LANG", "en")] False g respectCookieLang :: Bool respectCookieLang = reqLangs r == ["en"] where r = parseWaiRequest' defaultRequest { requestHeaders = [("Cookie", "_LANG=en")]- } [] Nothing g+ } [] False g respectQueryLang :: Bool respectQueryLang = reqLangs r == ["en-US", "en"] where- r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "en-US")] } [] Nothing g+ r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "en-US")] } [] False g prioritizeLangs :: Bool prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "es"] where@@ -90,11 +90,11 @@ , ("Cookie", "_LANG=en-COOKIE") ] , queryString = [("_LANG", Just "en-QUERY")]- } [("_LANG", "en-SESSION")] Nothing g+ } [("_LANG", "en-SESSION")] False g internalRequestTest :: [Spec] internalRequestTest = descriptions [ randomStringSpecs- , nonceSpecs+ , tokenSpecs , langSpecs ]
test/YesodCoreTest/Links.hs view
@@ -18,7 +18,7 @@ instance Yesod Y getRootR :: Handler RepHtml-getRootR = defaultLayout $ addHamlet [hamlet|<a href=@{RootR}>|]+getRootR = defaultLayout $ toWidget [hamlet|<a href=@{RootR}>|] linksTest :: [Spec] linksTest = describe "Test.Links"
test/YesodCoreTest/Media.hs view
@@ -27,9 +27,9 @@ getRootR :: Handler RepHtml getRootR = defaultLayout $ do- addCassius [lucius|foo1{bar:baz}|]+ toWidget [lucius|foo1{bar:baz}|] addCassiusMedia "screen" [lucius|foo2{bar:baz}|]- addCassius [lucius|foo3{bar:baz}|]+ toWidget [lucius|foo3{bar:baz}|] getStaticR :: Handler RepHtml getStaticR = getRootR
test/YesodCoreTest/Widget.hs view
@@ -25,6 +25,7 @@ /foo/*Strings MultiR GET /whamlet WhamletR GET /towidget TowidgetR GET+/auto AutoR GET |] instance Yesod Y where@@ -69,11 +70,19 @@ where embed = [whamlet|<h4>Embed|] +getAutoR :: Handler RepHtml+getAutoR = defaultLayout [whamlet|+^{someHtml}+|]+ where+ someHtml = [shamlet|somehtml|]+ widgetTest :: [Spec] widgetTest = describe "Test.Widget" [ it "addJuliusBody" case_addJuliusBody , it "whamlet" case_whamlet , it "two letter lang codes" case_two_letter_lang+ , it "automatically applies toWidget" case_auto ] runner :: Session () -> IO ()@@ -99,3 +108,11 @@ , 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++case_auto :: IO ()+case_auto = runner $ do+ res <- request defaultRequest+ { pathInfo = ["auto"]+ , requestHeaders = [("Accept-Language", "es")]+ }+ assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body>somehtml</body></html>" res
yesod-core.cabal view
@@ -1,6 +1,6 @@ name: yesod-core-version: 0.10.3-license: BSD3+version: 1.0.0+license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> maintainer: Michael Snoyman <michael@snoyman.com>@@ -47,20 +47,20 @@ build-depends: wai-test build-depends: time >= 1.1.4- , yesod-routes >= 0.0.1 && < 0.1- , wai >= 1.1 && < 1.2- , wai-extra >= 1.1 && < 1.3+ , yesod-routes >= 1.0 && < 1.1+ , wai >= 1.2 && < 1.3+ , wai-extra >= 1.2 && < 1.3 , bytestring >= 0.9.1.4 && < 0.10 , text >= 0.7 && < 0.12 , template-haskell , path-pieces >= 0.1 && < 0.2- , hamlet >= 0.10.7 && < 0.11- , shakespeare >= 0.10 && < 0.12- , shakespeare-js >= 0.11 && < 0.12- , shakespeare-css >= 0.10.5 && < 0.11- , shakespeare-i18n >= 0.0 && < 0.1+ , hamlet >= 1.0 && < 1.1+ , shakespeare >= 1.0 && < 1.1+ , shakespeare-js >= 1.0 && < 1.1+ , shakespeare-css >= 1.0 && < 1.1+ , shakespeare-i18n >= 1.0 && < 1.1 , blaze-builder >= 0.2.1.4 && < 0.4- , transformers >= 0.2.2 && < 0.3+ , transformers >= 0.2.2 && < 0.4 , clientsession >= 0.7.3.1 && < 0.8 , random >= 1.0.0.2 && < 1.1 , cereal >= 0.3 && < 0.4@@ -79,9 +79,9 @@ , aeson >= 0.5 , fast-logger >= 0.0.2 , wai-logger >= 0.0.1- , conduit >= 0.2 && < 0.3+ , conduit >= 0.4 && < 0.5+ , resourcet >= 0.3 && < 0.4 , lifted-base >= 0.1 && < 0.2- exposed-modules: Yesod.Content Yesod.Core Yesod.Dispatch