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

Added Yesod parameter to Handler

Browse Source
This commit is contained in:
Michael Snoyman 2009-12-13 09:50:43 +02:00
parent 4650cf4e92
commit ac54b644bc
7 changed files with 74 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Yesod/Application.hs
View File

@ -102,7 +102,7 @@ takeJusts (Just x:rest) = x : takeJusts rest
toHackApplication :: RestfulApp resourceName
=> resourceName
-> (resourceName -> Verb -> Handler [(ContentType, Content)])
-> (resourceName -> Verb -> Handler resourceName [(ContentType, Content)])
-> Hack.Application
toHackApplication sampleRN hm env = do
-- The following is safe since we run cleanPath as middleware
@ -117,7 +117,7 @@ toHackApplication sampleRN hm env = do
let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env
ctypes' = map TypeOther $ parseHttpAccept rawHttpAccept
r <-
runHandler handler rr ctypes' >>=
runHandler handler rr sampleRN ctypes' >>=
either (applyErrorHandler sampleRN rr ctypes') return
responseToHackResponse (rawLanguages rr) r

43
Yesod/Handler.hs
View File

@ -19,6 +19,7 @@
module Yesod.Handler
( -- * Handler monad
Handler
, getYesod
, runHandler
, liftIO
--, ToHandler (..)
@ -44,20 +45,20 @@ import Control.Monad.Attempt
--import Data.Typeable
------ Handler monad
newtype Handler a = Handler {
unHandler :: RawRequest -> IO ([Header], HandlerContents a)
newtype Handler yesod a = Handler {
unHandler :: (RawRequest, yesod) -> IO ([Header], HandlerContents a)
}
data HandlerContents a =
forall e. Exception e => HCError e
| HCSpecial ErrorResult
| HCContent a
instance Functor Handler where
instance Functor (Handler yesod) where
fmap = liftM
instance Applicative Handler where
instance Applicative (Handler yesod) where
pure = return
(<*>) = ap
instance Monad Handler where
instance Monad (Handler yesod) where
fail = failureString -- We want to catch all exceptions anyway
return x = Handler $ \_ -> return ([], HCContent x)
(Handler handler) >>= f = Handler $ \rr -> do
@ -68,23 +69,27 @@ instance Monad Handler where
(HCSpecial e) -> return $ ([], HCSpecial e)
(HCContent a) -> unHandler (f a) rr
return (headers ++ headers', c')
instance MonadIO Handler where
instance MonadIO (Handler yesod) where
liftIO i = Handler $ \_ -> i >>= \i' -> return ([], HCContent i')
instance Exception e => Failure e Handler where
instance Exception e => Failure e (Handler yesod) where
failure e = Handler $ \_ -> return ([], HCError e)
instance MonadRequestReader Handler where
askRawRequest = Handler $ \rr -> return ([], HCContent rr)
instance MonadRequestReader (Handler yesod) where
askRawRequest = Handler $ \(rr, _) -> return ([], HCContent rr)
invalidParam _pt _pn _pe = error "invalidParam"
authRequired = error "authRequired"
getYesod :: Handler yesod yesod
getYesod = Handler $ \(_, yesod) -> return ([], HCContent yesod)
-- FIXME this is a stupid signature
runHandler :: HasReps a
=> Handler a
=> Handler yesod a
-> RawRequest
-> yesod
-> [ContentType]
-> IO (Either (ErrorResult, [Header]) Response)
runHandler (Handler handler) rr cts = do
(headers, contents) <- handler rr
runHandler (Handler handler) rr yesod cts = do
(headers, contents) <- handler (rr, yesod)
case contents of
HCError e -> return $ Left (InternalError $ show e, headers)
HCSpecial e -> return $ Left (e, headers)
@ -171,15 +176,15 @@ runHandler eh wrapper ctypesAll (HandlerT inside) rr = do
-}
------ Special handlers
errorResult :: ErrorResult -> Handler a
errorResult :: ErrorResult -> Handler yesod a
errorResult er = Handler $ \_ -> return ([], HCSpecial er)
-- | Redirect to the given URL.
redirect :: String -> Handler a
redirect :: String -> Handler yesod a
redirect = errorResult . Redirect
-- | Return a 404 not found page. Also denotes no handler available.
notFound :: Handler a
notFound :: Handler yesod a
notFound = errorResult NotFound
------- Headers
@ -187,16 +192,16 @@ notFound = errorResult NotFound
addCookie :: Int -- ^ minutes to timeout
-> String -- ^ key
-> String -- ^ value
-> Handler ()
-> Handler yesod ()
addCookie a b = addHeader . AddCookie a b
-- | Unset the cookie on the client.
deleteCookie :: String -> Handler ()
deleteCookie :: String -> Handler yesod ()
deleteCookie = addHeader . DeleteCookie
-- | Set an arbitrary header on the client.
header :: String -> String -> Handler ()
header :: String -> String -> Handler yesod ()
header a = addHeader . Header a
addHeader :: Header -> Handler ()
addHeader :: Header -> Handler yesod ()
addHeader h = Handler $ \_ -> return ([h], HCContent ())

14
Yesod/Helpers/Auth.hs
View File

@ -60,7 +60,7 @@ instance Enumerable AuthResource where
newtype RpxnowApiKey = RpxnowApiKey String
authHandler :: Maybe RpxnowApiKey -> AuthResource -> Verb -> Handler HtmlObject
authHandler :: Maybe RpxnowApiKey -> AuthResource -> Verb -> Handler y HtmlObject
authHandler _ Check Get = authCheck
authHandler _ Logout Get = authLogout
authHandler _ Openid Get = authOpenidForm
@ -88,7 +88,7 @@ instance Show OIDFormReq where
show (OIDFormReq (Just s) _) = "<p class='message'>" ++ encodeHtml s ++
"</p>"
authOpenidForm :: Handler HtmlObject
authOpenidForm :: Handler y HtmlObject
authOpenidForm = do
m@(OIDFormReq _ dest) <- parseRequest
let html =
@ -102,7 +102,7 @@ authOpenidForm = do
Nothing -> return ()
return $ toHtmlObject $ Html $ cs html
authOpenidForward :: Handler HtmlObject
authOpenidForward :: Handler y HtmlObject
authOpenidForward = do
oid <- getParam "openid"
env <- parseEnv
@ -115,7 +115,7 @@ authOpenidForward = do
redirect
res
authOpenidComplete :: Handler HtmlObject
authOpenidComplete :: Handler y HtmlObject
authOpenidComplete = do
gets' <- rawGetParams <$> askRawRequest
dest <- cookieParam "DEST"
@ -141,7 +141,7 @@ chopHash ('#':rest) = rest
chopHash x = x
rpxnowLogin :: String -- ^ api key
-> Handler HtmlObject
-> Handler y HtmlObject
rpxnowLogin apiKey = do
token <- anyParam "token"
postDest <- postParam "dest"
@ -157,7 +157,7 @@ rpxnowLogin apiKey = do
header authCookieName $ Rpxnow.identifier ident
redirect dest
authCheck :: Handler HtmlObject
authCheck :: Handler y HtmlObject
authCheck = do
ident <- maybeIdentifier
case ident of
@ -167,7 +167,7 @@ authCheck = do
, ("ident", i)
]
authLogout :: Handler HtmlObject
authLogout :: Handler y HtmlObject
authLogout = do
deleteCookie authCookieName
return $ toHtmlObject [("status", "loggedout")]

