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

Compiles again, tests fails

Browse Source
This commit is contained in:
Michael Snoyman 2013-03-14 07:32:40 +02:00
parent c466845095
commit 8e793c70cc
12 changed files with 107 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -48,8 +48,6 @@ module Yesod.Core
, ScriptLoadPosition (..)
, BottomOfHeadAsync
-- * Subsites
, defaultLayoutT
, MonadHandler (..)
, HandlerReader (..)
, HandlerState (..)
, HandlerError (..)
@ -63,7 +61,6 @@ module Yesod.Core
, module Yesod.Core.Handler
, module Yesod.Core.Widget
, module Yesod.Core.Json
, module Yesod.Core.Class.MonadLift
, module Text.Shakespeare.I18N
, module Yesod.Core.Internal.Util
) where
@ -113,10 +110,3 @@ maybeAuthorized :: Yesod site
maybeAuthorized r isWrite = do
x <- isAuthorized r isWrite
return $ if x == Authorized then Just r else Nothing
defaultLayoutT :: Yesod parent
=> WidgetT child m ()
-> HandlerT parent m RepHtml
defaultLayoutT (WidgetT (HandlerT f)) = HandlerT $ \hd -> do
((), gwdata) <- liftResourceT $ f hd
unHandlerT $ defaultLayout $ WidgetT $ return ((), renderGWData (rheRender $ handlerEnv hd) gwdata)

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

