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

Merge pull request #1243 from mschristiansen/master

Browse Source 
Cleanup of yesod-core code
This commit is contained in:
Michael Snoyman 2016-06-28 11:13:50 +03:00 committed by GitHub
commit 8bbe91cbfe
25 changed files with 143 additions and 169 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
yesod-core/Yesod/Core.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
@ -134,11 +133,10 @@ import Text.Blaze.Html (Html, toHtml, preEscapedToMarkup)
import Control.Monad.Logger import Control.Monad.Logger
import Control.Monad.Trans.Class (MonadTrans (..)) import Control.Monad.Trans.Class (MonadTrans (..))
import Yesod.Core.Internal.Session import Yesod.Core.Internal.Session
import Yesod.Core.Internal.Run (yesodRunner) import Yesod.Core.Internal.Run (yesodRunner, yesodRender)
import Yesod.Core.Class.Yesod import Yesod.Core.Class.Yesod
import Yesod.Core.Class.Dispatch import Yesod.Core.Class.Dispatch
import Yesod.Core.Class.Breadcrumbs import Yesod.Core.Class.Breadcrumbs
import Yesod.Core.Internal.Run (yesodRender)
import qualified Yesod.Core.Internal.Run import qualified Yesod.Core.Internal.Run
import qualified Paths_yesod_core import qualified Paths_yesod_core
import Data.Version (showVersion) import Data.Version (showVersion)

6
yesod-core/Yesod/Core/Class/Dispatch.hs
View File

@ -1,7 +1,6 @@
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
@ -25,10 +24,9 @@ class YesodSubDispatch sub m where
-> W.Application -> W.Application
instance YesodSubDispatch WaiSubsite master where instance YesodSubDispatch WaiSubsite master where
yesodSubDispatch YesodSubRunnerEnv {..} req = yesodSubDispatch YesodSubRunnerEnv {..} = app
app req
where where
WaiSubsite app = ysreGetSub $ yreSite $ ysreParentEnv WaiSubsite app = ysreGetSub $ yreSite ysreParentEnv
-- | A helper function for creating YesodSubDispatch instances, used by the -- | A helper function for creating YesodSubDispatch instances, used by the
-- internal generated code. This function has been exported since 1.4.11. -- internal generated code. This function has been exported since 1.4.11.

65
yesod-core/Yesod/Core/Class/Yesod.hs
View File

@ -5,7 +5,6 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module Yesod.Core.Class.Yesod where module Yesod.Core.Class.Yesod where
import Control.Monad.Logger (logErrorS)
import Yesod.Core.Content import Yesod.Core.Content
import Yesod.Core.Handler import Yesod.Core.Handler
@ -15,16 +14,18 @@ import Blaze.ByteString.Builder (Builder)
import Blaze.ByteString.Builder.Char.Utf8 (fromText) import Blaze.ByteString.Builder.Char.Utf8 (fromText)
import Control.Arrow ((***), second) import Control.Arrow ((***), second)
import Control.Exception (bracket) import Control.Exception (bracket)
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif
import Control.Monad (forM, when, void) import Control.Monad (forM, when, void)
import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther), import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther),
LogSource) LogSource, logErrorS)
import Control.Monad.Trans.Resource (InternalState, createInternalState, closeInternalState) import Control.Monad.Trans.Resource (InternalState, createInternalState, closeInternalState)
import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import Data.Aeson (object, (.=)) import Data.Aeson (object, (.=))
import Data.List (foldl') import Data.List (foldl', nub)
import Data.List (nub)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Monoid import Data.Monoid
import Data.Text (Text) import Data.Text (Text)
@ -43,14 +44,13 @@ import Network.Wai.Parse (lbsBackEnd,
import Network.Wai.Logger (ZonedDate, clockDateCacher) import Network.Wai.Logger (ZonedDate, clockDateCacher)
import System.Log.FastLogger import System.Log.FastLogger
import Text.Blaze (customAttribute, textTag, import Text.Blaze (customAttribute, textTag,
toValue, (!)) toValue, (!),
import Text.Blaze (preEscapedToMarkup) preEscapedToMarkup)
import qualified Text.Blaze.Html5 as TBH import qualified Text.Blaze.Html5 as TBH
import Text.Hamlet import Text.Hamlet
import Text.Julius import Text.Julius
import qualified Web.ClientSession as CS import qualified Web.ClientSession as CS
import Web.Cookie (parseCookies) import Web.Cookie (SetCookie (..), parseCookies)
import Web.Cookie (SetCookie (..))
import Yesod.Core.Types import Yesod.Core.Types
import Yesod.Core.Internal.Session import Yesod.Core.Internal.Session
import Yesod.Core.Widget import Yesod.Core.Widget
@ -237,7 +237,7 @@ class RenderRoute site => Yesod site where
-- --
-- Default: Uses clientsession with a 2 hour timeout. -- Default: Uses clientsession with a 2 hour timeout.
makeSessionBackend :: site -> IO (Maybe SessionBackend) makeSessionBackend :: site -> IO (Maybe SessionBackend)
makeSessionBackend _ = fmap Just $ defaultClientSessionBackend 120 CS.defaultKeyFile makeSessionBackend _ = Just <$> defaultClientSessionBackend 120 CS.defaultKeyFile
-- | How to store uploaded files. -- | How to store uploaded files.
-- --
@ -388,8 +388,7 @@ sslOnlyMiddleware timeout handler = do
-- --
-- Since 1.2.0 -- Since 1.2.0
authorizationCheck :: Yesod site => HandlerT site IO () authorizationCheck :: Yesod site => HandlerT site IO ()
authorizationCheck = do authorizationCheck = getCurrentRoute >>= maybe (return ()) checkUrl
getCurrentRoute >>= maybe (return ()) checkUrl
where where
checkUrl url = do checkUrl url = do
isWrite <- isWriteRequest url isWrite <- isWriteRequest url
@ -399,21 +398,21 @@ authorizationCheck = do
AuthenticationRequired -> do AuthenticationRequired -> do
master <- getYesod master <- getYesod
case authRoute master of case authRoute master of
Nothing -> void $ notAuthenticated Nothing -> void notAuthenticated
Just url' -> do Just url' ->
void $ selectRep $ do void $ selectRep $ do
provideRepType typeHtml $ do provideRepType typeHtml $ do
setUltDestCurrent setUltDestCurrent
void $ redirect url' void $ redirect url'
provideRepType typeJson $ provideRepType typeJson $
void $ notAuthenticated void notAuthenticated
Unauthorized s' -> permissionDenied s' Unauthorized s' -> permissionDenied s'
-- | Calls 'csrfCheckMiddleware' with 'isWriteRequest', 'defaultCsrfHeaderName', and 'defaultCsrfParamName' as parameters. -- | Calls 'csrfCheckMiddleware' with 'isWriteRequest', 'defaultCsrfHeaderName', and 'defaultCsrfParamName' as parameters.
-- --
-- Since 1.4.14 -- Since 1.4.14
defaultCsrfCheckMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO res defaultCsrfCheckMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO res
defaultCsrfCheckMiddleware handler = do defaultCsrfCheckMiddleware handler =
csrfCheckMiddleware csrfCheckMiddleware
handler handler
(getCurrentRoute >>= maybe (return False) isWriteRequest) (getCurrentRoute >>= maybe (return False) isWriteRequest)
@ -592,12 +591,9 @@ defaultErrorHandler NotAuthenticated = selectRep $ do
-- The client will just use the authentication_url in the JSON -- The client will just use the authentication_url in the JSON
site <- getYesod site <- getYesod
rend <- getUrlRender rend <- getUrlRender
return $ object $ [ let apair u = ["authentication_url" .= rend u]
"message" .= ("Not logged in"::Text) content = maybe [] apair (authRoute site)
] ++ return $ object $ ("message" .= ("Not logged in"::Text)):content
case authRoute site of
Nothing -> []
Just url -> ["authentication_url" .= rend url]
defaultErrorHandler (PermissionDenied msg) = selectRep $ do defaultErrorHandler (PermissionDenied msg) = selectRep $ do
provideRep $ defaultLayout $ do provideRep $ defaultLayout $ do
@ -607,9 +603,7 @@ defaultErrorHandler (PermissionDenied msg) = selectRep $ do
<p>#{msg} <p>#{msg}
|] |]
provideRep $ provideRep $
return $ object $ [ return $ object ["message" .= ("Permission Denied. " <> msg)]
"message" .= ("Permission Denied. " <> msg)
]
defaultErrorHandler (InvalidArgs ia) = selectRep $ do defaultErrorHandler (InvalidArgs ia) = selectRep $ do
provideRep $ defaultLayout $ do provideRep $ defaultLayout $ do
@ -641,8 +635,8 @@ defaultErrorHandler (BadMethod m) = selectRep $ do
provideRep $ return $ object ["message" .= ("Bad method" :: Text), "method" .= TE.decodeUtf8With TEE.lenientDecode m] provideRep $ return $ object ["message" .= ("Bad method" :: Text), "method" .= TE.decodeUtf8With TEE.lenientDecode m]
asyncHelper :: (url -> [x] -> Text) asyncHelper :: (url -> [x] -> Text)
-> [Script (url)] -> [Script url]
-> Maybe (JavascriptUrl (url)) -> Maybe (JavascriptUrl url)
-> Maybe Text -> Maybe Text
-> (Maybe (HtmlUrl url), [Text]) -> (Maybe (HtmlUrl url), [Text])
asyncHelper render scripts jscript jsLoc = asyncHelper render scripts jscript jsLoc =
@ -732,8 +726,7 @@ defaultClientSessionBackend :: Int -- ^ minutes
-> IO SessionBackend -> IO SessionBackend
defaultClientSessionBackend minutes fp = do defaultClientSessionBackend minutes fp = do
key <- CS.getKey fp key <- CS.getKey fp
let timeout = fromIntegral (minutes * 60) (getCachedDate, _closeDateCacher) <- clientSessionDateCacher (minToSec minutes)
(getCachedDate, _closeDateCacher) <- clientSessionDateCacher timeout
return $ clientSessionBackend key getCachedDate return $ clientSessionBackend key getCachedDate
-- | Create a @SessionBackend@ which reads the session key from the named -- | Create a @SessionBackend@ which reads the session key from the named
@ -759,10 +752,12 @@ envClientSessionBackend :: Int -- ^ minutes
-> IO SessionBackend -> IO SessionBackend
envClientSessionBackend minutes name = do envClientSessionBackend minutes name = do
key <- CS.getKeyEnv name key <- CS.getKeyEnv name
let timeout = fromIntegral (minutes * 60) (getCachedDate, _closeDateCacher) <- clientSessionDateCacher $ minToSec minutes
(getCachedDate, _closeDateCacher) <- clientSessionDateCacher timeout
return $ clientSessionBackend key getCachedDate return $ clientSessionBackend key getCachedDate
minToSec :: (Integral a, Num b) => a -> b
minToSec minutes = fromIntegral (minutes * 60)
jsToHtml :: Javascript -> Html jsToHtml :: Javascript -> Html
jsToHtml (Javascript b) = preEscapedToMarkup $ toLazyText b jsToHtml (Javascript b) = preEscapedToMarkup $ toLazyText b
@ -818,8 +813,14 @@ loadClientSession key getCachedDate sessionName req = load
-- turn the TH Loc loaction information into a human readable string -- turn the TH Loc loaction information into a human readable string
-- leaving out the loc_end parameter -- leaving out the loc_end parameter
fileLocationToString :: Loc -> String fileLocationToString :: Loc -> String
fileLocationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++ fileLocationToString loc =
' ' : (loc_filename loc) ++ ':' : (line loc) ++ ':' : (char loc) concat
[ loc_package loc
, ':' : loc_module loc
, ' ' : loc_filename loc
, ':' : line loc
, ':' : char loc
]
where where
line = show . fst . loc_start line = show . fst . loc_start
char = show . snd . loc_start char = show . snd . loc_start