11
Yesod/Helpers/Sitemap.hs
View File

@ -30,6 +30,7 @@ import qualified Hack
import Yesod.Request
import Data.Time (UTCTime)
import Data.Convertible.Text (cs)
import Yesod.Yesod
data SitemapLoc = AbsLoc String | RelLoc String
data SitemapChangeFreq = Always
@ -86,7 +87,7 @@ instance HasReps SitemapResponse where
[ (TypeXml, cs . show)
]
sitemap :: IO [SitemapUrl] -> Handler SitemapResponse
sitemap :: IO [SitemapUrl] -> Handler yesod SitemapResponse
sitemap urls' = do
env <- parseEnv
-- FIXME
@ -94,6 +95,8 @@ sitemap urls' = do
urls <- liftIO urls'
return $ SitemapResponse req urls
robots :: Approot -> Handler Plain
robots (Approot ar) = do
return $ plain $ "Sitemap: " ++ ar ++ "sitemap.xml"
robots :: Yesod yesod => Handler yesod Plain
robots = do
yesod <- getYesod
return $ plain $ "Sitemap: " ++ unApproot (approot yesod)
++ "sitemap.xml"

4
Yesod/Helpers/Static.hs
View File

@ -40,11 +40,11 @@ fileLookupDir dir fp = do
then Just <$> B.readFile fp'
else return Nothing
serveStatic :: FileLookup -> Verb -> Handler [(ContentType, Content)]
serveStatic :: FileLookup -> Verb -> Handler y [(ContentType, Content)]
serveStatic fl Get = getStatic fl
serveStatic _ _ = notFound
getStatic :: FileLookup -> Handler [(ContentType, Content)]
getStatic :: FileLookup -> Handler y [(ContentType, Content)]
getStatic fl = do
fp <- urlParam "filepath" -- FIXME check for ..
content <- liftIO $ fl fp