@ -21,16 +21,15 @@ import Control.Monad.Trans.Control (MonadBaseControl)
class Yesod site => YesodDispatch site where
yesodDispatch :: YesodRunnerEnv site -> W.Application
class YesodSubDispatch sub parent where
class YesodSubDispatch sub m where
yesodSubDispatch
:: Monad m
=> (HandlerT parent m TypedContent
-> YesodRunnerEnv parent
-> Maybe (Route parent)
:: (m TypedContent
-> YesodRunnerEnv (HandlerSite m)
-> Maybe (Route (HandlerSite m))
-> W.Application)
-> (parent -> sub)
-> (Route sub -> Route parent)
-> YesodRunnerEnv parent
-> (HandlerSite m -> sub)
-> (Route sub -> Route (HandlerSite m))
-> YesodRunnerEnv (HandlerSite m)
-> W.Application
instance YesodSubDispatch WaiSubsite master where

9
yesod-core/Yesod/Core/Class/Handler.hs
View File

@ -29,8 +29,8 @@ instance Monad m => HandlerReader (HandlerT site m) where
instance Monad m => HandlerReader (WidgetT site m) where
type HandlerSite (WidgetT site m) = site
askYesodRequest = WidgetT $ fmap (, mempty) $ askYesodRequest
askHandlerEnv = WidgetT $ fmap (, mempty) $ askHandlerEnv
askYesodRequest = WidgetT $ return . (, mempty) . handlerRequest
askHandlerEnv = WidgetT $ return . (, mempty) . handlerEnv
class HandlerReader m => HandlerState m where
stateGHState :: (GHState -> (a, GHState)) -> m a
@ -48,7 +48,10 @@ instance MonadBase IO m => HandlerState (HandlerT site m) where
f' z = let (x, y) = f z in (y, x)
instance MonadBase IO m => HandlerState (WidgetT site m) where
stateGHState = WidgetT . fmap (, mempty) . stateGHState
stateGHState f =
WidgetT $ fmap (, mempty) . flip atomicModifyIORef f' . handlerState
where
f' z = let (x, y) = f z in (y, x)
class HandlerReader m => HandlerError m where
handlerError :: HandlerContents -> m a

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

@ -58,6 +58,7 @@ import Web.Cookie (SetCookie (..))
import Yesod.Core.Types
import Yesod.Core.Internal.Session
import Yesod.Core.Widget
import Control.Monad.Trans.Class (lift)
-- | Define settings for a Yesod applications. All methods have intelligent
-- defaults, and therefore no implementation is required.
@ -302,7 +303,8 @@ widgetToPageContent :: (Eq (Route site), Yesod site)
-> HandlerT site IO (PageContent (Route site))
widgetToPageContent w = do
master <- getYesod
((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- unWidgetT w
hd <- HandlerT return
((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- lift $ unWidgetT w hd
let title = maybe mempty unTitle mTitle
scripts = runUniqueList scripts'
stylesheets = runUniqueList stylesheets'

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

@ -30,6 +30,7 @@ module Yesod.Core.Handler
, getRequest
, waiRequest
, runRequestBody
, rawRequestBody
-- ** Request information
-- *** Request datatype
, RequestBodyContents
@ -147,6 +148,7 @@ import Text.Hamlet (Html, HtmlUrl, hamlet)
import qualified Data.ByteString as S
import qualified Data.Map as Map
import Data.Conduit (Source)
import Control.Arrow ((***))
import qualified Data.ByteString.Char8 as S8
import Data.Maybe (mapMaybe)
@ -314,7 +316,9 @@ handlerToIO =
-- The state IORef needs to be created here, otherwise it
-- will be shared by different invocations of this function.
newStateIORef <- I.newIORef newState
runResourceT $ f clearedOldHandlerData
-- FIXME previously runResourceT was used here, but that could mean resources might vanish...
-- Check if this new behavior is correct.
f clearedOldHandlerData
{ handlerRequest = newReq
, handlerState = newStateIORef }
@ -875,3 +879,9 @@ provideRepType :: (MonadIO m, ToContent a)
-> Writer.Writer (Endo [ProvidedRep m]) ()
provideRepType ct handler =
Writer.tell $ Endo $ (ProvidedRep ct (liftM toContent handler):)
-- | Stream in the raw request body without any parsing.
--
-- Since 1.2.0
rawRequestBody :: Source m S.ByteString
rawRequestBody = error "rawRequestBody"

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

@ -17,7 +17,7 @@ import Control.Monad.IO.Class (MonadIO)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger (LogLevel (LevelError), LogSource,
liftLoc)
import Control.Monad.Trans.Resource (runResourceT, transResourceT, ResourceT, joinResourceT)
import Control.Monad.Trans.Resource (runResourceT, transResourceT, ResourceT, joinResourceT, withInternalState, runInternalState)
import Control.Monad.Trans.Control (MonadBaseControl)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
@ -51,7 +51,7 @@ runHandler :: ToTypedContent c
=> RunHandlerEnv site
-> HandlerT site IO c
-> YesodApp
runHandler rhe@RunHandlerEnv {..} handler yreq = do
runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> do
let toErrorHandler e =
case fromException e of
Just (HCError x) -> x
@ -68,6 +68,7 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = do
, handlerEnv = rhe
, handlerState = istate
, handlerToParent = const ()
, handlerResource = resState
}
contents' <- catch (fmap Right $ unHandlerT handler hd)
(\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id
@ -76,7 +77,7 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = do
let finalSession = ghsSession state
let headers = ghsHeaders state
let contents = either id (HCContent H.status200 . toTypedContent) contents'
let handleError e = do
let handleError e = flip runInternalState resState $ do
yar <- rheOnError e yreq
{ reqSession = finalSession
}
@ -278,7 +279,7 @@ stripHandlerT :: HandlerT child (HandlerT parent m) a
-> HandlerT parent m a
stripHandlerT (HandlerT f) getSub toMaster newRoute = HandlerT $ \hd -> do
let env = handlerEnv hd
joinResourceT $ transResourceT (($ hd) . unHandlerT) $ f hd
($ hd) $ unHandlerT $ f hd
{ handlerEnv = env
{ rheSite = getSub $ rheSite env
, rheRoute = newRoute

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

@ -22,7 +22,7 @@ import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Logger (LogLevel, LogSource,
MonadLogger (..))
import Control.Monad.Trans.Control (MonadBaseControl (..))
import Control.Monad.Trans.Resource (MonadResource (..))
import Control.Monad.Trans.Resource
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as L
import Data.Conduit (Flush, MonadThrow (..),
@ -184,6 +184,7 @@ data HandlerData site parentRoute = HandlerData
, handlerEnv :: !(RunHandlerEnv site)
, handlerState :: !(IORef GHState)
, handlerToParent :: !(Route site -> parentRoute)
, handlerResource :: !InternalState
}
data YesodRunnerEnv site = YesodRunnerEnv
@ -195,7 +196,7 @@ data YesodRunnerEnv site = YesodRunnerEnv
-- | A generic handler monad, which can have a different subsite and master
-- site. We define a newtype for better error message.
newtype HandlerT site m a = HandlerT
{ unHandlerT :: HandlerData site (MonadRoute m) -> ResourceT m a
{ unHandlerT :: HandlerData site (MonadRoute m) -> m a
}
type family MonadRoute (m :: * -> *)
@ -219,7 +220,7 @@ type YesodApp = YesodRequest -> ResourceT IO YesodResponse
-- site datatypes. While this is simply a @WriterT@, we define a newtype for
-- better error messages.
newtype WidgetT site m a = WidgetT
{ unWidgetT :: HandlerT site m (a, GWData (Route site))
{ unWidgetT :: HandlerData site (MonadRoute m) -> m (a, GWData (Route site))
}
instance (a ~ (), Monad m) => Monoid (WidgetT site m a) where
@ -344,35 +345,36 @@ instance Monad m => Applicative (WidgetT site m) where
pure = return
(<*>) = ap
instance Monad m => Monad (WidgetT site m) where
return a = WidgetT $ pure (a, mempty)
WidgetT x >>= f = WidgetT $ do
(a, wa) <- x
(b, wb) <- unWidgetT (f a)
return a = WidgetT $ const $ return (a, mempty)
WidgetT x >>= f = WidgetT $ \r -> do
(a, wa) <- x r
(b, wb) <- unWidgetT (f a) r
return (b, wa `mappend` wb)
instance MonadIO m => MonadIO (WidgetT site m) where
liftIO = lift . liftIO
instance MonadBase b m => MonadBase b (WidgetT site m) where
liftBase = WidgetT . fmap (\a -> (a, mempty)) . liftBase
liftBase = WidgetT . const . liftBase . fmap (, mempty)
instance MonadBaseControl b m => MonadBaseControl b (WidgetT site m) where
data StM (WidgetT site m) a =
StW (StM (HandlerT site m) (a, GWData (Route site)))
liftBaseWith f = WidgetT $ liftBaseWith $ \runInBase ->
liftM (\x -> (x, mempty))
(f $ liftM StW . runInBase . unWidgetT)
restoreM (StW base) = WidgetT $ restoreM base
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)
restoreM (StW base) = WidgetT $ const $ restoreM base
instance MonadTrans (WidgetT site) where
lift = WidgetT . fmap (, mempty) . lift
lift = WidgetT . const . liftM (, mempty)
instance MonadThrow m => MonadThrow (WidgetT site m) where
monadThrow = lift . monadThrow
instance (Applicative m, MonadIO m, MonadUnsafeIO m, MonadThrow m) => MonadResource (WidgetT site m) where
liftResourceT = WidgetT . fmap (, mempty) . liftResourceT
liftResourceT f = WidgetT $ \hd -> liftIO $ fmap (, mempty) $ runInternalState f (handlerResource hd)
instance MonadIO m => MonadLogger (WidgetT site m) where
monadLoggerLog a b c d = WidgetT $ fmap (, mempty) $ monadLoggerLog a b c d
monadLoggerLog a b c d = WidgetT $ \hd ->
liftIO $ fmap (, mempty) $ rheLog (handlerEnv hd) a b c (toLogStr d)
instance MonadTrans (HandlerT site) where
lift = HandlerT . const . lift
lift = HandlerT . const
-- Instances for HandlerT
instance Monad m => Functor (HandlerT site m) where
@ -396,7 +398,7 @@ instance MonadBase b m => MonadBase b (HandlerT site m) where
-- \"Control.Monad.Trans.Resource.register\': The mutable state is being accessed
-- after cleanup. Please contact the maintainers.\"
instance MonadBaseControl b m => MonadBaseControl b (HandlerT site m) where
data StM (HandlerT site m) a = StH (StM (ResourceT m) a)
data StM (HandlerT site m) a = StH (StM m a)
liftBaseWith f = HandlerT $ \reader ->
liftBaseWith $ \runInBase ->
f $ liftM StH . runInBase . (\(HandlerT r) -> r reader)
@ -404,8 +406,8 @@ instance MonadBaseControl b m => MonadBaseControl b (HandlerT site m) where
instance MonadThrow m => MonadThrow (HandlerT site m) where
monadThrow = lift . monadThrow
instance (MonadIO m, MonadUnsafeIO m, MonadThrow m, Applicative m) => MonadResource (HandlerT site m) where
liftResourceT = HandlerT . const . liftResourceT
instance (MonadIO m, MonadUnsafeIO m, MonadThrow m) => MonadResource (HandlerT site m) where
liftResourceT f = HandlerT $ \hd -> liftIO $ runInternalState f (handlerResource hd)
instance MonadIO m => MonadLogger (HandlerT site m) where
monadLoggerLog a b c d = HandlerT $ \hd ->

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

@ -40,6 +40,8 @@ module Yesod.Core.Widget
, addScriptRemote
, addScriptRemoteAttrs
, addScriptEither
-- * Subsites
, liftWidget
-- * Internal
, whamletFileWithSettings
) where
@ -83,7 +85,7 @@ instance (Monad m, render ~ RY site) => ToWidget site m (render -> CssBuilder) w
toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty
instance (Monad m, render ~ RY site) => ToWidget site m (render -> Javascript) where
toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty
instance (site' ~ site, Monad m) => ToWidget site' m (WidgetT site m ()) where
instance (site' ~ site, Monad m, m' ~ m) => ToWidget site' m' (WidgetT site m ()) where
toWidget = id
instance Monad m => ToWidget site m Html where
toWidget = toWidget . const
@ -214,7 +216,7 @@ ihamletToRepHtml ih = do
return $ ih (toHtml . mrender) urender
tell :: Monad m => GWData (Route site) -> WidgetT site m ()
tell w = WidgetT $ return ((), w)
tell w = WidgetT $ const $ return ((), w)
toUnique :: x -> UniqueList x
toUnique = UniqueList . (:)
@ -223,7 +225,7 @@ liftHandlerT :: MonadIO m
=> HandlerT site IO a
-> HandlerT site m a
liftHandlerT (HandlerT f) =
HandlerT $ transResourceT liftIO . f . fixToParent
HandlerT $ liftIO . f . fixToParent
where
fixToParent hd = hd { handlerToParent = const () }
@ -231,8 +233,33 @@ liftWidget :: MonadIO m
=> WidgetT child IO a
-> HandlerT child (HandlerT parent m) (WidgetT parent m a)
liftWidget (WidgetT f) = HandlerT $ \hd -> do
(a, gwd) <- unHandlerT (liftHandlerT f) hd
return $ WidgetT $ HandlerT $ const $ return (a, liftGWD (handlerToParent hd) gwd)
(a, gwd) <- liftIO $ f hd { handlerToParent = const () }
return $ WidgetT $ const $ return (a, liftGWD (handlerToParent hd) gwd)
liftGWD :: (child -> parent) -> GWData child -> GWData parent
liftGWD = error "liftGWD"
liftGWD tp gwd = GWData
{ 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
}
where
fixRender f route params = f (tp route) params
fixBody (Body h) = Body $ h . fixRender
fixHead (Head h) = Head $ h . fixRender
fixUnique go (UniqueList f) = UniqueList (map go (f []) ++)
fixScript (Script loc attrs) = Script (fixLoc loc) attrs
fixStyle (Stylesheet loc attrs) = Stylesheet (fixLoc loc) attrs
fixLoc (Local url) = Local $ tp url
fixLoc (Remote t) = Remote t
fixCss f = f . fixRender
fixJS f = f . fixRender

12
yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs
View File

@ -11,25 +11,27 @@ import Network.Wai.Test
import Data.Monoid (mempty)
import qualified Data.Text as T
import qualified Data.ByteString.Lazy.Char8 as L8
import Control.Monad.Trans.Class
getSubsite :: a -> Subsite
getSubsite = const Subsite
instance YesodSubDispatch Subsite (GHandler master) where
instance Yesod master => YesodSubDispatch Subsite (HandlerT master IO) where
yesodSubDispatch = $(mkYesodSubDispatch resourcesSubsite)
getBarR :: Monad m => m T.Text
getBarR = return $ T.pack "BarR"
getBazR :: Yesod master => HandlerT Subsite (GHandler master) RepHtml
getBazR :: Yesod master => HandlerT Subsite (HandlerT master IO) RepHtml
getBazR = lift $ defaultLayout [whamlet|Used Default Layout|]
getBinR :: MonadHandler m => HandlerT Subsite m RepHtml
getBinR = defaultLayoutT
[whamlet|
getBinR :: Yesod master => HandlerT Subsite (HandlerT master IO) RepHtml
getBinR = do
widget <- liftWidget [whamlet|
<p>Used defaultLayoutT
<a href=@{BazR}>Baz
|]
lift $ defaultLayout widget
data Y = Y
mkYesod "Y" [parseRoutes|

8
yesod-core/test/YesodCoreTest/RequestBodySize.hs
View File

@ -18,6 +18,8 @@ import qualified Data.Text as T
import Data.Conduit
import Data.Conduit.List (consume)
import Data.Conduit.Binary (isolate)
import Control.Monad.Trans.Class
import Control.Monad.Trans.Resource
data Y = Y
@ -38,13 +40,11 @@ postPostR = do
return $ RepPlain $ toContent $ T.concat val
postConsumeR = do
req <- waiRequest
body <- lift $ requestBody req $$ consume
body <- rawRequestBody $$ consume
return $ RepPlain $ toContent $ S.concat body
postPartialConsumeR = do
req <- waiRequest
body <- lift $ requestBody req $$ isolate 5 =$ consume
body <- rawRequestBody $$ isolate 5 =$ consume
return $ RepPlain $ toContent $ S.concat body
postUnusedR = return $ RepPlain ""

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

@ -61,18 +61,14 @@ getTowidgetR = defaultLayout $ do
getWhamletR :: Handler RepHtml
getWhamletR = defaultLayout [whamlet|
$newline never
<h1>Test
<h2>@{WhamletR}
<h3>_{Goodbye}
<h3>_{MsgAnother}
^{embed}
|]
<h1>Test
<h2>@{WhamletR}
<h3>_{Goodbye}
<h3>_{MsgAnother}
^{embed}
|]
where
embed = [whamlet|
$newline never
<h4>Embed
|]
embed = [whamlet|<h4>Embed|]
getAutoR :: Handler RepHtml
getAutoR = defaultLayout [whamlet|

1
yesod-core/yesod-core.cabal
View File

@ -133,6 +133,7 @@ test-suite tests
, conduit
, containers
, lifted-base
, resourcet
ghc-options: -Wall
source-repository head