From c91a4ada567f17752b7ff15826bd2d7072a4cb0d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 30 Jun 2010 12:23:55 +0300 Subject: [PATCH] Changes reflecting web-routes-quasi modifications. Minimal changes to get hello world working. --- Yesod.hs | 2 -- Yesod/Dispatch.hs | 82 ++++++++++++++++++++++++++--------------------- Yesod/Formable.hs | 2 +- Yesod/Hamlet.hs | 1 - Yesod/Handler.hs | 6 ++-- Yesod/Yesod.hs | 6 ++-- helloworld.hs | 7 ++++ 7 files changed, 61 insertions(+), 45 deletions(-) create mode 100644 helloworld.hs diff --git a/Yesod.hs b/Yesod.hs index 90fa85bd..073a625a 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -13,7 +13,6 @@ module Yesod , module Yesod.Formable , Application , liftIO - , Routes ) where #if TEST @@ -34,4 +33,3 @@ import Yesod.Handler hiding (runHandler) import Network.Wai (Application) import Yesod.Hamlet import "transformers" Control.Monad.IO.Class (liftIO) -import Web.Routes.Quasi (Routes) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 378c01d3..3ac56f2f 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -18,7 +18,6 @@ module Yesod.Dispatch , basicHandler -- * Utilities , fullRender - , quasiRender #if TEST , testSuite #endif @@ -30,6 +29,9 @@ import Yesod.Request import Yesod.Internal import Web.Routes.Quasi +import Web.Routes.Quasi.Parse +import Web.Routes.Quasi.TH +import Web.Routes.Site import Language.Haskell.TH.Syntax import qualified Network.Wai as W @@ -102,7 +104,7 @@ mkYesodData :: String -> [Resource] -> Q [Dec] mkYesodData name res = do (x, _) <- mkYesodGeneral name [] [] False res let rname = mkName $ "resources" ++ name - eres <- liftResources res + eres <- lift res let y = [ SigD rname $ ListT `AppT` ConT ''Resource , FunD rname [Clause [] (NormalB eres) []] ] @@ -142,6 +144,32 @@ mkYesodGeneral name args clazzes isSub res = do $ map (\x -> (x, [])) ("master" : args) ++ clazzes explode <- [|explodeHandler|] + let th = map thResourceFromResource res + w' <- createRoutes th + let w = DataD [] (mkName $ name ++ "Routes") [] w' [] + let x = TySynInstD ''Routes [arg] $ ConT $ mkName $ name ++ "Routes" + + parse' <- createParse th + parse'' <- newName "parse" + let parse = LetE [FunD parse'' parse'] $ VarE parse'' + + render' <- createRender th + render'' <- newName "render" + let render = LetE [FunD render'' render'] $ VarE render'' + + id' <- [|id|] + modMaster <- [|fmap chooseRep|] + dispatch' <- createDispatch modMaster id' th + dispatch'' <- newName "dispatch" + let dispatch = LetE [FunD dispatch'' dispatch'] $ LamE [WildP] $ VarE dispatch'' + + site <- [|Site|] + let site' = site `AppE` dispatch `AppE` render `AppE` parse + let y = InstanceD [] (ConT ''YesodSite `AppT` arg) + [ FunD (mkName "getSite") [Clause [] (NormalB site') []] + ] + let z = undefined + {- QuasiSiteDecs w x y z <- createQuasiSite QuasiSiteSettings { crRoutes = mkName $ name ++ "Routes" , crApplication = ConT ''YesodApp @@ -153,7 +181,11 @@ mkYesodGeneral name args clazzes isSub res = do then Right clazzes' else Left (ConT name') } - return ([w, x], (if isSub then id else (:) yes) [y, z]) + -} + return ([w, x], [y]) + +thResourceFromResource :: Resource -> THResource +thResourceFromResource (Resource n ps (ByMethod ms)) = (n, Simple ps $ map fst ms) compact :: [(String, [a])] -> [(String, [a])] compact [] = [] @@ -193,41 +225,23 @@ toWaiApp' y segments env = do method = B.unpack $ W.methodToBS $ W.requestMethod env types = httpAccept env pathSegments = filter (not . null) segments - eurl = quasiParse site pathSegments + eurl = parsePathSegments site pathSegments render u = fromMaybe - (fullRender (approot y) (quasiRender site) u) + (fullRender (approot y) (formatPathSegments site) u) (urlRenderOverride y u) rr <- parseWaiRequest env session' onRequest y rr - ya <- - case eurl of - Left _ -> return $ runHandler (errorHandler y NotFound) - render - Nothing - id - y - id - Right url -> do - auth <- isAuthorized y url - case auth of - Nothing -> return $ quasiDispatch site - render - url - id - y - id - (badMethodApp method) - method - Just msg -> - return $ runHandler - (errorHandler y $ PermissionDenied msg) - render - (Just url) - id - y - id + let h = + case eurl of + Left _ -> errorHandler y NotFound + Right url -> do + -- FIXME auth <- isAuthorized y url + case handleSite site render url method of + Nothing -> errorHandler y $ BadMethod method + Just h' -> h' let eurl' = either (const Nothing) Just eurl let eh er = runHandler (errorHandler y er) render eurl' id y id + let ya = runHandler h render eurl' id y id (s, hs, ct, c, sessionFinal) <- unYesodApp ya eh rr types let sessionVal = encodeSession key' exp' host sessionFinal let hs' = AddCookie (clientSessionDuration y) sessionName @@ -271,10 +285,6 @@ basicHandler port app = do SS.run port app Just _ -> CGI.run app -badMethodApp :: String -> YesodApp -badMethodApp m = YesodApp $ \eh req cts - -> unYesodApp (eh $ BadMethod m) eh req cts - fixSegs :: [String] -> [String] fixSegs [] = [] fixSegs [x] diff --git a/Yesod/Formable.hs b/Yesod/Formable.hs index 33c1305a..bb39be50 100644 --- a/Yesod/Formable.hs +++ b/Yesod/Formable.hs @@ -38,7 +38,7 @@ import Yesod.Request import Yesod.Handler import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.State -import Web.Routes.Quasi (Routes, SinglePiece) +import Web.Routes.Quasi (SinglePiece) import Data.Int (Int64) sealRow :: Formable b => String -> (a -> b) -> Maybe a -> Form sub master b diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index 6ddce335..7aa6992b 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -17,7 +17,6 @@ module Yesod.Hamlet import Text.Hamlet import Yesod.Content import Yesod.Handler -import Web.Routes.Quasi (Routes) -- | Content for a web page. By providing this datatype, we can easily create -- generic site templates, which would have the type signature: diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index d4cef5b1..1b47d79a 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -63,13 +63,13 @@ module Yesod.Handler -- * Internal Yesod , runHandler , YesodApp (..) + , Routes ) where import Prelude hiding (catch) import Yesod.Request import Yesod.Content import Yesod.Internal -import Web.Routes.Quasi (Routes) import Data.List (foldl', intercalate) import Data.Neither @@ -81,7 +81,7 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Writer import Control.Monad.Trans.Reader -import Control.Monad.CatchIO (MonadCatchIO) +import "MonadCatchIO-transformers" Control.Monad.CatchIO (MonadCatchIO) import System.IO import qualified Network.Wai as W @@ -93,6 +93,8 @@ import Text.Hamlet import Numeric (showIntAtBase) import Data.Char (ord, chr) +type family Routes a + data HandlerData sub master = HandlerData { handlerRequest :: Request , handlerSub :: sub diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index d70ba3d1..870fb3a8 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -31,13 +31,13 @@ import qualified Web.ClientSession as CS import Data.Monoid (mempty) import Data.ByteString.UTF8 (toString) import Database.Persist - -import Web.Routes.Quasi (QuasiSite (..), Routes) +import Web.Routes.Site (Site) -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. class YesodSite y where - getSite :: QuasiSite YesodApp y y + getSite :: Site (Routes y) (Method -> Maybe (Handler y ChooseRep)) +type Method = String -- | Define settings for a Yesod applications. The only required setting is -- 'approot'; other than that, there are intelligent defaults. diff --git a/helloworld.hs b/helloworld.hs new file mode 100644 index 00000000..2e26b7a8 --- /dev/null +++ b/helloworld.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeFamilies, QuasiQuotes #-} +import Yesod +data HelloWorld = HelloWorld +mkYesod "HelloWorld" [$parseRoutes|/ Home GET|] +instance Yesod HelloWorld where approot _ = "" +getHome = return $ RepPlain $ toContent "Hello World!" +main = toWaiApp HelloWorld >>= basicHandler 3000