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

More incomplete changes

Browse Source
This commit is contained in:
Michael Snoyman 2013-03-14 05:58:37 +02:00
parent 553dff7bd2
commit c466845095
8 changed files with 87 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -94,7 +94,7 @@ import Data.Version (showVersion)
import Yesod.Routes.Class (RenderRoute (..))
-- | Return an 'Unauthorized' value, with the given i18n message.
unauthorizedI :: RenderMessage site msg => msg -> GHandler site AuthResult
unauthorizedI :: (Monad m, RenderMessage site msg) => msg -> HandlerT site m AuthResult
unauthorizedI msg = do
mr <- getMessageRender
return $ Unauthorized $ mr msg
@ -109,44 +109,14 @@ yesodVersion = showVersion Paths_yesod_core.version
maybeAuthorized :: Yesod site
=> Route site
-> Bool -- ^ is this a write request?
-> GHandler site (Maybe (Route site))
-> HandlerT site IO (Maybe (Route site))
maybeAuthorized r isWrite = do
x <- isAuthorized r isWrite
return $ if x == Authorized then Just r else Nothing
defaultLayoutT :: ( HandlerSite m ~ sub
, Yesod (HandlerMaster m)
, MonadHandler m
)
=> GWidget sub ()
-> m RepHtml
defaultLayoutT (GWidget (GHandler f)) = do
hd <- askHandlerData
defaultLayoutT :: Yesod parent
=> WidgetT child m ()
-> HandlerT parent m RepHtml
defaultLayoutT (WidgetT (HandlerT f)) = HandlerT $ \hd -> do
((), gwdata) <- liftResourceT $ f hd
liftHandlerMaster $ defaultLayout $ GWidget $ return ((), renderGWData (rheRender $ handlerEnv hd) gwdata)
renderGWData :: (x -> [(Text, Text)] -> Text) -> GWData x -> GWData y
renderGWData render 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
fixBody (Body h) = Body $ const $ h render
fixHead (Head h) = Head $ const $ h render
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) = Remote $ render url []
fixLoc (Remote t) = Remote t
fixCss f = const $ f render
fixJS f = const $ f render
unHandlerT $ defaultLayout $ WidgetT $ return ((), renderGWData (rheRender $ handlerEnv hd) gwdata)

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