3
yesod-core/Yesod/Core/Content.hs
View File

@ -53,8 +53,6 @@ import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import Data.Text.Lazy (Text, pack) import Data.Text.Lazy (Text, pack)
import qualified Data.Text as T import qualified Data.Text as T
import Control.Monad (liftM)
import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString) import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)
#if __GLASGOW_HASKELL__ < 710 #if __GLASGOW_HASKELL__ < 710
import Data.Monoid (mempty) import Data.Monoid (mempty)
@ -62,6 +60,7 @@ import Data.Monoid (mempty)
import Text.Hamlet (Html) import Text.Hamlet (Html)
import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder) import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
import Data.Conduit (Source, Flush (Chunk), ResumableSource, mapOutput) import Data.Conduit (Source, Flush (Chunk), ResumableSource, mapOutput)
import Control.Monad (liftM)
import Control.Monad.Trans.Resource (ResourceT) import Control.Monad.Trans.Resource (ResourceT)
import Data.Conduit.Internal (ResumableSource (ResumableSource)) import Data.Conduit.Internal (ResumableSource (ResumableSource))
import qualified Data.Conduit.Internal as CI import qualified Data.Conduit.Internal as CI

10
yesod-core/Yesod/Core/Dispatch.hs
View File

@ -85,7 +85,7 @@ toWaiAppPlain site = do
sb <- makeSessionBackend site sb <- makeSessionBackend site
gen <- MWC.createSystemRandom gen <- MWC.createSystemRandom
getMaxExpires <- getGetMaxExpires getMaxExpires <- getGetMaxExpires
return $ toWaiAppYre $ YesodRunnerEnv return $ toWaiAppYre YesodRunnerEnv
{ yreLogger = logger { yreLogger = logger
, yreSite = site , yreSite = site
, yreSessionBackend = sb , yreSessionBackend = sb
@ -119,8 +119,8 @@ toWaiAppYre yre req =
dest' = dest' =
if S.null (W.rawQueryString env) if S.null (W.rawQueryString env)
then dest then dest
else (dest `mappend` else dest `mappend`
Blaze.ByteString.Builder.fromByteString (W.rawQueryString env)) Blaze.ByteString.Builder.fromByteString (W.rawQueryString env)
-- | Same as 'toWaiAppPlain', but provides a default set of middlewares. This -- | Same as 'toWaiAppPlain', but provides a default set of middlewares. This
-- set may change with future releases, but currently covers: -- set may change with future releases, but currently covers:
@ -184,7 +184,7 @@ warp port site = do
$(qLocation >>= liftLoc) $(qLocation >>= liftLoc)
"yesod-core" "yesod-core"
LevelError LevelError
(toLogStr $ "Exception from Warp: " ++ show e)) $ (toLogStr $ "Exception from Warp: " ++ show e))
Network.Wai.Handler.Warp.defaultSettings) Network.Wai.Handler.Warp.defaultSettings)
where where
shouldLog' = Network.Wai.Handler.Warp.defaultShouldDisplayException shouldLog' = Network.Wai.Handler.Warp.defaultShouldDisplayException
@ -231,7 +231,7 @@ warpEnv :: YesodDispatch site => site -> IO ()
warpEnv site = do warpEnv site = do
env <- getEnvironment env <- getEnvironment
case lookup "PORT" env of case lookup "PORT" env of
Nothing -> error $ "warpEnv: no PORT environment variable found" Nothing -> error "warpEnv: no PORT environment variable found"
Just portS -> Just portS ->
case readMay portS of case readMay portS of
Nothing -> error $ "warpEnv: invalid PORT environment variable: " ++ show portS Nothing -> error $ "warpEnv: invalid PORT environment variable: " ++ show portS

84
yesod-core/Yesod/Core/Handler.hs
View File

