Steps towards unifying on YesodDispatch

2011-01-28 10:30:02 +02:00 · 2011-01-28 10:30:02 +02:00 · 09e93e96a1
commit 09e93e96a1
parent c87068b7fb
4 changed files with 67 additions and 52 deletions
--- a/Yesod/Core.hs
+++ b/Yesod/Core.hs
@ -80,11 +80,17 @@ import qualified Data.Text.Encoding
 class Eq u => RenderRoute u where
    renderRoute :: u -> ([String], [(String, String)])

-- FIXME unify YesodSite and YesodSubSite
 -- | This class is automatically instantiated when you use the template haskell
 -- mkYesod function. You should never need to deal with it directly.
-class RenderRoute (Route y) => YesodDispatch y where
-    yesodDispatch :: y -> Maybe CS.Key -> [String] -> Maybe W.Application
+class Yesod master => YesodDispatch a master where
+    yesodDispatch
+        :: (Yesod master)
+        => a
+        -> Maybe CS.Key
+        -> [String]
+        -> master
+        -> (Route a -> Route master)
+        -> Maybe W.Application

 -- | Same as 'YesodSite', but for subsites. Once again, users should not need
 -- to deal with it directly, as mkYesodSub creates instances appropriately.
@ -246,22 +252,29 @@ class RenderRoute (Route a) => Yesod a where
    sessionIpAddress :: a -> Bool
    sessionIpAddress _ = True

-    yesodRunner :: a -> Maybe CS.Key -> Maybe (Route a) -> GHandler a a ChooseRep -> W.Application
+    -- FIXME this probably needs to be a part of YesodDispatch
+    yesodRunner :: Yesod master
+                => a
+                -> master
+                -> (Route a -> Route master)
+                -> Maybe CS.Key -> Maybe (Route a) -> GHandler a master ChooseRep -> W.Application
    yesodRunner = defaultYesodRunner

-defaultYesodRunner :: Yesod a
+defaultYesodRunner :: Yesod master
                   => a
+                   -> master
+                   -> (Route a -> Route master)
                   -> Maybe CS.Key
                   -> Maybe (Route a)
-                   -> GHandler a a ChooseRep
+                   -> GHandler a master ChooseRep
                   -> W.Application
-defaultYesodRunner y mkey murl handler req = do
+defaultYesodRunner s master toMasterRoute mkey murl handler req = do
    now <- liftIO getCurrentTime
    let getExpires m = fromIntegral (m * 60) `addUTCTime` now
-    let exp' = getExpires $ clientSessionDuration y
+    let exp' = getExpires $ clientSessionDuration master
    -- FIXME will show remoteHost give the answer I need? will it include port
    -- information that changes on each request?
-    let host = if sessionIpAddress y then S8.pack (show (W.remoteHost req)) else ""
+    let host = if sessionIpAddress master then S8.pack (show (W.remoteHost req)) else ""
    let session' =
            case mkey of
                Nothing -> []
@ -274,12 +287,12 @@ defaultYesodRunner y mkey murl handler req = do
          case murl of
            Nothing -> handler
            Just url -> do
-                isWrite <- isWriteRequest url
-                ar <- isAuthorized url isWrite
+                isWrite <- isWriteRequest $ toMasterRoute url
+                ar <- isAuthorized (toMasterRoute url) isWrite
                case ar of
                    Authorized -> return ()
                    AuthenticationRequired ->
-                        case authRoute y of
+                        case authRoute master of
                            Nothing ->
                                permissionDenied "Authentication required"
                            Just url' -> do
@ -289,7 +302,7 @@ defaultYesodRunner y mkey murl handler req = do
                handler
    let sessionMap = Map.fromList
                   $ filter (\(x, _) -> x /= nonceKey) session'
