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

More built in support for subsites

Browse Source
This commit is contained in:
Michael Snoyman 2010-04-18 00:53:35 -07:00
parent 654331f406
commit d6fbe1e088
6 changed files with 123 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Yesod/Hamlet.hs
View File

@ -28,7 +28,7 @@ data PageContent url = PageContent
, pageBody :: Hamlet url IO ()
}
hamletToContent :: Hamlet (Routes y) IO () -> Handler y Content
hamletToContent :: Hamlet (Routes sub) IO () -> GHandler sub master Content
hamletToContent h = do
render <- getUrlRender
return $ ContentEnum $ go render

96
Yesod/Handler.hs
View File

@ -21,13 +21,19 @@
module Yesod.Handler
( -- * Handler monad
Handler
, GHandler
, getYesod
, getYesodMaster
, getUrlRender
, getUrlRenderMaster
, getRoute
, getRouteMaster
, runHandler
, runHandler'
, runHandlerSub
, liftIO
, YesodApp (..)
, YesodAppSub (..)
, Routes
-- * Special handlers
, redirect
@ -61,11 +67,13 @@ import Data.Convertible.Text (cs)
type family Routes y
data HandlerData yesod = HandlerData
data HandlerData sub master = HandlerData
{ handlerRequest :: Request
, handlerYesod :: yesod
, handlerRoute :: Maybe (Routes yesod)
, handlerRender :: (Routes yesod -> String)
, handlerSub :: sub
, handlerMaster :: master
, handlerRoute :: Maybe (Routes sub)
, handlerRender :: (Routes master -> String)
, handlerToMaster :: Routes sub -> Routes master
}
newtype YesodApp = YesodApp
@ -76,22 +84,26 @@ newtype YesodApp = YesodApp
-> IO Response
}
data YesodAppSub master = YesodAppSub
------ Handler monad
newtype Handler yesod a = Handler {
unHandler :: HandlerData yesod
newtype GHandler sub master a = Handler {
unHandler :: HandlerData sub master
-> IO ([Header], HandlerContents a)
}
type Handler yesod = GHandler yesod yesod
data HandlerContents a =
HCSpecial SpecialResponse
| HCError ErrorResponse
| HCContent a
instance Functor (Handler yesod) where
instance Functor (GHandler sub master) where
fmap = liftM
instance Applicative (Handler yesod) where
instance Applicative (GHandler sub master) where
pure = return
(<*>) = ap
instance Monad (Handler yesod) where
instance Monad (GHandler sub master) where
fail = failure . InternalError -- We want to catch all exceptions anyway
return x = Handler $ \_ -> return ([], HCContent x)
(Handler handler) >>= f = Handler $ \rr -> do
@ -102,21 +114,46 @@ instance Monad (Handler yesod) where
(HCSpecial e) -> return ([], HCSpecial e)
(HCContent a) -> unHandler (f a) rr
return (headers ++ headers', c')
instance MonadIO (Handler yesod) where
instance MonadIO (GHandler sub master) where
liftIO i = Handler $ \_ -> i >>= \i' -> return ([], HCContent i')
instance Failure ErrorResponse (Handler yesod) where
instance Failure ErrorResponse (GHandler sub master) where
failure e = Handler $ \_ -> return ([], HCError e)
instance RequestReader (Handler yesod) where
instance RequestReader (GHandler sub master) where
getRequest = Handler $ \r -> return ([], HCContent $ handlerRequest r)
getYesod :: Handler yesod yesod
getYesod = Handler $ \r -> return ([], HCContent $ handlerYesod r)
getData :: GHandler sub master (HandlerData sub master)
getData = Handler $ \r -> return ([], HCContent r)
getUrlRender :: Handler yesod (Routes yesod -> String)
getUrlRender = Handler $ \r -> return ([], HCContent $ handlerRender r)
getYesod :: GHandler sub master sub
getYesod = handlerSub <$> getData
getRoute :: Handler yesod (Maybe (Routes yesod))
getRoute = Handler $ \r -> return ([], HCContent $ handlerRoute r)
getYesodMaster :: GHandler sub master master
getYesodMaster = handlerMaster <$> getData
getUrlRender :: GHandler sub master (Routes sub -> String)
getUrlRender = do
d <- getData
return $ handlerRender d . handlerToMaster d
getUrlRenderMaster :: GHandler sub master (Routes master -> String)
getUrlRenderMaster = handlerRender <$> getData
getRoute :: GHandler sub master (Maybe (Routes sub))
getRoute = handlerRoute <$> getData
getRouteMaster :: GHandler sub master (Maybe (Routes master))
getRouteMaster = do
d <- getData
return $ handlerToMaster d <$> handlerRoute d
runHandlerSub :: HasReps c
=> GHandler sub master c
-> master
-> (master -> sub)
-> Routes sub
-> (Routes sub -> String)
-> YesodAppSub master
runHandlerSub = error "runHandlerSub"
runHandler' :: HasReps c
=> Handler yesod c
@ -137,7 +174,14 @@ runHandler handler y route render = YesodApp $ \eh rr cts -> do
InternalError
. (show :: Control.Exception.SomeException -> String)
(headers, contents) <- Control.Exception.catch
(unHandler handler $ HandlerData rr y route render)
(unHandler handler $ HandlerData
{ handlerRequest = rr
, handlerSub = y
, handlerMaster = y
, handlerRoute = route
, handlerRender = render
, handlerToMaster = id
})
(\e -> return ([], HCError $ toErrorHandler e))
let handleError e = do
Response _ hs ct c <- unYesodApp (eh e) safeEh rr cts
@ -164,14 +208,14 @@ safeEh er = YesodApp $ \_ _ _ -> do
return $ Response W.Status500 [] TypePlain $ cs "Internal Server Error"
------ Special handlers
specialResponse :: SpecialResponse -> Handler yesod a
specialResponse :: SpecialResponse -> GHandler sub master a
specialResponse er = Handler $ \_ -> return ([], HCSpecial er)
-- | Redirect to the given URL.
redirect :: RedirectType -> String -> Handler yesod a
redirect :: RedirectType -> String -> GHandler sub master a
redirect rt = specialResponse . Redirect rt
sendFile :: ContentType -> FilePath -> Handler yesod a
sendFile :: ContentType -> FilePath -> GHandler sub master a
sendFile ct = specialResponse . SendFile ct
-- | Return a 404 not found page. Also denotes no handler available.
@ -194,16 +238,16 @@ invalidArgs = failure . InvalidArgs
addCookie :: Int -- ^ minutes to timeout
-> String -- ^ key
-> String -- ^ value
-> Handler yesod ()
-> GHandler sub master ()
addCookie a b = addHeader . AddCookie a b
-- | Unset the cookie on the client.
deleteCookie :: String -> Handler yesod ()
deleteCookie :: String -> GHandler sub master ()
deleteCookie = addHeader . DeleteCookie
-- | Set an arbitrary header on the client.
header :: String -> String -> Handler yesod ()
header :: String -> String -> GHandler sub master ()
header a = addHeader . Header a
addHeader :: Header -> Handler yesod ()
addHeader :: Header -> GHandler sub master ()
addHeader h = Handler $ \_ -> return ([h], HCContent ())