5
Yesod/Resource.hs
View File

@ -19,6 +19,7 @@
---------------------------------------------------------
module Yesod.Resource
( ResourceName (..)
, ResourcePatternString
, fromString
, checkPattern
, validatePatterns
@ -92,7 +93,9 @@ class (Show a, Enumerable a) => ResourceName a where
resourcePattern :: a -> String
-- | Find the handler for each resource name/verb pattern.
getHandler :: a -> Verb -> Handler [(ContentType, Content)] -- FIXME
getHandler :: a -> Verb -> Handler a [(ContentType, Content)] -- FIXME
type ResourcePatternString = String
type SMap = [(String, String)]

57
Yesod/Yesod.hs
View File

@ -1,7 +1,6 @@
-- | The basic typeclass for a Yesod application.
module Yesod.Yesod
( Yesod (..)
, Handler
, toHackApp
) where
@ -10,10 +9,10 @@ import Data.Object.Html (toHtmlObject)
import Yesod.Response
import Yesod.Request
import Yesod.Constants
--import Yesod.Definitions
--import Yesod.Resource (checkResourceName)
import Yesod.Definitions
import Yesod.Resource
import Yesod.Handler
import Control.Applicative
--import Control.Monad (when)
import qualified Hack
@ -23,11 +22,12 @@ import Hack.Middleware.Gzip
import Hack.Middleware.Jsonp
import Hack.Middleware.MethodOverride
type Handler a v = a -> IO v -- FIXME
type HandlerMap a = [(String, [ContentType] -> Handler a Content)]
type ContentPair = (ContentType, Content)
class Yesod a where
handlers :: HandlerMap a
handlers ::
[(ResourcePatternString,
[(Verb, [ContentType] -> Handler a ContentPair)])]
-- | The encryption key to be used for encrypting client sessions.
encryptKey :: a -> IO Word256
@ -43,37 +43,36 @@ class Yesod a where
]
-- | Output error response pages.
errorHandler :: a -> RawRequest -> ErrorResult -> [ContentType] -> (ContentType, Content) -- FIXME better type sig?
errorHandler :: ErrorResult -> [ContentType] -> Handler a ContentPair
errorHandler = defaultErrorHandler
-- | Whether or not we should check for overlapping resource names.
checkOverlaps :: a -> Bool
checkOverlaps = const True
newtype MyIdentity a = MyIdentity { _unMyIdentity :: a }
instance Functor MyIdentity where
fmap f (MyIdentity a) = MyIdentity $ f a
instance Applicative MyIdentity where
pure = MyIdentity
(MyIdentity f) <*> (MyIdentity a) = MyIdentity $ f a
-- | An absolute URL to the root of the application.
approot :: a -> Approot
defaultErrorHandler :: a
-> RawRequest
-> ErrorResult
defaultErrorHandler :: Yesod y
=> ErrorResult
-> [ContentType]
-> (ContentType, Content)
defaultErrorHandler _ rr NotFound = chooseRep $ toHtmlObject $
"Not found: " ++ show rr
defaultErrorHandler _ _ (Redirect url) =
chooseRep $ toHtmlObject $ "Redirect to: " ++ url
defaultErrorHandler _ _ (InternalError e) =
chooseRep $ toHtmlObject $ "Internal server error: " ++ e
defaultErrorHandler _ _ (InvalidArgs ia) =
chooseRep $ toHtmlObject
-> Handler y ContentPair
defaultErrorHandler NotFound cts = do
rr <- askRawRequest
return $ chooseRep (toHtmlObject $ "Not found: " ++ show rr) cts
defaultErrorHandler (Redirect url) cts =
return $ chooseRep (toHtmlObject $ "Redirect to: " ++ url) cts
defaultErrorHandler PermissionDenied cts =
return $ chooseRep (toHtmlObject "Permission denied") cts
defaultErrorHandler (InvalidArgs ia) cts =
return $ chooseRep (toHtmlObject
[ ("errorMsg", toHtmlObject "Invalid arguments")
, ("messages", toHtmlObject ia)
]
defaultErrorHandler _ _ PermissionDenied =
chooseRep $ toHtmlObject "Permission denied"
]) cts
defaultErrorHandler (InternalError e) cts =
return $ chooseRep (toHtmlObject
[ ("Internal server error", e)
]) cts
toHackApp :: Yesod y => y -> Hack.Application
toHackApp a env = do