-    yar <- handlerToYAR y (yesodRender y) errorHandler rr murl sessionMap h
+    yar <- handlerToYAR master s toMasterRoute (yesodRender master) errorHandler rr murl sessionMap h
    let mnonce = reqNonce rr
    return $ yarToResponse (hr mnonce getExpires host exp') yar
  where
@ -307,7 +320,7 @@ defaultYesodRunner y mkey murl handler req = do
            case mkey of
                Nothing -> hs
                Just _ -> AddCookie
-                            (clientSessionDuration y)
+                            (clientSessionDuration master)
                            sessionName
                            sessionVal
                          : hs
--- a/Yesod/Dispatch.hs
+++ b/Yesod/Dispatch.hs
@ -177,20 +177,10 @@ mkYesodGeneral name args clazzes isSub res = do
    subsiteClauses <- catMaybes <$> mapM mkDispatchToSubsite th'
    let subSubsiteClauses = [] -- FIXME subSubsiteClauses
    nothing <- [|Nothing|]
-    dds <- [|defaultDispatchSubsite|]
-    let otherMethods =
-            if isSub
-                then [ FunD (mkName "dispatchSubsite") [Clause [] (NormalB dds) []]
-                     , FunD (mkName "dispatchToSubSubsite")
-                        (subSubsiteClauses ++ [Clause [WildP, WildP, WildP, WildP, WildP] (NormalB nothing) []])
-                     ]
-                else [ FunD (mkName "dispatchToSubsite")
-                        (subsiteClauses ++ [Clause [WildP, WildP, WildP] (NormalB nothing) []])
-                     ]
    let mkYSS = InstanceD clazzes (ConT ''YesodSubSite `AppT` arg `AppT` VarT (mkName "master"))
                [
                ]
-        mkYS = InstanceD [] (ConT ''YesodDispatch `AppT` arg) [FunD (mkName "yesodDispatch") [yd]]
+        mkYS = InstanceD [] (ConT ''YesodDispatch `AppT` arg `AppT` arg) [FunD (mkName "yesodDispatch") [yd]]
    let y = if isSub then mkYSS else mkYS {-InstanceD ctx ytyp
                $ FunD (mkName yfunc) [Clause [] (NormalB site') []]
                : otherMethods -}
@ -200,26 +190,28 @@ isSubSite ((_, SubSite{}), _) = True
 isSubSite _ = False

 mkYesodDispatch' sortedRes = do
+    sub <- newName "sub"
    master <- newName "master"
    mkey <- newName "mkey"
    segments <- newName "segments"
+    toMasterRoute <- newName "toMasterRoute"
    nothing <- [|Nothing|]
-    body <- foldM (go master mkey segments) nothing sortedRes
+    body <- foldM (go master sub toMasterRoute mkey segments) nothing sortedRes
    return $ Clause
-        [VarP master, VarP mkey, VarP segments]
+        [VarP master, VarP mkey, VarP segments, VarP sub, VarP toMasterRoute]
        (NormalB body)
        []
  where
-    go master mkey segments onFail ((constr, SubSite { ssPieces = pieces }), Just toSub) = do
-        test <- mkSubsiteExp segments pieces id (master, mkey, constr, toSub)
+    go master sub toMasterRoute mkey segments onFail ((constr, SubSite { ssPieces = pieces }), Just toSub) = do
+        test <- mkSubsiteExp segments pieces id (master, sub, toMasterRoute, mkey, constr, toSub)
        just <- [|Just|]
        app <- newName "app"
        return $ CaseE test
            [ Match (ConP (mkName "Nothing") []) (NormalB onFail) []
            , Match (ConP (mkName "Just") [VarP app]) (NormalB $ just `AppE` VarE app) []
            ]
-    go master mkey segments onFail ((constr, Simple pieces methods), Nothing) = do
-        test <- mkSimpleExp segments pieces id (master, mkey, constr, methods)
+    go master sub toMasterRoute mkey segments onFail ((constr, Simple pieces methods), Nothing) = do
+        test <- mkSimpleExp segments pieces id (master, sub, toMasterRoute, mkey, constr, methods)
        just <- [|Just|]
        app <- newName "app"
        return $ CaseE test
@ -227,7 +219,7 @@ mkYesodDispatch' sortedRes = do
            , Match (ConP (mkName "Just") [VarP app]) (NormalB $ just `AppE` VarE app) []
            ]

-mkSimpleExp segments [] frontVars (master, mkey, constr, methods) = do
+mkSimpleExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, methods) = do
    just <- [|Just|]
    nothing <- [|Nothing|]
    onSuccess <- newName "onSuccess"
@ -239,7 +231,13 @@ mkSimpleExp segments [] frontVars (master, mkey, constr, methods) = do
    cr <- [|fmap chooseRep|]
    let url = foldl' AppE (ConE $ mkName constr) $ frontVars []
    let runHandlerVars h = runHandler $ foldl' AppE (cr `AppE` (VarE $ mkName h)) $ frontVars []
-        runHandler h = NormalB $ yr `AppE` VarE master `AppE` VarE mkey `AppE` (just `AppE` url) `AppE` h `AppE` VarE req
+        runHandler h = NormalB $ yr `AppE` VarE sub
+                                    `AppE` VarE master
+                                    `AppE` VarE toMasterRoute
+                                    `AppE` VarE mkey
+                                    `AppE` (just `AppE` url)
+                                    `AppE` h
+                                    `AppE` VarE req
    let match m = Match (LitP $ StringL m) (runHandlerVars $ map toLower m ++ constr) []
    let clauses =
            case methods of
@ -295,7 +293,7 @@ mkSimpleExp segments (SinglePiece s:pieces) frontVars x = do
                ]
    return exp

-mkSubsiteExp segments [] frontVars (master, mkey, constr, toSub) = do
+mkSubsiteExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, toSub) = do
    ds <- [|dispatchSubsite|]
    let con = foldl' AppE (ConE $ mkName constr) $ frontVars []
    let s' = VarE (mkName toSub) `AppE` VarE master
@ -493,7 +491,7 @@ mkToMasterArg ps fname = do
 -- handler. This is the same as 'toWaiAppPlain', except it includes three
 -- middlewares: GZIP compression, JSON-P and path cleaning. This is the
 -- recommended approach for most users.