@ -189,10 +189,10 @@ import Control.Applicative ((<$>))
import Data.Monoid (mempty, mappend) import Data.Monoid (mempty, mappend)
#endif #endif
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
import Control.Exception (evaluate, SomeException) import Control.Exception (evaluate, SomeException, throwIO)
import Control.Exception.Lifted (handle) import Control.Exception.Lifted (handle)
import Control.Monad (liftM, void) import Control.Monad (void, liftM, unless)
import qualified Control.Monad.Trans.Writer as Writer import qualified Control.Monad.Trans.Writer as Writer
import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.IO.Class (MonadIO, liftIO)
@ -235,24 +235,19 @@ import Web.PathPieces (PathPiece(..))
import Yesod.Core.Class.Handler import Yesod.Core.Class.Handler
import Yesod.Core.Types import Yesod.Core.Types
import Yesod.Routes.Class (Route) import Yesod.Routes.Class (Route)
import Control.Exception (throwIO) import Blaze.ByteString.Builder (Builder)
import Blaze.ByteString.Builder (Builder) import Safe (headMay)
import Safe (headMay) import Data.CaseInsensitive (CI)
import Data.CaseInsensitive (CI)
import qualified Data.Conduit.List as CL import qualified Data.Conduit.List as CL
import Control.Monad (unless) import Control.Monad.Trans.Resource (MonadResource, InternalState, runResourceT, withInternalState, getInternalState, liftResourceT, resourceForkIO)
import Control.Monad.Trans.Resource (MonadResource, InternalState, runResourceT, withInternalState, getInternalState, liftResourceT, resourceForkIO
)
import qualified System.PosixCompat.Files as PC import qualified System.PosixCompat.Files as PC
import Control.Monad.Trans.Control (control, MonadBaseControl) import Control.Monad.Trans.Control (control, MonadBaseControl)
import Data.Conduit (Source, transPipe, Flush (Flush), yield, Producer import Data.Conduit (Source, transPipe, Flush (Flush), yield, Producer, Sink)
, Sink
)
import qualified Yesod.Core.TypeCache as Cache import qualified Yesod.Core.TypeCache as Cache
import qualified Data.Word8 as W8 import qualified Data.Word8 as W8
import qualified Data.Foldable as Fold import qualified Data.Foldable as Fold
import Data.Default import Data.Default
import Control.Monad.Logger (MonadLogger, logWarnS) import Control.Monad.Logger (MonadLogger, logWarnS)
get :: MonadHandler m => m GHState get :: MonadHandler m => m GHState
get = liftHandlerT $ HandlerT $ I.readIORef . handlerState get = liftHandlerT $ HandlerT $ I.readIORef . handlerState
@ -305,7 +300,7 @@ rbHelper' :: NWP.BackEnd x
-> W.Request -> W.Request
-> IO ([(Text, Text)], [(Text, FileInfo)]) -> IO ([(Text, Text)], [(Text, FileInfo)])
rbHelper' backend mkFI req = rbHelper' backend mkFI req =
(map fix1 *** mapMaybe fix2) <$> (NWP.parseRequestBody backend req) (map fix1 *** mapMaybe fix2) <$> NWP.parseRequestBody backend req
where where
fix1 = go *** go fix1 = go *** go
fix2 (x, NWP.FileInfo a' b c) fix2 (x, NWP.FileInfo a' b c)
@ -324,29 +319,29 @@ askHandlerEnv = liftHandlerT $ HandlerT $ return . handlerEnv
-- | Get the master site application argument. -- | Get the master site application argument.
getYesod :: MonadHandler m => m (HandlerSite m) getYesod :: MonadHandler m => m (HandlerSite m)
getYesod = rheSite `liftM` askHandlerEnv getYesod = rheSite <$> askHandlerEnv
-- | Get a specific component of the master site application argument. -- | Get a specific component of the master site application argument.
-- Analogous to the 'gets' function for operating on 'StateT'. -- Analogous to the 'gets' function for operating on 'StateT'.
getsYesod :: MonadHandler m => (HandlerSite m -> a) -> m a getsYesod :: MonadHandler m => (HandlerSite m -> a) -> m a
getsYesod f = (f . rheSite) `liftM` askHandlerEnv getsYesod f = (f . rheSite) <$> askHandlerEnv
-- | Get the URL rendering function. -- | Get the URL rendering function.
getUrlRender :: MonadHandler m => m (Route (HandlerSite m) -> Text) getUrlRender :: MonadHandler m => m (Route (HandlerSite m) -> Text)
getUrlRender = do getUrlRender = do
x <- rheRender `liftM` askHandlerEnv x <- rheRender <$> askHandlerEnv
return $ flip x [] return $ flip x []
-- | The URL rendering function with query-string parameters. -- | The URL rendering function with query-string parameters.
getUrlRenderParams getUrlRenderParams
:: MonadHandler m :: MonadHandler m
=> m (Route (HandlerSite m) -> [(Text, Text)] -> Text) => m (Route (HandlerSite m) -> [(Text, Text)] -> Text)
getUrlRenderParams = rheRender `liftM` askHandlerEnv getUrlRenderParams = rheRender <$> askHandlerEnv
-- | Get the route requested by the user. If this is a 404 response- where the -- | 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'. -- user requested an invalid route- this function will return 'Nothing'.
getCurrentRoute :: MonadHandler m => m (Maybe (Route (HandlerSite m))) getCurrentRoute :: MonadHandler m => m (Maybe (Route (HandlerSite m)))
getCurrentRoute = rheRoute `liftM` askHandlerEnv getCurrentRoute = rheRoute <$> askHandlerEnv
-- | Returns a function that runs 'HandlerT' actions inside @IO@. -- | Returns a function that runs 'HandlerT' actions inside @IO@.
-- --
@ -487,7 +482,7 @@ setUltDestCurrent = do
case route of case route of
Nothing -> return () Nothing -> return ()
Just r -> do Just r -> do
gets' <- reqGetParams `liftM` getRequest gets' <- reqGetParams <$> getRequest
setUltDest (r, gets') setUltDest (r, gets')
-- | Sets the ultimate destination to the referer request header, if present. -- | Sets the ultimate destination to the referer request header, if present.
@ -541,7 +536,7 @@ addMessage status msg = do
addMsg = maybe msg' (S.append msg' . S.cons W8._nul) addMsg = maybe msg' (S.append msg' . S.cons W8._nul)
msg' = S.append msg' = S.append
(encodeUtf8 status) (encodeUtf8 status)
(W8._nul `S.cons` (L.toStrict $ renderHtml msg)) (W8._nul `S.cons` L.toStrict (renderHtml msg))
-- | Adds a message in the user's session but uses RenderMessage to allow for i18n -- | Adds a message in the user's session but uses RenderMessage to allow for i18n
-- --
@ -568,7 +563,7 @@ getMessages = do
where where
enlist = pairup . S.split W8._nul enlist = pairup . S.split W8._nul
pairup [] = [] pairup [] = []
pairup [x] = [] pairup [_] = []
pairup (s:v:xs) = (decode s, preEscapedToHtml (decode v)) : pairup xs pairup (s:v:xs) = (decode s, preEscapedToHtml (decode v)) : pairup xs
decode = decodeUtf8With lenientDecode decode = decodeUtf8With lenientDecode
@ -584,7 +579,7 @@ setMessageI = addMessageI ""
-- | Gets just the last message in the user's session, -- | Gets just the last message in the user's session,
-- discards the rest and the status -- discards the rest and the status
getMessage :: MonadHandler m => m (Maybe Html) getMessage :: MonadHandler m => m (Maybe Html)
getMessage = (return . fmap snd . headMay) =<< getMessages getMessage = fmap (fmap snd . headMay) getMessages
-- | Bypass remaining handler code and output the given file. -- | Bypass remaining handler code and output the given file.
-- --
@ -657,7 +652,7 @@ sendRawResponseNoConduit
-> m a -> m a
sendRawResponseNoConduit raw = control $ \runInIO -> sendRawResponseNoConduit raw = control $ \runInIO ->
liftIO $ throwIO $ HCWai $ flip W.responseRaw fallback liftIO $ throwIO $ HCWai $ flip W.responseRaw fallback
$ \src sink -> runInIO (raw src sink) >> return () $ \src sink -> void $ runInIO (raw src sink)
where where
fallback = W.responseLBS H.status500 [("Content-Type", "text/plain")] fallback = W.responseLBS H.status500 [("Content-Type", "text/plain")]
"sendRawResponse: backend does not support raw responses" "sendRawResponse: backend does not support raw responses"
@ -672,7 +667,7 @@ sendRawResponse :: (MonadHandler m, MonadBaseControl IO m)
-> m a -> m a
sendRawResponse raw = control $ \runInIO -> sendRawResponse raw = control $ \runInIO ->
liftIO $ throwIO $ HCWai $ flip W.responseRaw fallback liftIO $ throwIO $ HCWai $ flip W.responseRaw fallback
$ \src sink -> runInIO (raw (src' src) (CL.mapM_ sink)) >> return () $ \src sink -> void $ runInIO $ raw (src' src) (CL.mapM_ sink)
where where
fallback = W.responseLBS H.status500 [("Content-Type", "text/plain")] fallback = W.responseLBS H.status500 [("Content-Type", "text/plain")]
"sendRawResponse: backend does not support raw responses" "sendRawResponse: backend does not support raw responses"
@ -901,17 +896,17 @@ instance (RedirectUrl master a, PathPiece b) => RedirectUrl master (Fragment a b
-- | Lookup for session data. -- | Lookup for session data.
lookupSession :: MonadHandler m => Text -> m (Maybe Text) lookupSession :: MonadHandler m => Text -> m (Maybe Text)
lookupSession = (liftM . fmap) (decodeUtf8With lenientDecode) . lookupSessionBS lookupSession = (fmap . fmap) (decodeUtf8With lenientDecode) . lookupSessionBS
-- | Lookup for session data in binary format. -- | Lookup for session data in binary format.
lookupSessionBS :: MonadHandler m => Text -> m (Maybe S.ByteString) lookupSessionBS :: MonadHandler m => Text -> m (Maybe S.ByteString)
lookupSessionBS n = do lookupSessionBS n = do
m <- liftM ghsSession get m <- fmap ghsSession get
return $ Map.lookup n m return $ Map.lookup n m
-- | Get all session variables. -- | Get all session variables.
getSession :: MonadHandler m => m SessionMap getSession :: MonadHandler m => m SessionMap
getSession = liftM ghsSession get getSession = fmap ghsSession get
-- | Get a unique identifier. -- | Get a unique identifier.
newIdent :: MonadHandler m => m Text newIdent :: MonadHandler m => m Text
@ -976,13 +971,13 @@ withUrlRenderer f = do
-- | Get the request\'s 'W.Request' value. -- | Get the request\'s 'W.Request' value.
waiRequest :: MonadHandler m => m W.Request waiRequest :: MonadHandler m => m W.Request
waiRequest = reqWaiRequest `liftM` getRequest waiRequest = reqWaiRequest <$> getRequest
getMessageRender :: (MonadHandler m, RenderMessage (HandlerSite m) message) getMessageRender :: (MonadHandler m, RenderMessage (HandlerSite m) message)
=> m (message -> Text) => m (message -> Text)
getMessageRender = do getMessageRender = do
env <- askHandlerEnv env <- askHandlerEnv
l <- reqLangs `liftM` getRequest l <- reqLangs <$> getRequest
return $ renderMessage (rheSite env) l return $ renderMessage (rheSite env) l
-- | Use a per-request cache to avoid performing the same action multiple times. -- | Use a per-request cache to avoid performing the same action multiple times.
@ -1045,7 +1040,7 @@ cachedBy k action = do
-- --
-- This is handled by parseWaiRequest (not exposed). -- This is handled by parseWaiRequest (not exposed).
languages :: MonadHandler m => m [Text] languages :: MonadHandler m => m [Text]
languages = reqLangs `liftM` getRequest languages = reqLangs <$> getRequest
lookup' :: Eq a => a -> [(a, b)] -> [b] lookup' :: Eq a => a -> [(a, b)] -> [b]
lookup' a = map snd . filter (\x -> a == fst x) lookup' a = map snd . filter (\x -> a == fst x)
@ -1054,7 +1049,7 @@ lookup' a = map snd . filter (\x -> a == fst x)
-- --
-- Since 1.2.2 -- Since 1.2.2
lookupHeader :: MonadHandler m => CI S8.ByteString -> m (Maybe S8.ByteString) lookupHeader :: MonadHandler m => CI S8.ByteString -> m (Maybe S8.ByteString)
lookupHeader = liftM listToMaybe . lookupHeaders lookupHeader = fmap listToMaybe . lookupHeaders
-- | Lookup a request header. -- | Lookup a request header.
-- --
@ -1069,11 +1064,9 @@ lookupHeaders key = do
-- --
-- Since 1.4.9 -- Since 1.4.9
lookupBasicAuth :: (MonadHandler m) => m (Maybe (Text, Text)) lookupBasicAuth :: (MonadHandler m) => m (Maybe (Text, Text))
lookupBasicAuth = fmap (>>= getBA) lookupBasicAuth = fmap (>>= getBA) (lookupHeader "Authorization")
(lookupHeader "Authorization")
where where
getBA bs = (\(x, y) -> ( decodeUtf8With lenientDecode x getBA bs = (decodeUtf8With lenientDecode *** decodeUtf8With lenientDecode)
, decodeUtf8With lenientDecode y))
<$> extractBasicAuth bs <$> extractBasicAuth bs
-- | Lookup bearer authentication datafrom __Authorization__ header of -- | Lookup bearer authentication datafrom __Authorization__ header of
@ -1096,7 +1089,7 @@ lookupGetParams pn = do
-- | Lookup for GET parameters. -- | Lookup for GET parameters.
lookupGetParam :: MonadHandler m => Text -> m (Maybe Text) lookupGetParam :: MonadHandler m => Text -> m (Maybe Text)
lookupGetParam = liftM listToMaybe . lookupGetParams lookupGetParam = fmap listToMaybe . lookupGetParams
-- | Lookup for POST parameters. -- | Lookup for POST parameters.
lookupPostParams :: (MonadResource m, MonadHandler m) => Text -> m [Text] lookupPostParams :: (MonadResource m, MonadHandler m) => Text -> m [Text]
@ -1107,13 +1100,13 @@ lookupPostParams pn = do
lookupPostParam :: (MonadResource m, MonadHandler m) lookupPostParam :: (MonadResource m, MonadHandler m)
=> Text => Text
-> m (Maybe Text) -> m (Maybe Text)
lookupPostParam = liftM listToMaybe . lookupPostParams lookupPostParam = fmap listToMaybe . lookupPostParams
-- | Lookup for POSTed files. -- | Lookup for POSTed files.
lookupFile :: (MonadHandler m, MonadResource m) lookupFile :: (MonadHandler m, MonadResource m)
=> Text => Text
-> m (Maybe FileInfo) -> m (Maybe FileInfo)
lookupFile = liftM listToMaybe . lookupFiles lookupFile = fmap listToMaybe . lookupFiles
-- | Lookup for POSTed files. -- | Lookup for POSTed files.
lookupFiles :: (MonadHandler m, MonadResource m) lookupFiles :: (MonadHandler m, MonadResource m)
@ -1125,7 +1118,7 @@ lookupFiles pn = do
-- | Lookup for cookie data. -- | Lookup for cookie data.
lookupCookie :: MonadHandler m => Text -> m (Maybe Text) lookupCookie :: MonadHandler m => Text -> m (Maybe Text)
lookupCookie = liftM listToMaybe . lookupCookies lookupCookie = fmap listToMaybe . lookupCookies
-- | Lookup for cookie data. -- | Lookup for cookie data.
lookupCookies :: MonadHandler m => Text -> m [Text] lookupCookies :: MonadHandler m => Text -> m [Text]
@ -1160,7 +1153,7 @@ selectRep :: MonadHandler m
selectRep w = do selectRep w = do
-- the content types are already sorted by q values -- the content types are already sorted by q values
-- which have been stripped -- which have been stripped
cts <- liftM reqAccept getRequest cts <- fmap reqAccept getRequest
case mapMaybe tryAccept cts of case mapMaybe tryAccept cts of
[] -> [] ->
@ -1175,8 +1168,7 @@ selectRep w = do
explainUnaccepted :: Text explainUnaccepted :: Text
explainUnaccepted = "no match found for accept header" explainUnaccepted = "no match found for accept header"
returnRep (ProvidedRep ct mcontent) = returnRep (ProvidedRep ct mcontent) = fmap (TypedContent ct) mcontent
mcontent >>= return . TypedContent ct
reps = appEndo (Writer.execWriter w) [] reps = appEndo (Writer.execWriter w) []
@ -1235,7 +1227,7 @@ provideRepType :: (Monad m, ToContent a)
-> m a -> m a
-> Writer.Writer (Endo [ProvidedRep m]) () -> Writer.Writer (Endo [ProvidedRep m]) ()
provideRepType ct handler = provideRepType ct handler =
Writer.tell $ Endo $ (ProvidedRep ct (liftM toContent handler):) Writer.tell $ Endo (ProvidedRep ct (liftM toContent handler):)
-- | Stream in the raw request body without any parsing. -- | Stream in the raw request body without any parsing.
-- --

13
yesod-core/Yesod/Core/Internal/Request.hs
View File

@ -1,5 +1,4 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings, CPP #-}
{-# LANGUAGE CPP #-}
module Yesod.Core.Internal.Request module Yesod.Core.Internal.Request
( parseWaiRequest ( parseWaiRequest
, RequestBodyContents , RequestBodyContents
@ -37,7 +36,7 @@ import Data.Text.Encoding.Error (lenientDecode)
import Data.Conduit import Data.Conduit
import Data.Conduit.List (sourceList) import Data.Conduit.List (sourceList)
import Data.Conduit.Binary (sourceFile, sinkFile) import Data.Conduit.Binary (sourceFile, sinkFile)
import Data.Word (Word64) import Data.Word (Word8, Word64)
import Control.Monad.Trans.Resource (runResourceT, ResourceT) import Control.Monad.Trans.Resource (runResourceT, ResourceT)
import Control.Exception (throwIO) import Control.Exception (throwIO)
import Control.Monad ((<=<), liftM) import Control.Monad ((<=<), liftM)
@ -47,7 +46,6 @@ import Data.IORef
import qualified System.Random.MWC as MWC import qualified System.Random.MWC as MWC
import Control.Monad.Primitive (PrimMonad, PrimState) import Control.Monad.Primitive (PrimMonad, PrimState)
import qualified Data.Vector.Storable as V import qualified Data.Vector.Storable as V
import Data.Word (Word8)
import Data.ByteString.Internal (ByteString (PS)) import Data.ByteString.Internal (ByteString (PS))
import qualified Data.Word8 as Word8 import qualified Data.Word8 as Word8
@ -78,7 +76,7 @@ parseWaiRequest :: W.Request
-> SessionMap -> SessionMap
-> Bool -> Bool
-> Maybe Word64 -- ^ max body size -> Maybe Word64 -- ^ max body size
-> (Either (IO YesodRequest) (MWC.GenIO -> IO YesodRequest)) -> Either (IO YesodRequest) (MWC.GenIO -> IO YesodRequest)
parseWaiRequest env session useToken mmaxBodySize = parseWaiRequest env session useToken mmaxBodySize =
-- In most cases, we won't need to generate any random values. Therefore, -- In most cases, we won't need to generate any random values. Therefore,
-- we split our results: if we need a random generator, return a Right -- we split our results: if we need a random generator, return a Right
@ -147,7 +145,7 @@ httpAccept = NWP.parseHttpAccept
addTwoLetters :: ([Text] -> [Text], Set.Set Text) -> [Text] -> [Text] addTwoLetters :: ([Text] -> [Text], Set.Set Text) -> [Text] -> [Text]
addTwoLetters (toAdd, exist) [] = addTwoLetters (toAdd, exist) [] =
filter (flip Set.notMember exist) $ toAdd [] filter (`Set.notMember` exist) $ toAdd []
addTwoLetters (toAdd, exist) (l:ls) = addTwoLetters (toAdd, exist) (l:ls) =
l : addTwoLetters (toAdd', exist') ls l : addTwoLetters (toAdd', exist') ls
where where
@ -177,7 +175,8 @@ fromByteVector v =
{-# INLINE fromByteVector #-} {-# INLINE fromByteVector #-}
mkFileInfoLBS :: Text -> Text -> L.ByteString -> FileInfo mkFileInfoLBS :: Text -> Text -> L.ByteString -> FileInfo
mkFileInfoLBS name ct lbs = FileInfo name ct (sourceList $ L.toChunks lbs) (\fp -> L.writeFile fp lbs) mkFileInfoLBS name ct lbs =
FileInfo name ct (sourceList $ L.toChunks lbs) (`L.writeFile` lbs)
mkFileInfoFile :: Text -> Text -> FilePath -> FileInfo mkFileInfoFile :: Text -> Text -> FilePath -> FileInfo
mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runResourceT $ sourceFile fp $$ sinkFile dst) mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runResourceT $ sourceFile fp $$ sinkFile dst)

21
yesod-core/Yesod/Core/Internal/Response.hs
View File

@ -1,19 +1,15 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Yesod.Core.Internal.Response where module Yesod.Core.Internal.Response where
import Blaze.ByteString.Builder (toByteString)
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import qualified Data.ByteString as S import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Char8 as S8
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import Network.Wai import Network.Wai
import Data.Conduit (transPipe) import Control.Monad (mplus)
import Control.Monad.Trans.Resource (runInternalState, InternalState) import Control.Monad.Trans.Resource (runInternalState, InternalState)
import Network.Wai.Internal import Network.Wai.Internal
#if !MIN_VERSION_base(4, 6, 0) #if !MIN_VERSION_base(4, 6, 0)
@ -26,12 +22,12 @@ import qualified Network.HTTP.Types as H
import qualified Data.Text as T import qualified Data.Text as T
import Control.Exception (SomeException, handle) import Control.Exception (SomeException, handle)
import Blaze.ByteString.Builder (fromLazyByteString, import Blaze.ByteString.Builder (fromLazyByteString,
toLazyByteString) toLazyByteString, toByteString)
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.Map as Map import qualified Data.Map as Map
import Yesod.Core.Internal.Request (tokenKey) import Yesod.Core.Internal.Request (tokenKey)
import Data.Text.Encoding (encodeUtf8) import Data.Text.Encoding (encodeUtf8)
import Data.Conduit (Flush (..), ($$)) import Data.Conduit (Flush (..), ($$), transPipe)
import qualified Data.Conduit.List as CL import qualified Data.Conduit.List as CL
yarToResponse :: YesodResponse yarToResponse :: YesodResponse
@ -58,11 +54,10 @@ yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq _req is sendResponse
let go (ContentBuilder b mlen) = do let go (ContentBuilder b mlen) = do
let hs' = maybe finalHeaders finalHeaders' mlen let hs' = maybe finalHeaders finalHeaders' mlen
sendResponse $ ResponseBuilder s hs' b sendResponse $ ResponseBuilder s hs' b
go (ContentFile fp p) = do go (ContentFile fp p) = sendResponse $ ResponseFile s finalHeaders fp p
sendResponse $ ResponseFile s finalHeaders fp p
go (ContentSource body) = sendResponse $ responseStream s finalHeaders go (ContentSource body) = sendResponse $ responseStream s finalHeaders
$ \sendChunk flush -> do $ \sendChunk flush ->
transPipe (flip runInternalState is) body transPipe (`runInternalState` is) body
$$ CL.mapM_ (\mchunk -> $$ CL.mapM_ (\mchunk ->
case mchunk of case mchunk of
Flush -> flush Flush -> flush
@ -91,7 +86,7 @@ defaultStatus = H.mkStatus (-1) "INVALID DEFAULT STATUS"
headerToPair :: Header headerToPair :: Header
-> (CI ByteString, ByteString) -> (CI ByteString, ByteString)
headerToPair (AddCookie sc) = headerToPair (AddCookie sc) =
("Set-Cookie", toByteString $ renderSetCookie $ sc) ("Set-Cookie", toByteString $ renderSetCookie sc)
headerToPair (DeleteCookie key path) = headerToPair (DeleteCookie key path) =
( "Set-Cookie" ( "Set-Cookie"
, S.concat , S.concat
@ -107,7 +102,7 @@ evaluateContent :: Content -> IO (Either ErrorResponse Content)
evaluateContent (ContentBuilder b mlen) = handle f $ do evaluateContent (ContentBuilder b mlen) = handle f $ do
let lbs = toLazyByteString b let lbs = toLazyByteString b
len = L.length lbs len = L.length lbs
mlen' = maybe (Just $ fromIntegral len) Just mlen mlen' = mlen `mplus` Just (fromIntegral len)
len `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen') len `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen')
where where
f :: SomeException -> IO (Either ErrorResponse Content) f :: SomeException -> IO (Either ErrorResponse Content)

5
yesod-core/Yesod/Core/Internal/Run.hs
View File

@ -11,6 +11,7 @@ module Yesod.Core.Internal.Run where
#if __GLASGOW_HASKELL__ < 710 #if __GLASGOW_HASKELL__ < 710
import Data.Monoid (Monoid, mempty) import Data.Monoid (Monoid, mempty)
import Control.Applicative ((<$>))
#endif #endif
import Yesod.Core.Internal.Response import Yesod.Core.Internal.Response
import Blaze.ByteString.Builder (toByteString) import Blaze.ByteString.Builder (toByteString)
@ -102,7 +103,7 @@ basicRunHandler rhe handler yreq resState = do
(\e -> (\e ->
case fromException e of case fromException e of
Just e' -> return e' Just e' -> return e'
Nothing -> fmap HCError $ toErrorHandler e) Nothing -> HCError <$> toErrorHandler e)
-- Get the raw state and return -- Get the raw state and return
state <- I.readIORef istate state <- I.readIORef istate
@ -330,7 +331,7 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse
| otherwise = do | otherwise = do
let dontSaveSession _ = return [] let dontSaveSession _ = return []
(session, saveSession) <- liftIO $ (session, saveSession) <- liftIO $
maybe (return (Map.empty, dontSaveSession)) (\sb -> sbLoadSession sb req) yreSessionBackend maybe (return (Map.empty, dontSaveSession)) (`sbLoadSession` req) yreSessionBackend
maxExpires <- yreGetMaxExpires maxExpires <- yreGetMaxExpires
let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend) mmaxLen let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend) mmaxLen
let yreq = let yreq =

6
yesod-core/Yesod/Core/Internal/Session.hs
View File

@ -11,11 +11,9 @@ import qualified Web.ClientSession as CS
import Data.Serialize import Data.Serialize
import Data.Time import Data.Time
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Monad (guard)
import Control.Monad (forever, guard)
import Yesod.Core.Types import Yesod.Core.Types
import Yesod.Core.Internal.Util import Yesod.Core.Internal.Util
import qualified Data.IORef as I
import Control.AutoUpdate import Control.AutoUpdate
encodeClientSession :: CS.Key encodeClientSession :: CS.Key
@ -63,7 +61,7 @@ clientSessionDateCacher validity = do
, updateFreq = 10000000 -- 10s , updateFreq = 10000000 -- 10s
} }
return $! (getClientSessionDateCache, return ()) return (getClientSessionDateCache, return ())
where where
getUpdated = do getUpdated = do
now <- getCurrentTime now <- getCurrentTime

15
yesod-core/Yesod/Core/Internal/TH.hs
View File

@ -16,7 +16,10 @@ import qualified Network.Wai as W
import Data.ByteString.Lazy.Char8 () import Data.ByteString.Lazy.Char8 ()
import Data.List (foldl') import Data.List (foldl')
import Control.Monad (replicateM) #if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif
import Control.Monad (replicateM, void)
import Data.Either (partitionEithers) import Data.Either (partitionEithers)
import Yesod.Routes.TH import Yesod.Routes.TH
@ -45,15 +48,15 @@ mkYesodWith name args = fmap (uncurry (++)) . mkYesodGeneral name args False ret
-- monolithic file into smaller parts. Use this function, paired with -- monolithic file into smaller parts. Use this function, paired with
-- 'mkYesodDispatch', to do just that. -- 'mkYesodDispatch', to do just that.
mkYesodData :: String -> [ResourceTree String] -> Q [Dec] mkYesodData :: String -> [ResourceTree String] -> Q [Dec]
mkYesodData name res = mkYesodDataGeneral name False res mkYesodData name = mkYesodDataGeneral name False
mkYesodSubData :: String -> [ResourceTree String] -> Q [Dec] mkYesodSubData :: String -> [ResourceTree String] -> Q [Dec]
mkYesodSubData name res = mkYesodDataGeneral name True res mkYesodSubData name = mkYesodDataGeneral name True
mkYesodDataGeneral :: String -> Bool -> [ResourceTree String] -> Q [Dec] mkYesodDataGeneral :: String -> Bool -> [ResourceTree String] -> Q [Dec]
mkYesodDataGeneral name isSub res = do mkYesodDataGeneral name isSub res = do
let (name':rest) = words name let (name':rest) = words name
fmap fst $ mkYesodGeneral name' (fmap Left rest) isSub return res fst <$> mkYesodGeneral name' (fmap Left rest) isSub return res
-- | See 'mkYesodData'. -- | See 'mkYesodData'.
mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec] mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
@ -150,8 +153,8 @@ mkMDS f rh = MkDispatchSettings
, mdsGetPathInfo = [|W.pathInfo|] , mdsGetPathInfo = [|W.pathInfo|]
, mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|] , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]
, mdsMethod = [|W.requestMethod|] , mdsMethod = [|W.requestMethod|]
, mds404 = [|notFound >> return ()|] , mds404 = [|void notFound|]
, mds405 = [|badMethod >> return ()|] , mds405 = [|void badMethod|]
, mdsGetHandler = defaultGetHandler , mdsGetHandler = defaultGetHandler
, mdsUnwrapper = f , mdsUnwrapper = f
} }