@ -21,16 +21,16 @@ import Control.Monad.Trans.Control (MonadBaseControl)
class Yesod site => YesodDispatch site where
yesodDispatch :: YesodRunnerEnv site -> W.Application
class YesodSubDispatch sub m where
class YesodSubDispatch sub parent where
yesodSubDispatch
:: (MonadHandler m, master ~ HandlerMaster m, Yesod master)
=> (m TypedContent
-> YesodRunnerEnv master
-> Maybe (Route master)
:: Monad m
=> (HandlerT parent m TypedContent
-> YesodRunnerEnv parent
-> Maybe (Route parent)
-> W.Application)
-> (master -> sub)
-> (Route sub -> Route master)
-> YesodRunnerEnv master
-> (parent -> sub)
-> (Route sub -> Route parent)
-> YesodRunnerEnv parent
-> W.Application
instance YesodSubDispatch WaiSubsite master where
@ -39,16 +39,18 @@ instance YesodSubDispatch WaiSubsite master where
where
WaiSubsite app = toSub site
subHelper :: (HandlerSite m ~ master, MonadHandler m)
=> (m TypedContent
-> YesodRunnerEnv master
-> Maybe (Route master)
-- | A helper function for creating YesodSubDispatch instances, used by the
-- internal generated code.
subHelper :: Monad m
=> (HandlerT parent m TypedContent
-> YesodRunnerEnv parent
-> Maybe (Route parent)
-> W.Application)
-> (master -> sub)
-> (Route sub -> Route master)
-> HandlerT sub m TypedContent
-> YesodRunnerEnv master
-> Maybe (Route sub)
-> (parent -> child)
-> (Route child -> Route parent)
-> HandlerT child (HandlerT parent m) TypedContent
-> YesodRunnerEnv parent
-> Maybe (Route child)
-> W.Application
subHelper parentRunner getSub toMaster handlert env route =
parentRunner base env (fmap toMaster route)

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

@ -122,8 +122,8 @@ mkYesodGeneral name args clazzes isSub resS = do
context = if isSub then cxt $ yesod : map return clazzes
else return []
yesod = classP ''HandlerReader [master]
handler = tySynD (mkName "Handler") [] [t| GHandler $master |]
widget = tySynD (mkName "Widget") [] [t| GWidget $master () |]
handler = tySynD (mkName "Handler") [] [t| HandlerT $master IO |]
widget = tySynD (mkName "Widget") [] [t| WidgetT $master IO () |]
res = map (fmap parseType) resS
subCons = conT $ mkName name
subArgs = map (varT. mkName) args

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

@ -297,7 +297,8 @@ handlerToIO =
newReq = oldReq { reqWaiRequest = newWaiReq }
clearedOldHandlerData =
oldHandlerData { handlerRequest = err "handlerRequest never here"
, handlerState = err "handlerState never here" }
, handlerState = err "handlerState never here"
, handlerToParent = const () }
where
err :: String -> a
err = error . ("handlerToIO: clearedOldHandlerData/" ++)

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

@ -12,11 +12,12 @@ import Blaze.ByteString.Builder (toByteString)
import Control.Applicative ((<$>))
import Control.Exception (fromException)
import Control.Exception.Lifted (catch)
import Control.Monad (join)
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)
import Control.Monad.Trans.Resource (runResourceT, transResourceT, ResourceT, joinResourceT)
import Control.Monad.Trans.Control (MonadBaseControl)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
@ -45,10 +46,10 @@ import Yesod.Core.Internal.Request (parseWaiRequest,
import Yesod.Routes.Class (Route, renderRoute)
-- | Function used internally by Yesod in the process of converting a
-- 'GHandler' into an 'Application'. Should not be needed by users.
-- 'HandlerT' into an 'Application'. Should not be needed by users.
runHandler :: ToTypedContent c
=> RunHandlerEnv site
-> GHandler site c
-> HandlerT site IO c
-> YesodApp
runHandler rhe@RunHandlerEnv {..} handler yreq = do
let toErrorHandler e =
@ -66,8 +67,9 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = do
{ handlerRequest = yreq
, handlerEnv = rhe
, handlerState = istate
, handlerToParent = const ()
}
contents' <- catch (fmap Right $ unGHandler handler hd)
contents' <- catch (fmap Right $ unHandlerT handler hd)
(\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id
$ fromException e)
state <- liftIO $ I.readIORef istate
@ -128,31 +130,31 @@ safeEh log' er req = do
(toContent ("Internal Server Error" :: S.ByteString))
(reqSession req)
-- | Run a 'GHandler' completely outside of Yesod. This
-- | Run a 'HandlerT' completely outside of Yesod. This
-- function comes with many caveats and you shouldn't use it
-- unless you fully understand what it's doing and how it works.
--
-- As of now, there's only one reason to use this function at
-- all: in order to run unit tests of functions inside 'GHandler'
-- all: in order to run unit tests of functions inside 'HandlerT'
-- but that aren't easily testable with a full HTTP request.
-- Even so, it's better to use @wai-test@ or @yesod-test@ instead
-- of using this function.
--
-- This function will create a fake HTTP request (both @wai@'s
-- 'Request' and @yesod@'s 'Request') and feed it to the
-- @GHandler@. The only useful information the @GHandler@ may
-- @HandlerT@. The only useful information the @HandlerT@ may
-- get from the request is the session map, which you must supply
-- as argument to @runFakeHandler@. All other fields contain
-- fake information, which means that they can be accessed but
-- won't have any useful information. The response of the
-- @GHandler@ is completely ignored, including changes to the
-- @HandlerT@ is completely ignored, including changes to the
-- session, cookies or headers. We only return you the
-- @GHandler@'s return value.
-- @HandlerT@'s return value.
runFakeHandler :: (Yesod site, MonadIO m) =>
SessionMap
-> (site -> Logger)
-> site
-> GHandler site a
-> HandlerT site IO a
-> m (Either ErrorResponse a)
runFakeHandler fakeSessionMap logger site handler = liftIO $ do
ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result")
@ -208,7 +210,7 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
{-# WARNING runFakeHandler "Usually you should *not* use runFakeHandler unless you really understand how it works and why you need it." #-}
yesodRunner :: (ToTypedContent res, Yesod site)
=> GHandler site res
=> HandlerT site IO res
-> YesodRunnerEnv site
-> Maybe (Route site)
-> Application
@ -269,20 +271,18 @@ resolveApproot master req =
ApprootMaster f -> f master
ApprootRequest f -> f master req
stripHandlerT :: (MonadHandler m, MonadBaseControl IO m)
=> HandlerT sub m a
-> (HandlerSite m -> sub)
-> (Route sub -> Route (HandlerSite m))
-> Maybe (Route sub)
-> m a
stripHandlerT (HandlerT f) getSub toMaster newRoute = do
hd <- askHandlerData
stripHandlerT :: HandlerT child (HandlerT parent m) a
-> (parent -> child)
-> (Route child -> Route parent)
-> Maybe (Route child)
-> HandlerT parent m a
stripHandlerT (HandlerT f) getSub toMaster newRoute = HandlerT $ \hd -> do
let env = handlerEnv hd
f hd
joinResourceT $ transResourceT (($ hd) . unHandlerT) $ f hd
{ handlerEnv = env
{ rheSite = getSub $ rheSite env
, rheRoute = newRoute
, rheRender = \url params -> rheRender env (toMaster url) params
}
, handlerToParent = toMaster
}

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

@ -48,9 +48,9 @@ import Control.Monad.Trans.Resource (liftResourceT)
--
-- /Since: 0.3.0/
defaultLayoutJson :: (Yesod site, J.ToJSON a)
=> WidgetT site m () -- ^ HTML
-> HandlerT site m a -- ^ JSON
-> HandlerT site m TypedContent
=> WidgetT site IO () -- ^ HTML
-> HandlerT site IO a -- ^ JSON
-> HandlerT site IO TypedContent
defaultLayoutJson w json = selectRep $ do
provideRep $ defaultLayout w
provideRep $ fmap J.toJSON json
@ -59,7 +59,7 @@ defaultLayoutJson w json = selectRep $ do
-- support conversion to JSON via 'J.ToJSON'.
--
-- /Since: 0.3.0/
jsonToRepJson :: J.ToJSON a => a -> HandlerT site m J.Value
jsonToRepJson :: (Monad m, J.ToJSON a) => a -> m J.Value
jsonToRepJson = return . J.toJSON
-- | Parse the request body to a data type as a JSON value. The
@ -68,7 +68,7 @@ jsonToRepJson = return . J.toJSON
-- 'J.Value'@.
--
-- /Since: 0.3.0/
parseJsonBody :: (MonadResource m, J.FromJSON a) => m (J.Result a)
parseJsonBody :: (MonadResource m, HandlerReader m, J.FromJSON a) => m (J.Result a)
parseJsonBody = do
req <- waiRequest
eValue <- runExceptionT

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

@ -179,10 +179,11 @@ data RunHandlerEnv site = RunHandlerEnv
-- Since 1.2.0
}
data HandlerData site = HandlerData
{ handlerRequest :: !YesodRequest
, handlerEnv :: !(RunHandlerEnv site)
, handlerState :: !(IORef GHState)
data HandlerData site parentRoute = HandlerData
{ handlerRequest :: !YesodRequest
, handlerEnv :: !(RunHandlerEnv site)
, handlerState :: !(IORef GHState)
, handlerToParent :: !(Route site -> parentRoute)
}
data YesodRunnerEnv site = YesodRunnerEnv
@ -194,9 +195,13 @@ 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 -> ResourceT m a
{ unHandlerT :: HandlerData site (MonadRoute m) -> ResourceT m a
}
type family MonadRoute (m :: * -> *)
type instance MonadRoute IO = ()
type instance MonadRoute (HandlerT site m) = (Route site)
data GHState = GHState
{ ghsSession :: SessionMap
, ghsRBC :: Maybe RequestBodyContents

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

@ -1,4 +1,5 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
@ -50,6 +51,8 @@ import Text.Cassius
import Text.Julius
import Yesod.Routes.Class
import Yesod.Core.Handler (getMessageRender, getUrlRenderParams)
import Control.Monad.Trans.Resource (transResourceT)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Text.Shakespeare.I18N (RenderMessage)
import Control.Monad (liftM)
import Data.Text (Text)
@ -215,3 +218,21 @@ tell w = WidgetT $ return ((), w)
toUnique :: x -> UniqueList x
toUnique = UniqueList . (:)
liftHandlerT :: MonadIO m
=> HandlerT site IO a
-> HandlerT site m a
liftHandlerT (HandlerT f) =
HandlerT $ transResourceT liftIO . f . fixToParent
where
fixToParent hd = hd { handlerToParent = const () }
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)
liftGWD :: (child -> parent) -> GWData child -> GWData parent
liftGWD = error "liftGWD"