Merge pull request #1243 from mschristiansen/master
Cleanup of yesod-core code
This commit is contained in:
Michael Snoyman
GitHub
commit
8bbe91cbfe
@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
@ -134,11 +133,10 @@ import Text.Blaze.Html (Html, toHtml, preEscapedToMarkup)
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Trans.Class (MonadTrans (..))
|
||||
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.Dispatch
|
||||
import Yesod.Core.Class.Breadcrumbs
|
||||
import Yesod.Core.Internal.Run (yesodRender)
|
||||
import qualified Yesod.Core.Internal.Run
|
||||
import qualified Paths_yesod_core
|
||||
import Data.Version (showVersion)
|
||||
|
||||
@ -1,7 +1,6 @@
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
@ -25,10 +24,9 @@ class YesodSubDispatch sub m where
|
||||
-> W.Application
|
||||
|
||||
instance YesodSubDispatch WaiSubsite master where
|
||||
yesodSubDispatch YesodSubRunnerEnv {..} req =
|
||||
app req
|
||||
yesodSubDispatch YesodSubRunnerEnv {..} = app
|
||||
where
|
||||
WaiSubsite app = ysreGetSub $ yreSite $ ysreParentEnv
|
||||
WaiSubsite app = ysreGetSub $ yreSite ysreParentEnv
|
||||
|
||||
-- | A helper function for creating YesodSubDispatch instances, used by the
|
||||
-- internal generated code. This function has been exported since 1.4.11.
|
||||
|
||||
@ -5,7 +5,6 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Yesod.Core.Class.Yesod where
|
||||
|
||||
import Control.Monad.Logger (logErrorS)
|
||||
import Yesod.Core.Content
|
||||
import Yesod.Core.Handler
|
||||
|
||||
@ -15,16 +14,18 @@ import Blaze.ByteString.Builder (Builder)
|
||||
import Blaze.ByteString.Builder.Char.Utf8 (fromText)
|
||||
import Control.Arrow ((***), second)
|
||||
import Control.Exception (bracket)
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
import Control.Applicative ((<$>))
|
||||
#endif
|
||||
import Control.Monad (forM, when, void)
|
||||
import Control.Monad.IO.Class (MonadIO (liftIO))
|
||||
import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther),
|
||||
LogSource)
|
||||
LogSource, logErrorS)
|
||||
import Control.Monad.Trans.Resource (InternalState, createInternalState, closeInternalState)
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Data.Aeson (object, (.=))
|
||||
import Data.List (foldl')
|
||||
import Data.List (nub)
|
||||
import Data.List (foldl', nub)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Monoid
|
||||
import Data.Text (Text)
|
||||
@ -43,14 +44,13 @@ import Network.Wai.Parse (lbsBackEnd,
|
||||
import Network.Wai.Logger (ZonedDate, clockDateCacher)
|
||||
import System.Log.FastLogger
|
||||
import Text.Blaze (customAttribute, textTag,
|
||||
toValue, (!))
|
||||
import Text.Blaze (preEscapedToMarkup)
|
||||
toValue, (!),
|
||||
preEscapedToMarkup)
|
||||
import qualified Text.Blaze.Html5 as TBH
|
||||
import Text.Hamlet
|
||||
import Text.Julius
|
||||
import qualified Web.ClientSession as CS
|
||||
import Web.Cookie (parseCookies)
|
||||
import Web.Cookie (SetCookie (..))
|
||||
import Web.Cookie (SetCookie (..), parseCookies)
|
||||
import Yesod.Core.Types
|
||||
import Yesod.Core.Internal.Session
|
||||
import Yesod.Core.Widget
|
||||
@ -237,7 +237,7 @@ class RenderRoute site => Yesod site where
|
||||
--
|
||||
-- Default: Uses clientsession with a 2 hour timeout.
|
||||
makeSessionBackend :: site -> IO (Maybe SessionBackend)
|
||||
makeSessionBackend _ = fmap Just $ defaultClientSessionBackend 120 CS.defaultKeyFile
|
||||
makeSessionBackend _ = Just <$> defaultClientSessionBackend 120 CS.defaultKeyFile
|
||||
|
||||
-- | How to store uploaded files.
|
||||
--
|
||||
@ -388,8 +388,7 @@ sslOnlyMiddleware timeout handler = do
|
||||
--
|
||||
-- Since 1.2.0
|
||||
authorizationCheck :: Yesod site => HandlerT site IO ()
|
||||
authorizationCheck = do
|
||||
getCurrentRoute >>= maybe (return ()) checkUrl
|
||||
authorizationCheck = getCurrentRoute >>= maybe (return ()) checkUrl
|
||||
where
|
||||
checkUrl url = do
|
||||
isWrite <- isWriteRequest url
|
||||
@ -399,21 +398,21 @@ authorizationCheck = do
|
||||
AuthenticationRequired -> do
|
||||
master <- getYesod
|
||||
case authRoute master of
|
||||
Nothing -> void $ notAuthenticated
|
||||
Just url' -> do
|
||||
Nothing -> void notAuthenticated
|
||||
Just url' ->
|
||||
void $ selectRep $ do
|
||||
provideRepType typeHtml $ do
|
||||
setUltDestCurrent
|
||||
void $ redirect url'
|
||||
provideRepType typeJson $
|
||||
void $ notAuthenticated
|
||||
void notAuthenticated
|
||||
Unauthorized s' -> permissionDenied s'
|
||||
|
||||
-- | Calls 'csrfCheckMiddleware' with 'isWriteRequest', 'defaultCsrfHeaderName', and 'defaultCsrfParamName' as parameters.
|
||||
--
|
||||
-- Since 1.4.14
|
||||
defaultCsrfCheckMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO res
|
||||
defaultCsrfCheckMiddleware handler = do
|
||||
defaultCsrfCheckMiddleware handler =
|
||||
csrfCheckMiddleware
|
||||
handler
|
||||
(getCurrentRoute >>= maybe (return False) isWriteRequest)
|
||||
@ -592,12 +591,9 @@ defaultErrorHandler NotAuthenticated = selectRep $ do
|
||||
-- The client will just use the authentication_url in the JSON
|
||||
site <- getYesod
|
||||
rend <- getUrlRender
|
||||
return $ object $ [
|
||||
"message" .= ("Not logged in"::Text)
|
||||
] ++
|
||||
case authRoute site of
|
||||
Nothing -> []
|
||||
Just url -> ["authentication_url" .= rend url]
|
||||
let apair u = ["authentication_url" .= rend u]
|
||||
content = maybe [] apair (authRoute site)
|
||||
return $ object $ ("message" .= ("Not logged in"::Text)):content
|
||||
|
||||
defaultErrorHandler (PermissionDenied msg) = selectRep $ do
|
||||
provideRep $ defaultLayout $ do
|
||||
@ -607,9 +603,7 @@ defaultErrorHandler (PermissionDenied msg) = selectRep $ do
|
||||
<p>#{msg}
|
||||
|]
|
||||
provideRep $
|
||||
return $ object $ [
|
||||
"message" .= ("Permission Denied. " <> msg)
|
||||
]
|
||||
return $ object ["message" .= ("Permission Denied. " <> msg)]
|
||||
|
||||
defaultErrorHandler (InvalidArgs ia) = selectRep $ 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]
|
||||
|
||||
asyncHelper :: (url -> [x] -> Text)
|
||||
-> [Script (url)]
|
||||
-> Maybe (JavascriptUrl (url))
|
||||
-> [Script url]
|
||||
-> Maybe (JavascriptUrl url)
|
||||
-> Maybe Text
|
||||
-> (Maybe (HtmlUrl url), [Text])
|
||||
asyncHelper render scripts jscript jsLoc =
|
||||
@ -732,8 +726,7 @@ defaultClientSessionBackend :: Int -- ^ minutes
|
||||
-> IO SessionBackend
|
||||
defaultClientSessionBackend minutes fp = do
|
||||
key <- CS.getKey fp
|
||||
let timeout = fromIntegral (minutes * 60)
|
||||
(getCachedDate, _closeDateCacher) <- clientSessionDateCacher timeout
|
||||
(getCachedDate, _closeDateCacher) <- clientSessionDateCacher (minToSec minutes)
|
||||
return $ clientSessionBackend key getCachedDate
|
||||
|
||||
-- | Create a @SessionBackend@ which reads the session key from the named
|
||||
@ -759,10 +752,12 @@ envClientSessionBackend :: Int -- ^ minutes
|
||||
-> IO SessionBackend
|
||||
envClientSessionBackend minutes name = do
|
||||
key <- CS.getKeyEnv name
|
||||
let timeout = fromIntegral (minutes * 60)
|
||||
(getCachedDate, _closeDateCacher) <- clientSessionDateCacher timeout
|
||||
(getCachedDate, _closeDateCacher) <- clientSessionDateCacher $ minToSec minutes
|
||||
return $ clientSessionBackend key getCachedDate
|
||||
|
||||
minToSec :: (Integral a, Num b) => a -> b
|
||||
minToSec minutes = fromIntegral (minutes * 60)
|
||||
|
||||
jsToHtml :: Javascript -> Html
|
||||
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
|
||||
-- leaving out the loc_end parameter
|
||||
fileLocationToString :: Loc -> String
|
||||
fileLocationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++
|
||||
' ' : (loc_filename loc) ++ ':' : (line loc) ++ ':' : (char loc)
|
||||
fileLocationToString loc =
|
||||
concat
|
||||
[ loc_package loc
|
||||
, ':' : loc_module loc
|
||||
, ' ' : loc_filename loc
|
||||
, ':' : line loc
|
||||
, ':' : char loc
|
||||
]
|
||||
where
|
||||
line = show . fst . loc_start
|
||||
char = show . snd . loc_start
|
||||
|
||||
@ -53,8 +53,6 @@ import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Data.Text.Lazy (Text, pack)
|
||||
import qualified Data.Text as T
|
||||
import Control.Monad (liftM)
|
||||
|
||||
import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
import Data.Monoid (mempty)
|
||||
@ -62,6 +60,7 @@ import Data.Monoid (mempty)
|
||||
import Text.Hamlet (Html)
|
||||
import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
|
||||
import Data.Conduit (Source, Flush (Chunk), ResumableSource, mapOutput)
|
||||
import Control.Monad (liftM)
|
||||
import Control.Monad.Trans.Resource (ResourceT)
|
||||
import Data.Conduit.Internal (ResumableSource (ResumableSource))
|
||||
import qualified Data.Conduit.Internal as CI
|
||||
|
||||
@ -85,7 +85,7 @@ toWaiAppPlain site = do
|
||||
sb <- makeSessionBackend site
|
||||
gen <- MWC.createSystemRandom
|
||||
getMaxExpires <- getGetMaxExpires
|
||||
return $ toWaiAppYre $ YesodRunnerEnv
|
||||
return $ toWaiAppYre YesodRunnerEnv
|
||||
{ yreLogger = logger
|
||||
, yreSite = site
|
||||
, yreSessionBackend = sb
|
||||
@ -119,8 +119,8 @@ toWaiAppYre yre req =
|
||||
dest' =
|
||||
if S.null (W.rawQueryString env)
|
||||
then dest
|
||||
else (dest `mappend`
|
||||
Blaze.ByteString.Builder.fromByteString (W.rawQueryString env))
|
||||
else dest `mappend`
|
||||
Blaze.ByteString.Builder.fromByteString (W.rawQueryString env)
|
||||
|
||||
-- | Same as 'toWaiAppPlain', but provides a default set of middlewares. This
|
||||
-- set may change with future releases, but currently covers:
|
||||
@ -184,7 +184,7 @@ warp port site = do
|
||||
$(qLocation >>= liftLoc)
|
||||
"yesod-core"
|
||||
LevelError
|
||||
(toLogStr $ "Exception from Warp: " ++ show e)) $
|
||||
(toLogStr $ "Exception from Warp: " ++ show e))
|
||||
Network.Wai.Handler.Warp.defaultSettings)
|
||||
where
|
||||
shouldLog' = Network.Wai.Handler.Warp.defaultShouldDisplayException
|
||||
@ -231,7 +231,7 @@ warpEnv :: YesodDispatch site => site -> IO ()
|
||||
warpEnv site = do
|
||||
env <- getEnvironment
|
||||
case lookup "PORT" env of
|
||||
Nothing -> error $ "warpEnv: no PORT environment variable found"
|
||||
Nothing -> error "warpEnv: no PORT environment variable found"
|
||||
Just portS ->
|
||||
case readMay portS of
|
||||
Nothing -> error $ "warpEnv: invalid PORT environment variable: " ++ show portS
|
||||
|
||||
@ -189,10 +189,10 @@ import Control.Applicative ((<$>))
|
||||
import Data.Monoid (mempty, mappend)
|
||||
#endif
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Exception (evaluate, SomeException)
|
||||
import Control.Exception (evaluate, SomeException, throwIO)
|
||||
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 Control.Monad.IO.Class (MonadIO, liftIO)
|
||||
@ -235,24 +235,19 @@ import Web.PathPieces (PathPiece(..))
|
||||
import Yesod.Core.Class.Handler
|
||||
import Yesod.Core.Types
|
||||
import Yesod.Routes.Class (Route)
|
||||
import Control.Exception (throwIO)
|
||||
import Blaze.ByteString.Builder (Builder)
|
||||
import Safe (headMay)
|
||||
import Data.CaseInsensitive (CI)
|
||||
import Blaze.ByteString.Builder (Builder)
|
||||
import Safe (headMay)
|
||||
import Data.CaseInsensitive (CI)
|
||||
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 Control.Monad.Trans.Control (control, MonadBaseControl)
|
||||
import Data.Conduit (Source, transPipe, Flush (Flush), yield, Producer
|
||||
, Sink
|
||||
)
|
||||
import Control.Monad.Trans.Control (control, MonadBaseControl)
|
||||
import Data.Conduit (Source, transPipe, Flush (Flush), yield, Producer, Sink)
|
||||
import qualified Yesod.Core.TypeCache as Cache
|
||||
import qualified Data.Word8 as W8
|
||||
import qualified Data.Foldable as Fold
|
||||
import Data.Default
|
||||
import Control.Monad.Logger (MonadLogger, logWarnS)
|
||||
import Data.Default
|
||||
import Control.Monad.Logger (MonadLogger, logWarnS)
|
||||
|
||||
get :: MonadHandler m => m GHState
|
||||
get = liftHandlerT $ HandlerT $ I.readIORef . handlerState
|
||||
@ -305,7 +300,7 @@ rbHelper' :: NWP.BackEnd x
|
||||
-> W.Request
|
||||
-> IO ([(Text, Text)], [(Text, FileInfo)])
|
||||
rbHelper' backend mkFI req =
|
||||
(map fix1 *** mapMaybe fix2) <$> (NWP.parseRequestBody backend req)
|
||||
(map fix1 *** mapMaybe fix2) <$> NWP.parseRequestBody backend req
|
||||
where
|
||||
fix1 = go *** go
|
||||
fix2 (x, NWP.FileInfo a' b c)
|
||||
@ -324,29 +319,29 @@ askHandlerEnv = liftHandlerT $ HandlerT $ return . handlerEnv
|
||||
|
||||
-- | Get the master site application argument.
|
||||
getYesod :: MonadHandler m => m (HandlerSite m)
|
||||
getYesod = rheSite `liftM` askHandlerEnv
|
||||
getYesod = rheSite <$> askHandlerEnv
|
||||
|
||||
-- | Get a specific component of the master site application argument.
|
||||
-- Analogous to the 'gets' function for operating on 'StateT'.
|
||||
getsYesod :: MonadHandler m => (HandlerSite m -> a) -> m a
|
||||
getsYesod f = (f . rheSite) `liftM` askHandlerEnv
|
||||
getsYesod f = (f . rheSite) <$> askHandlerEnv
|
||||
|
||||
-- | Get the URL rendering function.
|
||||
getUrlRender :: MonadHandler m => m (Route (HandlerSite m) -> Text)
|
||||
getUrlRender = do
|
||||
x <- rheRender `liftM` askHandlerEnv
|
||||
x <- rheRender <$> askHandlerEnv
|
||||
return $ flip x []
|
||||
|
||||
-- | The URL rendering function with query-string parameters.
|
||||
getUrlRenderParams
|
||||
:: MonadHandler m
|
||||
=> 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
|
||||
-- user requested an invalid route- this function will return 'Nothing'.
|
||||
getCurrentRoute :: MonadHandler m => m (Maybe (Route (HandlerSite m)))
|
||||
getCurrentRoute = rheRoute `liftM` askHandlerEnv
|
||||
getCurrentRoute = rheRoute <$> askHandlerEnv
|
||||
|
||||
-- | Returns a function that runs 'HandlerT' actions inside @IO@.
|
||||
--
|
||||
@ -487,7 +482,7 @@ setUltDestCurrent = do
|
||||
case route of
|
||||
Nothing -> return ()
|
||||
Just r -> do
|
||||
gets' <- reqGetParams `liftM` getRequest
|
||||
gets' <- reqGetParams <$> getRequest
|
||||
setUltDest (r, gets')
|
||||
|
||||
-- | 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)
|
||||
msg' = S.append
|
||||
(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
|
||||
--
|
||||
@ -568,7 +563,7 @@ getMessages = do
|
||||
where
|
||||
enlist = pairup . S.split W8._nul
|
||||
pairup [] = []
|
||||
pairup [x] = []
|
||||
pairup [_] = []
|
||||
pairup (s:v:xs) = (decode s, preEscapedToHtml (decode v)) : pairup xs
|
||||
decode = decodeUtf8With lenientDecode
|
||||
|
||||
@ -584,7 +579,7 @@ setMessageI = addMessageI ""
|
||||
-- | Gets just the last message in the user's session,
|
||||
-- discards the rest and the status
|
||||
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.
|
||||
--
|
||||
@ -657,7 +652,7 @@ sendRawResponseNoConduit
|
||||
-> m a
|
||||
sendRawResponseNoConduit raw = control $ \runInIO ->
|
||||
liftIO $ throwIO $ HCWai $ flip W.responseRaw fallback
|
||||
$ \src sink -> runInIO (raw src sink) >> return ()
|
||||
$ \src sink -> void $ runInIO (raw src sink)
|
||||
where
|
||||
fallback = W.responseLBS H.status500 [("Content-Type", "text/plain")]
|
||||
"sendRawResponse: backend does not support raw responses"
|
||||
@ -672,7 +667,7 @@ sendRawResponse :: (MonadHandler m, MonadBaseControl IO m)
|
||||
-> m a
|
||||
sendRawResponse raw = control $ \runInIO ->
|
||||
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
|
||||
fallback = W.responseLBS H.status500 [("Content-Type", "text/plain")]
|
||||
"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.
|
||||
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.
|
||||
lookupSessionBS :: MonadHandler m => Text -> m (Maybe S.ByteString)
|
||||
lookupSessionBS n = do
|
||||
m <- liftM ghsSession get
|
||||
m <- fmap ghsSession get
|
||||
return $ Map.lookup n m
|
||||
|
||||
-- | Get all session variables.
|
||||
getSession :: MonadHandler m => m SessionMap
|
||||
getSession = liftM ghsSession get
|
||||
getSession = fmap ghsSession get
|
||||
|
||||
-- | Get a unique identifier.
|
||||
newIdent :: MonadHandler m => m Text
|
||||
@ -976,13 +971,13 @@ withUrlRenderer f = do
|
||||
|
||||
-- | Get the request\'s 'W.Request' value.
|
||||
waiRequest :: MonadHandler m => m W.Request
|
||||
waiRequest = reqWaiRequest `liftM` getRequest
|
||||
waiRequest = reqWaiRequest <$> getRequest
|
||||
|
||||
getMessageRender :: (MonadHandler m, RenderMessage (HandlerSite m) message)
|
||||
=> m (message -> Text)
|
||||
getMessageRender = do
|
||||
env <- askHandlerEnv
|
||||
l <- reqLangs `liftM` getRequest
|
||||
l <- reqLangs <$> getRequest
|
||||
return $ renderMessage (rheSite env) l
|
||||
|
||||
-- | 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).
|
||||
languages :: MonadHandler m => m [Text]
|
||||
languages = reqLangs `liftM` getRequest
|
||||
languages = reqLangs <$> getRequest
|
||||
|
||||
lookup' :: Eq a => a -> [(a, b)] -> [b]
|
||||
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
|
||||
lookupHeader :: MonadHandler m => CI S8.ByteString -> m (Maybe S8.ByteString)
|
||||
lookupHeader = liftM listToMaybe . lookupHeaders
|
||||
lookupHeader = fmap listToMaybe . lookupHeaders
|
||||
|
||||
-- | Lookup a request header.
|
||||
--
|
||||
@ -1069,11 +1064,9 @@ lookupHeaders key = do
|
||||
--
|
||||
-- Since 1.4.9
|
||||
lookupBasicAuth :: (MonadHandler m) => m (Maybe (Text, Text))
|
||||
lookupBasicAuth = fmap (>>= getBA)
|
||||
(lookupHeader "Authorization")
|
||||
lookupBasicAuth = fmap (>>= getBA) (lookupHeader "Authorization")
|
||||
where
|
||||
getBA bs = (\(x, y) -> ( decodeUtf8With lenientDecode x
|
||||
, decodeUtf8With lenientDecode y))
|
||||
getBA bs = (decodeUtf8With lenientDecode *** decodeUtf8With lenientDecode)
|
||||
<$> extractBasicAuth bs
|
||||
|
||||
-- | Lookup bearer authentication datafrom __Authorization__ header of
|
||||
@ -1096,7 +1089,7 @@ lookupGetParams pn = do
|
||||
|
||||
-- | Lookup for GET parameters.
|
||||
lookupGetParam :: MonadHandler m => Text -> m (Maybe Text)
|
||||
lookupGetParam = liftM listToMaybe . lookupGetParams
|
||||
lookupGetParam = fmap listToMaybe . lookupGetParams
|
||||
|
||||
-- | Lookup for POST parameters.
|
||||
lookupPostParams :: (MonadResource m, MonadHandler m) => Text -> m [Text]
|
||||
@ -1107,13 +1100,13 @@ lookupPostParams pn = do
|
||||
lookupPostParam :: (MonadResource m, MonadHandler m)
|
||||
=> Text
|
||||
-> m (Maybe Text)
|
||||
lookupPostParam = liftM listToMaybe . lookupPostParams
|
||||
lookupPostParam = fmap listToMaybe . lookupPostParams
|
||||
|
||||
-- | Lookup for POSTed files.
|
||||
lookupFile :: (MonadHandler m, MonadResource m)
|
||||
=> Text
|
||||
-> m (Maybe FileInfo)
|
||||
lookupFile = liftM listToMaybe . lookupFiles
|
||||
lookupFile = fmap listToMaybe . lookupFiles
|
||||
|
||||
-- | Lookup for POSTed files.
|
||||
lookupFiles :: (MonadHandler m, MonadResource m)
|
||||
@ -1125,7 +1118,7 @@ lookupFiles pn = do
|
||||
|
||||
-- | Lookup for cookie data.
|
||||
lookupCookie :: MonadHandler m => Text -> m (Maybe Text)
|
||||
lookupCookie = liftM listToMaybe . lookupCookies
|
||||
lookupCookie = fmap listToMaybe . lookupCookies
|
||||
|
||||
-- | Lookup for cookie data.
|
||||
lookupCookies :: MonadHandler m => Text -> m [Text]
|
||||
@ -1160,7 +1153,7 @@ selectRep :: MonadHandler m
|
||||
selectRep w = do
|
||||
-- the content types are already sorted by q values
|
||||
-- which have been stripped
|
||||
cts <- liftM reqAccept getRequest
|
||||
cts <- fmap reqAccept getRequest
|
||||
|
||||
case mapMaybe tryAccept cts of
|
||||
[] ->
|
||||
@ -1175,8 +1168,7 @@ selectRep w = do
|
||||
explainUnaccepted :: Text
|
||||
explainUnaccepted = "no match found for accept header"
|
||||
|
||||
returnRep (ProvidedRep ct mcontent) =
|
||||
mcontent >>= return . TypedContent ct
|
||||
returnRep (ProvidedRep ct mcontent) = fmap (TypedContent ct) mcontent
|
||||
|
||||
reps = appEndo (Writer.execWriter w) []
|
||||
|
||||
@ -1235,7 +1227,7 @@ provideRepType :: (Monad m, ToContent a)
|
||||
-> m a
|
||||
-> Writer.Writer (Endo [ProvidedRep m]) ()
|
||||
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.
|
||||
--
|
||||
|
||||
@ -1,5 +1,4 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings, CPP #-}
|
||||
module Yesod.Core.Internal.Request
|
||||
( parseWaiRequest
|
||||
, RequestBodyContents
|
||||
@ -37,7 +36,7 @@ import Data.Text.Encoding.Error (lenientDecode)
|
||||
import Data.Conduit
|
||||
import Data.Conduit.List (sourceList)
|
||||
import Data.Conduit.Binary (sourceFile, sinkFile)
|
||||
import Data.Word (Word64)
|
||||
import Data.Word (Word8, Word64)
|
||||
import Control.Monad.Trans.Resource (runResourceT, ResourceT)
|
||||
import Control.Exception (throwIO)
|
||||
import Control.Monad ((<=<), liftM)
|
||||
@ -47,7 +46,6 @@ import Data.IORef
|
||||
import qualified System.Random.MWC as MWC
|
||||
import Control.Monad.Primitive (PrimMonad, PrimState)
|
||||
import qualified Data.Vector.Storable as V
|
||||
import Data.Word (Word8)
|
||||
import Data.ByteString.Internal (ByteString (PS))
|
||||
import qualified Data.Word8 as Word8
|
||||
|
||||
@ -78,7 +76,7 @@ parseWaiRequest :: W.Request
|
||||
-> SessionMap
|
||||
-> Bool
|
||||
-> Maybe Word64 -- ^ max body size
|
||||
-> (Either (IO YesodRequest) (MWC.GenIO -> IO YesodRequest))
|
||||
-> Either (IO YesodRequest) (MWC.GenIO -> IO YesodRequest)
|
||||
parseWaiRequest env session useToken mmaxBodySize =
|
||||
-- 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
|
||||
@ -147,7 +145,7 @@ httpAccept = NWP.parseHttpAccept
|
||||
|
||||
addTwoLetters :: ([Text] -> [Text], Set.Set Text) -> [Text] -> [Text]
|
||||
addTwoLetters (toAdd, exist) [] =
|
||||
filter (flip Set.notMember exist) $ toAdd []
|
||||
filter (`Set.notMember` exist) $ toAdd []
|
||||
addTwoLetters (toAdd, exist) (l:ls) =
|
||||
l : addTwoLetters (toAdd', exist') ls
|
||||
where
|
||||
@ -177,7 +175,8 @@ fromByteVector v =
|
||||
{-# INLINE fromByteVector #-}
|
||||
|
||||
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 name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runResourceT $ sourceFile fp $$ sinkFile dst)
|
||||
|
||||
@ -1,19 +1,15 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module Yesod.Core.Internal.Response where
|
||||
|
||||
import Blaze.ByteString.Builder (toByteString)
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as S
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Network.Wai
|
||||
import Data.Conduit (transPipe)
|
||||
import Control.Monad (mplus)
|
||||
import Control.Monad.Trans.Resource (runInternalState, InternalState)
|
||||
import Network.Wai.Internal
|
||||
#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 Control.Exception (SomeException, handle)
|
||||
import Blaze.ByteString.Builder (fromLazyByteString,
|
||||
toLazyByteString)
|
||||
toLazyByteString, toByteString)
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.Map as Map
|
||||
import Yesod.Core.Internal.Request (tokenKey)
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Data.Conduit (Flush (..), ($$))
|
||||
import Data.Conduit (Flush (..), ($$), transPipe)
|
||||
import qualified Data.Conduit.List as CL
|
||||
|
||||
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 hs' = maybe finalHeaders finalHeaders' mlen
|
||||
sendResponse $ ResponseBuilder s hs' b
|
||||
go (ContentFile fp p) = do
|
||||
sendResponse $ ResponseFile s finalHeaders fp p
|
||||
go (ContentFile fp p) = sendResponse $ ResponseFile s finalHeaders fp p
|
||||
go (ContentSource body) = sendResponse $ responseStream s finalHeaders
|
||||
$ \sendChunk flush -> do
|
||||
transPipe (flip runInternalState is) body
|
||||
$ \sendChunk flush ->
|
||||
transPipe (`runInternalState` is) body
|
||||
$$ CL.mapM_ (\mchunk ->
|
||||
case mchunk of
|
||||
Flush -> flush
|
||||
@ -91,7 +86,7 @@ defaultStatus = H.mkStatus (-1) "INVALID DEFAULT STATUS"
|
||||
headerToPair :: Header
|
||||
-> (CI ByteString, ByteString)
|
||||
headerToPair (AddCookie sc) =
|
||||
("Set-Cookie", toByteString $ renderSetCookie $ sc)
|
||||
("Set-Cookie", toByteString $ renderSetCookie sc)
|
||||
headerToPair (DeleteCookie key path) =
|
||||
( "Set-Cookie"
|
||||
, S.concat
|
||||
@ -107,7 +102,7 @@ evaluateContent :: Content -> IO (Either ErrorResponse Content)
|
||||
evaluateContent (ContentBuilder b mlen) = handle f $ do
|
||||
let lbs = toLazyByteString b
|
||||
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')
|
||||
where
|
||||
f :: SomeException -> IO (Either ErrorResponse Content)
|
||||
|
||||
@ -11,6 +11,7 @@ module Yesod.Core.Internal.Run where
|
||||
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
import Data.Monoid (Monoid, mempty)
|
||||
import Control.Applicative ((<$>))
|
||||
#endif
|
||||
import Yesod.Core.Internal.Response
|
||||
import Blaze.ByteString.Builder (toByteString)
|
||||
@ -102,7 +103,7 @@ basicRunHandler rhe handler yreq resState = do
|
||||
(\e ->
|
||||
case fromException e of
|
||||
Just e' -> return e'
|
||||
Nothing -> fmap HCError $ toErrorHandler e)
|
||||
Nothing -> HCError <$> toErrorHandler e)
|
||||
|
||||
-- Get the raw state and return
|
||||
state <- I.readIORef istate
|
||||
@ -330,7 +331,7 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse
|
||||
| otherwise = do
|
||||
let dontSaveSession _ = return []
|
||||
(session, saveSession) <- liftIO $
|
||||
maybe (return (Map.empty, dontSaveSession)) (\sb -> sbLoadSession sb req) yreSessionBackend
|
||||
maybe (return (Map.empty, dontSaveSession)) (`sbLoadSession` req) yreSessionBackend
|
||||
maxExpires <- yreGetMaxExpires
|
||||
let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend) mmaxLen
|
||||
let yreq =
|
||||
|
||||
@ -11,11 +11,9 @@ import qualified Web.ClientSession as CS
|
||||
import Data.Serialize
|
||||
import Data.Time
|
||||
import Data.ByteString (ByteString)
|
||||
import Control.Concurrent (forkIO, killThread, threadDelay)
|
||||
import Control.Monad (forever, guard)
|
||||
import Control.Monad (guard)
|
||||
import Yesod.Core.Types
|
||||
import Yesod.Core.Internal.Util
|
||||
import qualified Data.IORef as I
|
||||
import Control.AutoUpdate
|
||||
|
||||
encodeClientSession :: CS.Key
|
||||
@ -63,7 +61,7 @@ clientSessionDateCacher validity = do
|
||||
, updateFreq = 10000000 -- 10s
|
||||
}
|
||||
|
||||
return $! (getClientSessionDateCache, return ())
|
||||
return (getClientSessionDateCache, return ())
|
||||
where
|
||||
getUpdated = do
|
||||
now <- getCurrentTime
|
||||
|
||||
@ -16,7 +16,10 @@ import qualified Network.Wai as W
|
||||
|
||||
import Data.ByteString.Lazy.Char8 ()
|
||||
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 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
|
||||
-- 'mkYesodDispatch', to do just that.
|
||||
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 name res = mkYesodDataGeneral name True res
|
||||
mkYesodSubData name = mkYesodDataGeneral name True
|
||||
|
||||
mkYesodDataGeneral :: String -> Bool -> [ResourceTree String] -> Q [Dec]
|
||||
mkYesodDataGeneral name isSub res = do
|
||||
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'.
|
||||
mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
|
||||
@ -150,8 +153,8 @@ mkMDS f rh = MkDispatchSettings
|
||||
, mdsGetPathInfo = [|W.pathInfo|]
|
||||
, mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]
|
||||
, mdsMethod = [|W.requestMethod|]
|
||||
, mds404 = [|notFound >> return ()|]
|
||||
, mds405 = [|badMethod >> return ()|]
|
||||
, mds404 = [|void notFound|]
|
||||
, mds405 = [|void badMethod|]
|
||||
, mdsGetHandler = defaultGetHandler
|
||||
, mdsUnwrapper = f
|
||||
}
|
||||
|
||||
@ -14,8 +14,6 @@ import qualified Data.Text as T
|
||||
import Data.Time (Day (ModifiedJulianDay, toModifiedJulianDay),
|
||||
DiffTime, UTCTime (..), formatTime,
|
||||
getCurrentTime, addUTCTime)
|
||||
import Control.Monad (liftM)
|
||||
|
||||
#if MIN_VERSION_time(1,5,0)
|
||||
import Data.Time (defaultTimeLocale)
|
||||
#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.
|
||||
-}
|
||||
getCurrentMaxExpiresRFC1123 :: IO T.Text
|
||||
getCurrentMaxExpiresRFC1123 = liftM (formatRFC1123 . addUTCTime (60*60*24*365)) getCurrentTime
|
||||
getCurrentMaxExpiresRFC1123 = fmap (formatRFC1123 . addUTCTime (60*60*24*365)) getCurrentTime
|
||||
|
||||
@ -20,8 +20,7 @@ import Control.Arrow (first)
|
||||
import Control.Exception (Exception)
|
||||
import Control.Monad (liftM, ap)
|
||||
import Control.Monad.Base (MonadBase (liftBase))
|
||||
import Control.Monad.Catch (MonadCatch (..))
|
||||
import Control.Monad.Catch (MonadMask (..))
|
||||
import Control.Monad.Catch (MonadMask (..), MonadCatch (..))
|
||||
import Control.Monad.IO.Class (MonadIO (liftIO))
|
||||
import Control.Monad.Logger (LogLevel, LogSource,
|
||||
MonadLogger (..))
|
||||
@ -172,7 +171,7 @@ data ScriptLoadPosition master
|
||||
type BottomOfHeadAsync master
|
||||
= [Text] -- ^ urls to load asynchronously
|
||||
-> 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]
|
||||
|
||||
@ -264,7 +263,7 @@ instance (a ~ (), Monad m) => Semigroup (WidgetT site m a)
|
||||
-- @getHomeR = do defaultLayout "Widget text"@
|
||||
instance (Monad m, a ~ ()) => IsString (WidgetT site m a) where
|
||||
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)
|
||||
|
||||
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))
|
||||
liftBaseWith f = WidgetT $ \reader' ->
|
||||
liftBaseWith $ \runInBase ->
|
||||
liftM (\x -> (x, mempty))
|
||||
fmap (\x -> (x, mempty))
|
||||
(f $ runInBase . flip unWidgetT reader')
|
||||
restoreM = WidgetT . const . restoreM
|
||||
#else
|
||||
data StM (WidgetT site m) a = StW (StM m (a, GWData (Route site)))
|
||||
liftBaseWith f = WidgetT $ \reader' ->
|
||||
liftBaseWith $ \runInBase ->
|
||||
liftM (\x -> (x, mempty))
|
||||
(f $ liftM StW . runInBase . flip unWidgetT reader')
|
||||
fmap (\x -> (x, mempty))
|
||||
(f $ fmap StW . runInBase . flip unWidgetT reader')
|
||||
restoreM (StW base) = WidgetT $ const $ restoreM base
|
||||
#endif
|
||||
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)
|
||||
|
||||
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
|
||||
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)
|
||||
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)
|
||||
liftBaseWith f = HandlerT $ \reader' ->
|
||||
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
|
||||
#endif
|
||||
|
||||
|
||||
@ -57,9 +57,12 @@ import Text.Cassius
|
||||
import Text.Julius
|
||||
import Yesod.Routes.Class
|
||||
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 Text.Shakespeare.I18N (RenderMessage)
|
||||
import Control.Monad (liftM)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Map as Map
|
||||
import Language.Haskell.TH.Quote (QuasiQuoter)
|
||||
@ -232,7 +235,7 @@ rules = do
|
||||
let ur f = do
|
||||
let env = NP.Env
|
||||
(Just $ helper [|getUrlRenderParams|])
|
||||
(Just $ helper [|liftM (toHtml .) getMessageRender|])
|
||||
(Just $ helper [|fmap (toHtml .) getMessageRender|])
|
||||
f env
|
||||
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 tp gwd = GWData
|
||||
{ gwdBody = fixBody $ gwdBody gwd
|
||||
, gwdTitle = gwdTitle gwd
|
||||
, gwdScripts = fixUnique fixScript $ gwdScripts gwd
|
||||
{ gwdBody = fixBody $ gwdBody gwd
|
||||
, gwdTitle = gwdTitle gwd
|
||||
, gwdScripts = fixUnique fixScript $ gwdScripts gwd
|
||||
, gwdStylesheets = fixUnique fixStyle $ gwdStylesheets gwd
|
||||
, gwdCss = fmap fixCss $ gwdCss gwd
|
||||
, gwdJavascript = fmap fixJS $ gwdJavascript gwd
|
||||
, gwdHead = fixHead $ gwdHead gwd
|
||||
, gwdCss = fixCss <$> gwdCss gwd
|
||||
, gwdJavascript = fixJS <$> gwdJavascript gwd
|
||||
, gwdHead = fixHead $ gwdHead gwd
|
||||
}
|
||||
where
|
||||
fixRender f route params = f (tp route) params
|
||||
fixRender f route = f (tp route)
|
||||
|
||||
fixBody (Body h) = Body $ h . fixRender
|
||||
fixHead (Head h) = Head $ h . fixRender
|
||||
|
||||
@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module Yesod.Routes.TH
|
||||
( module Yesod.Routes.TH.Types
|
||||
-- * Functions
|
||||
|
||||
@ -55,7 +55,7 @@ mkRouteCons rttypes =
|
||||
where
|
||||
con = NormalC (mkName name)
|
||||
$ map (\x -> (notStrict, x))
|
||||
$ concat [singles, [ConT $ mkName name]]
|
||||
$ singles ++ [ConT $ mkName name]
|
||||
|
||||
singles = concatMap toSingle pieces
|
||||
toSingle Static{} = []
|
||||
@ -99,7 +99,7 @@ mkRenderRouteClauses =
|
||||
dyns <- replicateM cnt $ newName "dyn"
|
||||
sub <-
|
||||
case resourceDispatch res of
|
||||
Subsite{} -> fmap return $ newName "sub"
|
||||
Subsite{} -> return <$> newName "sub"
|
||||
_ -> return []
|
||||
let pat = ConP (mkName $ resourceName res) $ map VarP $ dyns ++ sub
|
||||
|
||||
@ -136,7 +136,7 @@ mkRenderRouteClauses =
|
||||
mkPieces _ _ [] _ = []
|
||||
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 _ _ ((Dynamic _) : _) [] = error "mkPieces 120"
|
||||
mkPieces _ _ (Dynamic _ : _) [] = error "mkPieces 120"
|
||||
|
||||
-- | Generate the 'RenderRoute' instance.
|
||||
--
|
||||
|
||||
@ -10,6 +10,9 @@ import Yesod.Routes.Class
|
||||
import Language.Haskell.TH.Syntax
|
||||
import Data.Set (fromList)
|
||||
import Data.Text (pack)
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
import Control.Applicative ((<$>))
|
||||
#endif
|
||||
|
||||
mkRouteAttrsInstance :: Type -> [ResourceTree a] -> Q Dec
|
||||
mkRouteAttrsInstance typ ress = do
|
||||
@ -19,11 +22,11 @@ mkRouteAttrsInstance typ ress = do
|
||||
]
|
||||
|
||||
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) =
|
||||
fmap concat $ mapM (goTree front') trees
|
||||
concat <$> mapM (goTree front') trees
|
||||
where
|
||||
ignored = ((replicate toIgnore WildP ++) . return)
|
||||
ignored = (replicate toIgnore WildP ++) . return
|
||||
toIgnore = length $ filter isDynamic pieces
|
||||
isDynamic Dynamic{} = True
|
||||
isDynamic Static{} = False
|
||||
|
||||
@ -53,11 +53,11 @@ data Piece typ = Static String | Dynamic typ
|
||||
deriving Show
|
||||
|
||||
instance Functor Piece where
|
||||
fmap _ (Static s) = (Static s)
|
||||
fmap _ (Static s) = Static s
|
||||
fmap f (Dynamic t) = Dynamic (f t)
|
||||
|
||||
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)|]
|
||||
|
||||
data Dispatch typ =
|
||||
|
||||
@ -13,8 +13,6 @@ import Yesod.Core
|
||||
import Data.IORef.Lifted
|
||||
import Data.Typeable (Typeable)
|
||||
import qualified Data.ByteString.Lazy.Char8 as L8
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
|
||||
data C = C
|
||||
|
||||
|
||||
@ -9,11 +9,10 @@ import Yesod.Core
|
||||
import Test.Hspec
|
||||
import Network.Wai
|
||||
import Network.Wai.Test
|
||||
import Text.Hamlet (hamlet)
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import Control.Exception (SomeException, try)
|
||||
import Network.HTTP.Types (mkStatus)
|
||||
import Network.HTTP.Types (Status, mkStatus)
|
||||
import Blaze.ByteString.Builder (Builder, fromByteString, toLazyByteString)
|
||||
import Data.Monoid (mconcat)
|
||||
import Data.Text (Text, pack)
|
||||
@ -40,6 +39,7 @@ mkYesod "App" [parseRoutes|
|
||||
/good-builder GoodBuilderR GET
|
||||
|]
|
||||
|
||||
overrideStatus :: Status
|
||||
overrideStatus = mkStatus 15 "OVERRIDE"
|
||||
|
||||
instance Yesod App where
|
||||
|
||||
@ -2,10 +2,7 @@
|
||||
module YesodCoreTest.InternalRequest (internalRequestTest) where
|
||||
|
||||
import Data.List (nub)
|
||||
import System.Random (StdGen, mkStdGen)
|
||||
|
||||
import Network.Wai as W
|
||||
import Network.Wai.Test
|
||||
import Yesod.Core.Internal (randomString, parseWaiRequest)
|
||||
import Test.Hspec
|
||||
import Data.Monoid (mempty)
|
||||
|
||||
@ -6,7 +6,6 @@ module YesodCoreTest.Links (linksTest, Widget) where
|
||||
import Test.Hspec
|
||||
|
||||
import Yesod.Core
|
||||
import Text.Hamlet
|
||||
import Network.Wai
|
||||
import Network.Wai.Test
|
||||
import Data.Text (Text)
|
||||
|
||||
@ -8,7 +8,6 @@ import Test.Hspec
|
||||
import Yesod.Core
|
||||
import Network.Wai
|
||||
import Network.Wai.Test
|
||||
import Text.Lucius
|
||||
import YesodCoreTest.MediaData
|
||||
|
||||
mkYesodDispatch "Y" resourcesY
|
||||
|
||||
@ -8,7 +8,6 @@
|
||||
module YesodCoreTest.NoOverloadedStringsSub where
|
||||
|
||||
import Yesod.Core
|
||||
import Network.Wai
|
||||
import Yesod.Core.Types
|
||||
|
||||
data Subsite = Subsite (forall master. Yesod master => YesodSubRunnerEnv Subsite master (HandlerT master IO) -> Application)
|
||||
|
||||
@ -6,10 +6,6 @@ module YesodCoreTest.Widget (widgetTest) where
|
||||
import Test.Hspec
|
||||
|
||||
import Yesod.Core
|
||||
import Text.Julius
|
||||
import Text.Lucius
|
||||
import Text.Hamlet
|
||||
|
||||
import Network.Wai
|
||||
import Network.Wai.Test
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user