4
yesod-core/Yesod/Core/Internal/Util.hs
View File

@ -14,8 +14,6 @@ import qualified Data.Text as T
import Data.Time (Day (ModifiedJulianDay, toModifiedJulianDay), import Data.Time (Day (ModifiedJulianDay, toModifiedJulianDay),
DiffTime, UTCTime (..), formatTime, DiffTime, UTCTime (..), formatTime,
getCurrentTime, addUTCTime) getCurrentTime, addUTCTime)
import Control.Monad (liftM)
#if MIN_VERSION_time(1,5,0) #if MIN_VERSION_time(1,5,0)
import Data.Time (defaultTimeLocale) import Data.Time (defaultTimeLocale)
#else #else
@ -58,4 +56,4 @@ formatRFC822 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z"
date on a resource that never expires. See RFC 2616 section 14.21 for details. date on a resource that never expires. See RFC 2616 section 14.21 for details.
-} -}
getCurrentMaxExpiresRFC1123 :: IO T.Text getCurrentMaxExpiresRFC1123 :: IO T.Text
getCurrentMaxExpiresRFC1123 = liftM (formatRFC1123 . addUTCTime (60*60*24*365)) getCurrentTime getCurrentMaxExpiresRFC1123 = fmap (formatRFC1123 . addUTCTime (60*60*24*365)) getCurrentTime