-toWaiApp :: (Yesod y, YesodDispatch y) => y -> IO W.Application
+toWaiApp :: (Yesod y, YesodDispatch y y) => y -> IO W.Application
 toWaiApp y = do
    a <- toWaiAppPlain y
    return $ gzip False
@ -502,12 +500,12 @@ toWaiApp y = do

 -- | Convert the given argument into a WAI application, executable with any WAI
 -- handler. This differs from 'toWaiApp' in that it uses no middlewares.
-toWaiAppPlain :: (Yesod y, YesodDispatch y) => y -> IO W.Application
+toWaiAppPlain :: (Yesod y, YesodDispatch y y) => y -> IO W.Application
 toWaiAppPlain a = do
    key' <- encryptKey a
    return $ toWaiApp' a key'

-toWaiApp' :: (Yesod y, YesodDispatch y)
+toWaiApp' :: (Yesod y, YesodDispatch y y)
          => y
          -> Maybe Key
          -> W.Application
@ -517,14 +515,14 @@ toWaiApp' y key' env = do
                "":x -> x
                x -> x
    liftIO $ print (W.pathInfo env, segments)
-    case yesodDispatch y key' segments of
+    case yesodDispatch y key' segments y id of
        Just app -> app env
        Nothing ->
            case cleanPath y segments of
                Nothing ->
-                    case yesodDispatch y key' segments of
+                    case yesodDispatch y key' segments y id of
                        Just app -> app env
-                        Nothing -> yesodRunner y key' Nothing notFound env
+                        Nothing -> yesodRunner y y id key' Nothing notFound env
                Just segments' ->
                    let dest = joinPath y (approot y) segments' []
                        dest' =
@ -540,19 +538,21 @@ toWaiApp' y key' env = do
                            , ("Location", dest')
                            ] "Redirecting"

+{-
 defaultDispatchSubsite
    :: (Yesod m, YesodDispatch m, YesodSubSite s m)
    => m -> Maybe Key -> [String]
    -> (Route s -> Route m)
    -> s
    -> W.Application
-defaultDispatchSubsite y key' segments toMasterRoute s env =
+defaultDispatchSubsite y key' segments toMasterRoute s env = error "FIXME" {-
    case dispatchToSubSubsite y key' segments toMasterRoute s of
        Just app -> app env
        Nothing ->
            case dispatchSubLocal y key' segments toMasterRoute s of
                Just app -> app env
-                Nothing -> yesodRunner y key' Nothing notFound env
+                Nothing -> yesodRunner y key' Nothing notFound env-}
+-}

 #if TEST

--- a/Yesod/Handler.hs
+++ b/Yesod/Handler.hs
@ -345,16 +345,16 @@ runHandler :: HasReps c
           -> Maybe (Route sub)
           -> (Route sub -> Route master)
           -> master
-           -> (master -> sub)
+           -> sub
           -> YesodApp
-runHandler handler mrender sroute tomr ma tosa =
+runHandler handler mrender sroute tomr ma sa =
  YesodApp $ \eh rr cts initSession -> do
    let toErrorHandler =
            InternalError
          . (show :: Control.Exception.SomeException -> String)
    let hd = HandlerData
            { handlerRequest = rr
-            , handlerSub = tosa ma
+            , handlerSub = sa
            , handlerMaster = ma
            , handlerRoute = sroute
            , handlerRender = mrender
@ -655,18 +655,20 @@ handlerTestSuite = testGroup "Yesod.Handler"

 handlerToYAR :: (HasReps a, HasReps b)
             => m -- ^ master site foundation
+             -> s -- ^ sub site foundation
+             -> (Route s -> Route m)
             -> (Route m -> [(String, String)] -> String) -- ^ url render
-             -> (ErrorResponse -> GHandler m m a)
+             -> (ErrorResponse -> GHandler s m a)
             -> Request
-             -> Maybe (Route m)
+             -> Maybe (Route s)
             -> SessionMap
-             -> GHandler m m b
+             -> GHandler s m b
             -> Iteratee ByteString IO YesodAppResult
-handlerToYAR y render errorHandler rr murl sessionMap h =
+handlerToYAR y s toMasterRoute render errorHandler rr murl sessionMap h =
    unYesodApp ya eh' rr types sessionMap
  where
-    ya = runHandler h render murl id y id
-    eh' er = runHandler (errorHandler' er) render murl id y id
+    ya = runHandler h render murl toMasterRoute y s
+    eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s
    types = httpAccept $ reqWaiRequest rr
    errorHandler' = localNoCurrent . errorHandler

--- a/helloworld.hs
+++ b/helloworld.hs
@ -26,6 +26,6 @@ mkYesod "HelloWorld" [$parseRoutes|
 /subsite/#String SubsiteR Subsite getSubsite
 |]
 instance Yesod HelloWorld where approot _ = ""
-getRootR :: GHandler HelloWorld HelloWorld RepPlain -- FIXME remove type sig
+-- getRootR :: GHandler HelloWorld HelloWorld RepPlain -- FIXME remove type sig
 getRootR = return $ RepPlain "Hello World"
 main = toWaiApp (HelloWorld Subsite) >>= runEx print 3000