diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 3a95145c..b5a8853a 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -4,6 +4,7 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE TypeFamilies #-} --------------------------------------------------------- -- -- Module : Yesod.Handler @@ -21,8 +22,11 @@ module Yesod.Handler ( -- * Handler monad Handler , getYesod + , getUrlRender , runHandler , liftIO + , YesodApp + , Routes -- * Special handlers , redirect , sendFile @@ -51,7 +55,14 @@ import Data.Object.Html import qualified Data.ByteString.Lazy as BL import qualified Network.Wai as W -data HandlerData yesod = HandlerData Request yesod +type family Routes y + +data HandlerData yesod = HandlerData Request yesod (Routes yesod -> String) + +type YesodApp yesod = (ErrorResponse -> Handler yesod ChooseRep) + -> Request + -> [ContentType] + -> IO Response ------ Handler monad newtype Handler yesod a = Handler { @@ -84,27 +95,25 @@ instance MonadIO (Handler yesod) where instance Failure ErrorResponse (Handler yesod) where failure e = Handler $ \_ -> return ([], HCError e) instance RequestReader (Handler yesod) where - getRequest = Handler $ \(HandlerData rr _) + getRequest = Handler $ \(HandlerData rr _ _) -> return ([], HCContent rr) getYesod :: Handler yesod yesod -getYesod = Handler $ \(HandlerData _ yesod) -> return ([], HCContent yesod) +getYesod = Handler $ \(HandlerData _ yesod _) -> return ([], HCContent yesod) -runHandler :: Handler yesod ChooseRep - -> (ErrorResponse -> Handler yesod ChooseRep) - -> Request - -> yesod - -> [ContentType] - -> IO Response -runHandler handler eh rr y cts = do +getUrlRender :: Handler yesod (Routes yesod -> String) +getUrlRender = Handler $ \(HandlerData _ _ r) -> return ([], HCContent r) + +runHandler :: HasReps c => Handler yesod c -> yesod -> (Routes yesod -> String) -> YesodApp yesod +runHandler handler y render eh rr cts = do let toErrorHandler = InternalError . (show :: Control.Exception.SomeException -> String) (headers, contents) <- Control.Exception.catch - (unHandler handler $ HandlerData rr y) + (unHandler handler $ HandlerData rr y render) (\e -> return ([], HCError $ toErrorHandler e)) let handleError e = do - Response _ hs ct c <- runHandler (eh e) safeEh rr y cts + Response _ hs ct c <- runHandler (eh e) y render safeEh rr cts let hs' = headers ++ hs return $ Response (getStatus e) hs' ct c let sendFile' ct fp = do @@ -119,7 +128,7 @@ runHandler handler eh rr y cts = do (sendFile' ct fp) (handleError . toErrorHandler) HCContent a -> do - (ct, c) <- a cts + (ct, c) <- chooseRep a cts return $ Response W.Status200 headers ct c safeEh :: ErrorResponse -> Handler yesod ChooseRep diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 7c9c4a03..fd8c5dd9 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -1,16 +1,29 @@ ---------------------------------------------------------- --- --- Module : Yesod.Resource --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Stable --- Portability : portable --- --- Defines the ResourceName class. --- ---------------------------------------------------------- +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} module Yesod.Resource - ( + ( parseRoutes + , mkYesod ) where + +import Web.Routes.Quasi (parseRoutes, createRoutes, Resource (..)) +import Yesod.Handler +import Language.Haskell.TH.Syntax +import Yesod.Yesod + +mkYesod :: String -> [Resource] -> Q [Dec] +mkYesod name res = do + let name' = mkName name + let yaname = mkName $ name ++ "YesodApp" + let ya = TySynD yaname [] $ ConT ''YesodApp `AppT` ConT name' + let tySyn = TySynInstD ''Routes [ConT $ name'] (ConT $ mkName $ name ++ "Routes") + let hand = TySynD (mkName $ name ++ "Handler") [PlainTV $ mkName "a"] + $ ConT ''Handler `AppT` ConT name' `AppT` VarT (mkName "a") + let gsbod = NormalB $ VarE $ mkName $ "site" ++ name ++ "Routes" + let yes' = FunD (mkName "getSite") [Clause [] gsbod []] + let yes = InstanceD [] (ConT ''YesodSite `AppT` ConT name') [yes'] + decs <- createRoutes (name ++ "Routes") + yaname + name' + "runHandler" + res + return $ ya : tySyn : hand : yes : decs diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index a8e09714..30ff6e41 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -1,6 +1,7 @@ -- | The basic typeclass for a Yesod application. module Yesod.Yesod ( Yesod (..) + , YesodSite (..) , YesodApproot (..) , applyLayout' , applyLayoutJson @@ -20,6 +21,7 @@ import qualified Data.ByteString as B import Data.Maybe (fromMaybe) import Web.Mime import Web.Encodings (parseHttpAccept) +import Web.Routes (Site (..)) import qualified Network.Wai as W import Network.Wai.Middleware.CleanPath @@ -32,11 +34,13 @@ import qualified Network.Wai.Handler.SimpleServer as SS import qualified Network.Wai.Handler.CGI as CGI import System.Environment (getEnvironment) -class Yesod a where - -- | Please use the Quasi-Quoter, you\'ll be happier. For more information, - -- see the examples/fact.lhs sample. - resources :: Resource -> W.Method -> Handler a ChooseRep +class YesodSite y where + getSite :: ((String -> YesodApp y) -> YesodApp y) -- ^ get the method + -> YesodApp y -- ^ bad method + -> y + -> Site (Routes y) (YesodApp y) +class YesodSite a => Yesod a where -- | The encryption key to be used for encrypting client sessions. encryptKey :: a -> IO Word256 encryptKey _ = getKey defaultKeyFile @@ -62,6 +66,8 @@ class Yesod a where onRequest :: a -> Request -> IO () onRequest _ _ = return () + badMethod :: a -> YesodApp a + class Yesod a => YesodApproot a where -- | An absolute URL to the root of the application. approot :: a -> Approot @@ -133,12 +139,24 @@ toWaiApp' :: Yesod y -> W.Request -> IO W.Response toWaiApp' y resource session env = do - let types = httpAccept env - handler = resources (map cs resource) $ W.requestMethod env - rr <- parseWaiRequest env session - onRequest y rr - res <- runHandler handler errorHandler rr y types - responseToWaiResponse res + let site = getSite getMethod (badMethod y) y + types = httpAccept env + pathSegments = map cleanupSegment resource + eurl = parsePathSegments site pathSegments + case eurl of + Left _ -> error "FIXME: send 404 message" + Right url -> do + rr <- parseWaiRequest env session + onRequest y rr + let render = error "FIXME: render" -- use formatPathSegments + res <- handleSite site render url errorHandler rr types + responseToWaiResponse res + +getMethod :: (String -> YesodApp y) -> YesodApp y +getMethod = error "FIXME: getMethod" + +cleanupSegment :: B.ByteString -> String +cleanupSegment = error "FIXME: cleanupSegment" httpAccept :: W.Request -> [ContentType] httpAccept = map contentTypeFromBS diff --git a/yesod.cabal b/yesod.cabal index b1d08cd1..8a4843b0 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -58,7 +58,9 @@ library attempt >= 0.2.1 && < 0.3, template-haskell, failure >= 0.0.0 && < 0.1, - safe-failure >= 0.4.0 && < 0.5 + safe-failure >= 0.4.0 && < 0.5, + web-routes >= 0.20 && < 0.21, + web-routes-quasi >= 0.0 && < 0.1 exposed-modules: Yesod Yesod.Request Yesod.Response