19
yesod-core/Yesod/Core/Types.hs
View File

@ -20,8 +20,7 @@ import Control.Arrow (first)
import Control.Exception (Exception) import Control.Exception (Exception)
import Control.Monad (liftM, ap) import Control.Monad (liftM, ap)
import Control.Monad.Base (MonadBase (liftBase)) import Control.Monad.Base (MonadBase (liftBase))
import Control.Monad.Catch (MonadCatch (..)) import Control.Monad.Catch (MonadMask (..), MonadCatch (..))
import Control.Monad.Catch (MonadMask (..))
import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Logger (LogLevel, LogSource, import Control.Monad.Logger (LogLevel, LogSource,
MonadLogger (..)) MonadLogger (..))
@ -172,7 +171,7 @@ data ScriptLoadPosition master
type BottomOfHeadAsync master type BottomOfHeadAsync master
= [Text] -- ^ urls to load asynchronously = [Text] -- ^ urls to load asynchronously
-> Maybe (HtmlUrl (Route master)) -- ^ widget of js to run on async completion -> Maybe (HtmlUrl (Route master)) -- ^ widget of js to run on async completion
-> (HtmlUrl (Route master)) -- ^ widget to insert at the bottom of <head> -> HtmlUrl (Route master) -- ^ widget to insert at the bottom of <head>
type Texts = [Text] type Texts = [Text]
@ -264,7 +263,7 @@ instance (a ~ (), Monad m) => Semigroup (WidgetT site m a)
-- @getHomeR = do defaultLayout "Widget text"@ -- @getHomeR = do defaultLayout "Widget text"@
instance (Monad m, a ~ ()) => IsString (WidgetT site m a) where instance (Monad m, a ~ ()) => IsString (WidgetT site m a) where
fromString = toWidget . toHtml . T.pack fromString = toWidget . toHtml . T.pack
where toWidget x = WidgetT $ const $ return $ ((), GWData (Body (const x)) where toWidget x = WidgetT $ const $ return ((), GWData (Body (const x))
mempty mempty mempty mempty mempty mempty) mempty mempty mempty mempty mempty mempty)
type RY master = Route master -> [(Text, Text)] -> Text type RY master = Route master -> [(Text, Text)] -> Text
@ -422,15 +421,15 @@ instance MonadBaseControl b m => MonadBaseControl b (WidgetT site m) where
type StM (WidgetT site m) a = StM m (a, GWData (Route site)) type StM (WidgetT site m) a = StM m (a, GWData (Route site))
liftBaseWith f = WidgetT $ \reader' -> liftBaseWith f = WidgetT $ \reader' ->
liftBaseWith $ \runInBase -> liftBaseWith $ \runInBase ->
liftM (\x -> (x, mempty)) fmap (\x -> (x, mempty))
(f $ runInBase . flip unWidgetT reader') (f $ runInBase . flip unWidgetT reader')
restoreM = WidgetT . const . restoreM restoreM = WidgetT . const . restoreM
#else #else
data StM (WidgetT site m) a = StW (StM m (a, GWData (Route site))) data StM (WidgetT site m) a = StW (StM m (a, GWData (Route site)))
liftBaseWith f = WidgetT $ \reader' -> liftBaseWith f = WidgetT $ \reader' ->
liftBaseWith $ \runInBase -> liftBaseWith $ \runInBase ->
liftM (\x -> (x, mempty)) fmap (\x -> (x, mempty))
(f $ liftM StW . runInBase . flip unWidgetT reader') (f $ fmap StW . runInBase . flip unWidgetT reader')
restoreM (StW base) = WidgetT $ const $ restoreM base restoreM (StW base) = WidgetT $ const $ restoreM base
#endif #endif
instance Monad m => MonadReader site (WidgetT site m) where instance Monad m => MonadReader site (WidgetT site m) where
@ -464,11 +463,11 @@ instance MonadMask m => MonadMask (WidgetT site m) where
where q u (WidgetT b) = WidgetT (u . b) where q u (WidgetT b) = WidgetT (u . b)
instance (Applicative m, MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (WidgetT site m) where instance (Applicative m, MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (WidgetT site m) where
liftResourceT f = WidgetT $ \hd -> liftIO $ fmap (, mempty) $ runInternalState f (handlerResource hd) liftResourceT f = WidgetT $ \hd -> liftIO $ (, mempty) <$> runInternalState f (handlerResource hd)
instance MonadIO m => MonadLogger (WidgetT site m) where instance MonadIO m => MonadLogger (WidgetT site m) where
monadLoggerLog a b c d = WidgetT $ \hd -> monadLoggerLog a b c d = WidgetT $ \hd ->
liftIO $ fmap (, mempty) $ rheLog (handlerEnv hd) a b c (toLogStr d) liftIO $ (, mempty) <$> rheLog (handlerEnv hd) a b c (toLogStr d)
#if MIN_VERSION_monad_logger(0, 3, 10) #if MIN_VERSION_monad_logger(0, 3, 10)
instance MonadIO m => MonadLoggerIO (WidgetT site m) where instance MonadIO m => MonadLoggerIO (WidgetT site m) where
@ -522,7 +521,7 @@ instance MonadBaseControl b m => MonadBaseControl b (HandlerT site m) where
data StM (HandlerT site m) a = StH (StM m a) data StM (HandlerT site m) a = StH (StM m a)
liftBaseWith f = HandlerT $ \reader' -> liftBaseWith f = HandlerT $ \reader' ->
liftBaseWith $ \runInBase -> liftBaseWith $ \runInBase ->
f $ liftM StH . runInBase . (\(HandlerT r) -> r reader') f $ fmap StH . runInBase . (\(HandlerT r) -> r reader')
restoreM (StH base) = HandlerT $ const $ restoreM base restoreM (StH base) = HandlerT $ const $ restoreM base
#endif #endif

21
yesod-core/Yesod/Core/Widget.hs
View File

@ -57,9 +57,12 @@ import Text.Cassius
import Text.Julius import Text.Julius
import Yesod.Routes.Class import Yesod.Routes.Class
import Yesod.Core.Handler (getMessageRender, getUrlRenderParams) import Yesod.Core.Handler (getMessageRender, getUrlRenderParams)
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif
import Control.Monad (liftM)
import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.IO.Class (MonadIO, liftIO)
import Text.Shakespeare.I18N (RenderMessage) import Text.Shakespeare.I18N (RenderMessage)
import Control.Monad (liftM)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Map as Map import qualified Data.Map as Map
import Language.Haskell.TH.Quote (QuasiQuoter) import Language.Haskell.TH.Quote (QuasiQuoter)
@ -232,7 +235,7 @@ rules = do
let ur f = do let ur f = do
let env = NP.Env let env = NP.Env
(Just $ helper [|getUrlRenderParams|]) (Just $ helper [|getUrlRenderParams|])
(Just $ helper [|liftM (toHtml .) getMessageRender|]) (Just $ helper [|fmap (toHtml .) getMessageRender|])
f env f env
return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b
@ -272,16 +275,16 @@ widgetToParentWidget (WidgetT f) = HandlerT $ \hd -> do
liftGWD :: (child -> parent) -> GWData child -> GWData parent liftGWD :: (child -> parent) -> GWData child -> GWData parent
liftGWD tp gwd = GWData liftGWD tp gwd = GWData
{ gwdBody = fixBody $ gwdBody gwd { gwdBody = fixBody $ gwdBody gwd
, gwdTitle = gwdTitle gwd , gwdTitle = gwdTitle gwd
, gwdScripts = fixUnique fixScript $ gwdScripts gwd , gwdScripts = fixUnique fixScript $ gwdScripts gwd
, gwdStylesheets = fixUnique fixStyle $ gwdStylesheets gwd , gwdStylesheets = fixUnique fixStyle $ gwdStylesheets gwd
, gwdCss = fmap fixCss $ gwdCss gwd , gwdCss = fixCss <$> gwdCss gwd
, gwdJavascript = fmap fixJS $ gwdJavascript gwd , gwdJavascript = fixJS <$> gwdJavascript gwd
, gwdHead = fixHead $ gwdHead gwd , gwdHead = fixHead $ gwdHead gwd
} }
where where
fixRender f route params = f (tp route) params fixRender f route = f (tp route)
fixBody (Body h) = Body $ h . fixRender fixBody (Body h) = Body $ h . fixRender
fixHead (Head h) = Head $ h . fixRender fixHead (Head h) = Head $ h . fixRender

1
yesod-core/Yesod/Routes/TH.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE TemplateHaskell #-}
module Yesod.Routes.TH module Yesod.Routes.TH
( module Yesod.Routes.TH.Types ( module Yesod.Routes.TH.Types
-- * Functions -- * Functions

6
yesod-core/Yesod/Routes/TH/RenderRoute.hs
View File

@ -55,7 +55,7 @@ mkRouteCons rttypes =
where where
con = NormalC (mkName name) con = NormalC (mkName name)
$ map (\x -> (notStrict, x)) $ map (\x -> (notStrict, x))
$ concat [singles, [ConT $ mkName name]] $ singles ++ [ConT $ mkName name]
singles = concatMap toSingle pieces singles = concatMap toSingle pieces
toSingle Static{} = [] toSingle Static{} = []
@ -99,7 +99,7 @@ mkRenderRouteClauses =
dyns <- replicateM cnt $ newName "dyn" dyns <- replicateM cnt $ newName "dyn"
sub <- sub <-
case resourceDispatch res of case resourceDispatch res of
Subsite{} -> fmap return $ newName "sub" Subsite{} -> return <$> newName "sub"
_ -> return [] _ -> return []
let pat = ConP (mkName $ resourceName res) $ map VarP $ dyns ++ sub let pat = ConP (mkName $ resourceName res) $ map VarP $ dyns ++ sub
@ -136,7 +136,7 @@ mkRenderRouteClauses =
mkPieces _ _ [] _ = [] mkPieces _ _ [] _ = []
mkPieces toText tsp (Static s:ps) dyns = toText s : mkPieces toText tsp ps dyns mkPieces toText tsp (Static s:ps) dyns = toText s : mkPieces toText tsp ps dyns
mkPieces toText tsp (Dynamic{}:ps) (d:dyns) = tsp `AppE` VarE d : mkPieces toText tsp ps dyns mkPieces toText tsp (Dynamic{}:ps) (d:dyns) = tsp `AppE` VarE d : mkPieces toText tsp ps dyns
mkPieces _ _ ((Dynamic _) : _) [] = error "mkPieces 120" mkPieces _ _ (Dynamic _ : _) [] = error "mkPieces 120"
-- | Generate the 'RenderRoute' instance. -- | Generate the 'RenderRoute' instance.
-- --

9
yesod-core/Yesod/Routes/TH/RouteAttrs.hs
View File

@ -10,6 +10,9 @@ import Yesod.Routes.Class
import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax
import Data.Set (fromList) import Data.Set (fromList)
import Data.Text (pack) import Data.Text (pack)
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif
mkRouteAttrsInstance :: Type -> [ResourceTree a] -> Q Dec mkRouteAttrsInstance :: Type -> [ResourceTree a] -> Q Dec
mkRouteAttrsInstance typ ress = do mkRouteAttrsInstance typ ress = do
@ -19,11 +22,11 @@ mkRouteAttrsInstance typ ress = do
] ]
goTree :: (Pat -> Pat) -> ResourceTree a -> Q [Clause] goTree :: (Pat -> Pat) -> ResourceTree a -> Q [Clause]
goTree front (ResourceLeaf res) = fmap return $ goRes front res goTree front (ResourceLeaf res) = return <$> goRes front res
goTree front (ResourceParent name _check pieces trees) = goTree front (ResourceParent name _check pieces trees) =
fmap concat $ mapM (goTree front') trees concat <$> mapM (goTree front') trees
where where
ignored = ((replicate toIgnore WildP ++) . return) ignored = (replicate toIgnore WildP ++) . return
toIgnore = length $ filter isDynamic pieces toIgnore = length $ filter isDynamic pieces
isDynamic Dynamic{} = True isDynamic Dynamic{} = True
isDynamic Static{} = False isDynamic Static{} = False

4
yesod-core/Yesod/Routes/TH/Types.hs
View File

@ -53,11 +53,11 @@ data Piece typ = Static String | Dynamic typ
deriving Show deriving Show
instance Functor Piece where instance Functor Piece where
fmap _ (Static s) = (Static s) fmap _ (Static s) = Static s
fmap f (Dynamic t) = Dynamic (f t) fmap f (Dynamic t) = Dynamic (f t)
instance Lift t => Lift (Piece t) where instance Lift t => Lift (Piece t) where
lift (Static s) = [|Static $(lift s)|] lift (Static s) = [|Static $(lift s)|]
lift (Dynamic t) = [|Dynamic $(lift t)|] lift (Dynamic t) = [|Dynamic $(lift t)|]
data Dispatch typ = data Dispatch typ =

2
yesod-core/test/YesodCoreTest/Cache.hs
View File

@ -13,8 +13,6 @@ import Yesod.Core
import Data.IORef.Lifted import Data.IORef.Lifted
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.ByteString.Lazy.Char8 as L8
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
data C = C data C = C

4
yesod-core/test/YesodCoreTest/ErrorHandling.hs
View File

@ -9,11 +9,10 @@ import Yesod.Core
import Test.Hspec import Test.Hspec
import Network.Wai import Network.Wai
import Network.Wai.Test import Network.Wai.Test
import Text.Hamlet (hamlet)
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Char8 as S8
import Control.Exception (SomeException, try) import Control.Exception (SomeException, try)
import Network.HTTP.Types (mkStatus) import Network.HTTP.Types (Status, mkStatus)
import Blaze.ByteString.Builder (Builder, fromByteString, toLazyByteString) import Blaze.ByteString.Builder (Builder, fromByteString, toLazyByteString)
import Data.Monoid (mconcat) import Data.Monoid (mconcat)
import Data.Text (Text, pack) import Data.Text (Text, pack)
@ -40,6 +39,7 @@ mkYesod "App" [parseRoutes|
/good-builder GoodBuilderR GET /good-builder GoodBuilderR GET
|] |]
overrideStatus :: Status
overrideStatus = mkStatus 15 "OVERRIDE" overrideStatus = mkStatus 15 "OVERRIDE"
instance Yesod App where instance Yesod App where

3
yesod-core/test/YesodCoreTest/InternalRequest.hs
View File

@ -2,10 +2,7 @@
module YesodCoreTest.InternalRequest (internalRequestTest) where module YesodCoreTest.InternalRequest (internalRequestTest) where
import Data.List (nub) import Data.List (nub)
import System.Random (StdGen, mkStdGen)
import Network.Wai as W import Network.Wai as W
import Network.Wai.Test
import Yesod.Core.Internal (randomString, parseWaiRequest) import Yesod.Core.Internal (randomString, parseWaiRequest)
import Test.Hspec import Test.Hspec
import Data.Monoid (mempty) import Data.Monoid (mempty)

1
yesod-core/test/YesodCoreTest/Links.hs
View File

@ -6,7 +6,6 @@ module YesodCoreTest.Links (linksTest, Widget) where
import Test.Hspec import Test.Hspec
import Yesod.Core import Yesod.Core
import Text.Hamlet
import Network.Wai import Network.Wai
import Network.Wai.Test import Network.Wai.Test
import Data.Text (Text) import Data.Text (Text)

1
yesod-core/test/YesodCoreTest/Media.hs
View File

@ -8,7 +8,6 @@ import Test.Hspec
import Yesod.Core import Yesod.Core
import Network.Wai import Network.Wai
import Network.Wai.Test import Network.Wai.Test
import Text.Lucius
import YesodCoreTest.MediaData import YesodCoreTest.MediaData
mkYesodDispatch "Y" resourcesY mkYesodDispatch "Y" resourcesY

1
yesod-core/test/YesodCoreTest/NoOverloadedStringsSub.hs
View File

@ -8,7 +8,6 @@
module YesodCoreTest.NoOverloadedStringsSub where module YesodCoreTest.NoOverloadedStringsSub where
import Yesod.Core import Yesod.Core
import Network.Wai
import Yesod.Core.Types import Yesod.Core.Types
data Subsite = Subsite (forall master. Yesod master => YesodSubRunnerEnv Subsite master (HandlerT master IO) -> Application) data Subsite = Subsite (forall master. Yesod master => YesodSubRunnerEnv Subsite master (HandlerT master IO) -> Application)

4
yesod-core/test/YesodCoreTest/Widget.hs
View File

@ -6,10 +6,6 @@ module YesodCoreTest.Widget (widgetTest) where
import Test.Hspec import Test.Hspec
import Yesod.Core import Yesod.Core
import Text.Julius
import Text.Lucius
import Text.Hamlet
import Network.Wai import Network.Wai
import Network.Wai.Test import Network.Wai.Test