39
Yesod/Helpers/Auth.hs
View File

@ -5,6 +5,7 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE NoMonomorphismRestriction #-} -- FIXME I'd like to get rid of this
---------------------------------------------------------
--
-- Module : Yesod.Helpers.Auth
@ -47,15 +48,14 @@ import Control.Applicative ((<$>))
data LoginType = OpenId | Rpxnow
data Auth = forall y. Yesod y => Auth
data Auth = Auth
{ defaultDest :: String
, onRpxnowLogin :: Rpxnow.Identifier -> Handler Auth ()
--, onRpxnowLogin :: Rpxnow.Identifier -> GHandler Auth master ()
, rpxnowApiKey :: Maybe String
, defaultLoginType :: LoginType
, parentYesod :: y
}
$(mkYesod "Auth" [$parseRoutes|
$(mkYesodSub "Auth" [$parseRoutes|
/check Check GET
/logout Logout GET
/openid OpenIdR GET
@ -68,13 +68,13 @@ data ExpectedSingleParam = ExpectedSingleParam
deriving (Show, Typeable)
instance Exception ExpectedSingleParam
getOpenIdR :: Handler Auth RepHtml
getOpenIdR :: Yesod master => GHandler Auth master RepHtml
getOpenIdR = do
rr <- getRequest
case getParams rr "dest" of
[] -> return ()
(x:_) -> addCookie destCookieTimeout destCookieName x
(Auth _ _ _ _ y) <- getYesod
y <- getYesodMaster
let html = template (getParams rr "message", id)
let pc = PageContent
{ pageTitle = cs "Log in via OpenID"
@ -97,7 +97,7 @@ $if hasMessage
%input!type=submit!value=Login
|]
getOpenIdForward :: Handler Auth ()
getOpenIdForward :: GHandler Auth master ()
getOpenIdForward = do
rr <- getRequest
oid <- case getParams rr "openid" of
@ -112,7 +112,7 @@ getOpenIdForward = do
(redirect RedirectTemporary)
res
getOpenIdComplete :: Handler Auth ()
getOpenIdComplete :: GHandler Auth master ()
getOpenIdComplete = do
rr <- getRequest
let gets' = reqGetParams rr
@ -126,7 +126,7 @@ getOpenIdComplete = do
redirectToDest RedirectTemporary $ defaultDest y
attempt onFailure onSuccess res
handleRpxnowR :: Handler Auth ()
handleRpxnowR :: GHandler Auth master ()
handleRpxnowR = do
ay <- getYesod
apiKey <- case rpxnowApiKey ay of
@ -146,7 +146,10 @@ handleRpxnowR = do
(d:_) -> d
ident <- liftIO $ Rpxnow.authenticate apiKey token
auth <- getYesod
onRpxnowLogin auth ident
{- FIXME onRpxnowLogin
case auth of
Auth _ f _ _ _ -> f ident
-}
header authCookieName $ Rpxnow.identifier ident
header authDisplayName $ getDisplayName ident
redirectToDest RedirectTemporary dest
@ -164,12 +167,12 @@ getDisplayName (Rpxnow.Identifier ident extra) = helper choices where
Nothing -> helper xs
Just y -> y
getCheck :: Handler Auth RepHtml
getCheck :: Yesod master => GHandler Auth master RepHtml
getCheck = do
ident <- maybeIdentifier
dn <- displayName
-- FIXME applyLayoutJson
hamletToRepHtml $ [$hamlet|
simpleApplyLayout "Authentication Status" $ [$hamlet|
%h1 Authentication Status
%dl
%dt identifier
@ -178,7 +181,7 @@ getCheck = do
%dd $snd$
|] (cs $ fromMaybe "" ident, cs $ fromMaybe "" dn)
getLogout :: Handler Auth ()
getLogout :: GHandler Auth master ()
getLogout = do
y <- getYesod
deleteCookie authCookieName
@ -198,12 +201,12 @@ displayName = do
-- | Gets the identifier for a user. If user is not logged in, redirects them
-- to the login page.
authIdentifier :: Handler Auth String
authIdentifier :: GHandler Auth master String
authIdentifier = maybeIdentifier >>= maybe redirectLogin return
-- | Redirect the user to the 'defaultLoginPath', setting the DEST cookie
-- appropriately.
redirectLogin :: Handler Auth a
redirectLogin :: GHandler Auth master a
redirectLogin = do
y <- getYesod
let r = case defaultLoginType y of
@ -228,8 +231,8 @@ requestPath = do
-- | Redirect to the given URL, and set a cookie with the current URL so the
-- user will ultimately be sent back here.
redirectSetDest :: RedirectType
-> Routes y -- ^ redirect page
-> Handler y a
-> Routes sub -- ^ redirect page
-> GHandler sub master a
redirectSetDest rt dest = do
ur <- getUrlRender
curr <- getRoute
@ -242,7 +245,7 @@ redirectSetDest rt dest = do
-- | Read the 'destCookieName' cookie and redirect to this destination. If the
-- cookie is missing, then use the default path provided.
redirectToDest :: RedirectType -> String -> Handler y a
redirectToDest :: RedirectType -> String -> GHandler sub master a
redirectToDest rt def = do
rr <- getRequest
dest <- case cookies rr destCookieName of

15
Yesod/Resource.hs
View File

@ -3,6 +3,7 @@
module Yesod.Resource
( parseRoutes
, mkYesod
, mkYesodSub
) where
import Web.Routes.Quasi (parseRoutes, createRoutes, Resource (..))
@ -18,8 +19,20 @@ mkYesod name res = do
let yes' = FunD (mkName "getSite") [Clause [] gsbod []]
let yes = InstanceD [] (ConT ''YesodSite `AppT` ConT name') [yes']
decs <- createRoutes (name ++ "Routes")
''YesodApp
(ConT ''YesodApp)
name'
"runHandler'"
res
return $ tySyn : yes : decs
mkYesodSub :: String -> [Resource] -> Q [Dec]
mkYesodSub name res = do
let name' = mkName name
let tySyn = TySynInstD ''Routes [ConT $ name'] (ConT $ mkName $ name ++ "Routes")
let yas = ConT ''YesodApp `AppT` VarT (mkName "master")
decs <- createRoutes (name ++ "Routes")
yas
name'
"runHandlerSub"
res
return $ tySyn : decs

28
Yesod/Yesod.hs
View File

@ -77,40 +77,44 @@ class YesodSite a => Yesod a where
approot :: a -> Approot
-- | A convenience wrapper around 'simpleApplyLayout for HTML-only data.
simpleApplyLayout :: Yesod y
simpleApplyLayout :: Yesod master
=> String -- ^ title
-> Hamlet (Routes y) IO () -- ^ body
-> Handler y ChooseRep
-> Hamlet (Routes sub) IO () -- ^ body
-> GHandler sub master RepHtml
simpleApplyLayout t b = do
let pc = PageContent
{ pageTitle = cs t
, pageHead = return ()
, pageBody = b
}
y <- getYesod
y <- getYesodMaster
rr <- getRequest
content <- hamletToContent $ applyLayout y pc rr
return $ chooseRep
[ (TypeHtml, content)
]
return $ RepHtml content
getApproot :: Yesod y => Handler y Approot
getApproot = approot `fmap` getYesod
simpleApplyLayout' :: Yesod master
=> String -- ^ title
-> Hamlet (Routes sub) IO () -- ^ body
-> GHandler sub master ChooseRep
simpleApplyLayout' t = fmap chooseRep . simpleApplyLayout t
defaultErrorHandler :: Yesod y => ErrorResponse -> Handler y ChooseRep
defaultErrorHandler NotFound = do
r <- waiRequest
simpleApplyLayout "Not Found" $ [$hamlet|
simpleApplyLayout' "Not Found" $ [$hamlet|
%h1 Not Found
%p $helper$
|] r
where
helper = Unencoded . cs . W.pathInfo
defaultErrorHandler PermissionDenied =
simpleApplyLayout "Permission Denied" $ [$hamlet|
simpleApplyLayout' "Permission Denied" $ [$hamlet|
%h1 Permission denied|] ()
defaultErrorHandler (InvalidArgs ia) =
simpleApplyLayout "Invalid Arguments" $ [$hamlet|
simpleApplyLayout' "Invalid Arguments" $ [$hamlet|
%h1 Invalid Arguments
%dl
$forall ias pair
@ -120,12 +124,12 @@ defaultErrorHandler (InvalidArgs ia) =
where
ias _ = map (cs *** cs) ia
defaultErrorHandler (InternalError e) =
simpleApplyLayout "Internal Server Error" $ [$hamlet|
simpleApplyLayout' "Internal Server Error" $ [$hamlet|
%h1 Internal Server Error
%p $cs$
|] e
defaultErrorHandler (BadMethod m) =
simpleApplyLayout "Bad Method" $ [$hamlet|
simpleApplyLayout' "Bad Method" $ [$hamlet|
%h1 Method Not Supported
%p Method "$cs$" not supported
|] m

2
examples/helloworld.lhs
View File

@ -15,7 +15,7 @@ mkYesod "HelloWorld" [$parseRoutes|
instance Yesod HelloWorld where
approot _ = "http://localhost:3000"
getHome :: Handler HelloWorld ChooseRep
getHome :: Handler HelloWorld RepHtml
getHome = simpleApplyLayout "Hello World" $ cs "Hello world!"
main :: IO ()