Removed handlerToYAR

yesod-core/Yesod/Core/Run.hs

@@ -14,7 +14,6 @@ import           Control.Monad.IO.Class       (MonadIO)
 import           Control.Monad.IO.Class       (liftIO)
 import           Control.Monad.Logger         (LogLevel, LogSource)
 import           Control.Monad.Trans.Resource (runResourceT)
-import           Control.Monad.Trans.Resource (ResourceT)
 import           Data.ByteString              (ByteString)
 import qualified Data.ByteString              as S
 import qualified Data.ByteString.Char8        as S8
@@ -49,26 +48,6 @@ import           Yesod.Internal.Request       (parseWaiRequest,
                                                tooLargeResponse)
 import           Yesod.Routes.Class           (Route, renderRoute)
 
-handlerToYAR :: (HasReps a, HasReps b)
-             => master -- ^ master site foundation
-             -> sub    -- ^ sub site foundation
-             -> (RequestBodyLength -> FileUpload)
-             -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-             -> (Route sub -> Route master)
-             -> (Route master -> [(Text, Text)] -> Text) -- route renderer
-             -> (ErrorResponse -> GHandler sub master a)
-             -> YesodRequest
-             -> Maybe (Route sub)
-             -> SessionMap
-             -> GHandler sub master b
-             -> ResourceT IO YesodResponse
-handlerToYAR y s upload log' toMasterRoute render errorHandler0 rr murl sessionMap h =
-    ya rr { reqOnError = eh', reqSession = sessionMap }
-  where
-    ya = runHandler h render murl toMasterRoute y s upload log'
-    eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s upload log'
-    errorHandler' = localNoCurrent . errorHandler0
-
 yarToResponse :: YesodResponse -> [(CI ByteString, ByteString)] -> Response
 yarToResponse (YRWai a) _ = a
 yarToResponse (YRPlain s hs _ c _) extraHeaders =
@@ -111,19 +90,23 @@ local :: (HandlerData sub' master' -> HandlerData sub master)
       -> GHandler sub' master' a
 local f (GHandler x) = GHandler $ \r -> x $ f r
 
+data RunHandlerEnv sub master = RunHandlerEnv -- FIXME merge with YesodRunnerEnv? Or HandlerData
+    { rheRender :: !(Route master -> [(Text, Text)] -> Text)
+    , rheRoute :: !(Maybe (Route sub))
+    , rheToMaster :: !(Route sub -> Route master)
+    , rheMaster :: !master
+    , rheSub :: !sub
+    , rheUpload :: !(RequestBodyLength -> FileUpload)
+    , rheLog :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ())
+    }
+
 -- | Function used internally by Yesod in the process of converting a
 -- 'GHandler' into an 'Application'. Should not be needed by users.
 runHandler :: HasReps c
-           => GHandler sub master c
+           => RunHandlerEnv sub master
-           -> (Route master -> [(Text, Text)] -> Text)
+           -> GHandler sub master c
-           -> Maybe (Route sub)
-           -> (Route sub -> Route master)
-           -> master
-           -> sub
-           -> (RequestBodyLength -> FileUpload)
-           -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
            -> YesodApp
-runHandler handler mrender sroute tomr master sub upload log' req = do
+runHandler RunHandlerEnv {..} handler yreq = do
     let toErrorHandler e =
             case fromException e of
                 Just (HCError x) -> x
@@ -136,15 +119,15 @@ runHandler handler mrender sroute tomr master sub upload log' req = do
         , ghsHeaders = mempty
         }
     let hd = HandlerData
-            { handlerRequest = req
+            { handlerRequest = yreq
-            , handlerSub = sub
+            , handlerSub = rheSub
-            , handlerMaster = master
+            , handlerMaster = rheMaster
-            , handlerRoute = sroute
+            , handlerRoute = rheRoute
-            , handlerRender = mrender
+            , handlerRender = rheRender
-            , handlerToMaster = tomr
+            , handlerToMaster = rheToMaster
             , handlerState = istate
-            , handlerUpload = upload
+            , handlerUpload = rheUpload
-            , handlerLog = log'
+            , handlerLog = rheLog
             }
     contents' <- catch (fmap Right $ unGHandler handler hd)
         (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id
@@ -154,7 +137,7 @@ runHandler handler mrender sroute tomr master sub upload log' req = do
     let headers = ghsHeaders state
     let contents = either id (HCContent H.status200 . chooseRep) contents'
     let handleError e = do
-            yar <- eh e req
+            yar <- eh e yreq
                 { reqOnError = safeEh
                 , reqSession = finalSession
                 }
@@ -196,9 +179,9 @@ runHandler handler mrender sroute tomr master sub upload log' req = do
                 finalSession
         HCWai r -> return $ YRWai r
   where
-    eh = reqOnError req
+    eh = reqOnError yreq
-    cts = reqAccept req
+    cts = reqAccept yreq
-    initSession = reqSession req
+    initSession = reqSession yreq
 
 safeEh :: ErrorResponse -> YesodApp
 safeEh er req = do
@@ -256,16 +239,17 @@ runFakeHandler fakeSessionMap logger master handler = liftIO $ do
   ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result")
   let handler' = do liftIO . I.writeIORef ret . Right =<< handler
                     return ()
-  let yapp =
+  let yapp = runHandler
-        runHandler
+         RunHandlerEnv
-          handler'
+            { rheRender = yesodRender master $ resolveApproot master fakeWaiRequest
-          (yesodRender master $ resolveApproot master fakeWaiRequest)
+            , rheRoute = Nothing
-          Nothing
+            , rheToMaster = id
-          id
+            , rheMaster = master
-          master
+            , rheSub = master
-          master
+            , rheUpload = fileUpload master
-          (fileUpload master)
+            , rheLog = messageLoggerSource master $ logger master
-          (messageLoggerSource master $ logger master)
+            }
+        handler'
       errHandler err req = do
           liftIO $ I.writeIORef ret (Left err)
           return $ YRPlain
@@ -344,11 +328,20 @@ defaultYesodRunner YesodRunnerEnv {..} handler' req
                                 redirect url'
                     Unauthorized s' -> permissionDenied s'
                 handler
-    let sessionMap = Map.filterWithKey (\k _v -> k /= tokenKey) $ session
     let ra = resolveApproot yreMaster req
     let log' = messageLoggerSource yreMaster yreLogger
-    yar <- handlerToYAR yreMaster yreSub (fileUpload yreMaster) log' yreToMaster
+        rhe = RunHandlerEnv
-        (yesodRender yreMaster ra) errorHandler rr yreRoute sessionMap h
+            { rheRender = yesodRender yreMaster ra
+            , rheRoute = yreRoute
+            , rheToMaster = yreToMaster
+            , rheMaster = yreMaster
+            , rheSub = yreSub
+            , rheUpload = fileUpload yreMaster
+            , rheLog = log'
+            }
+    yar <- runHandler rhe h rr
+        { reqOnError = runHandler rhe . localNoCurrent . errorHandler
+        }
     extraHeaders <- case yar of
         (YRPlain _ _ ct _ newSess) -> do
             let nsToken = maybe

yesod-core/Yesod/Internal/Request.hs

@@ -82,7 +82,9 @@ parseWaiRequest env session onError useToken maxBodySize gen =
         , reqWaiRequest = limitRequestBody maxBodySize env
         , reqLangs      = langs''
         , reqToken      = token
-        , reqSession    = session
+        , reqSession    = if useToken
+                            then Map.delete tokenKey session
+                            else session
         , reqAccept     = httpAccept env
         , reqOnError    = onError
         }

yesod-core/test/YesodCoreTest/InternalRequest.hs

@@ -11,6 +11,7 @@ import Yesod.Request (YesodRequest (..))
 import Test.Hspec
 import Data.Monoid (mempty)
 import Data.Map (singleton)
+import Yesod.Core.Types (YesodApp, ErrorResponse)
 
 randomStringSpecs :: Spec
 randomStringSpecs = describe "Yesod.Internal.Request.randomString" $ do
@@ -91,8 +92,8 @@ prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "e
         , queryString = [("_LANG", Just "en-QUERY")]
         } (singleton "_LANG" "en-SESSION") onError False 10000 g
 
-onError :: a
+onError :: ErrorResponse -> YesodApp
-onError = error "Yesod.InternalRequest.onError"
+onError _ = error "Yesod.InternalRequest.onError"
 
 internalRequestTest :: Spec
 internalRequestTest = describe "Test.InternalRequestTest" $ do

yesod-core/yesod-core.cabal

@@ -96,12 +96,12 @@ library
                      Yesod.Request
                      Yesod.Widget
                      Yesod.Internal.TestApi
+                     Yesod.Core.Types
     other-modules:   Yesod.Internal
                      Yesod.Internal.Cache
                      Yesod.Internal.Core
                      Yesod.Internal.Session
                      Yesod.Internal.Request
-                     Yesod.Core.Types
                      Yesod.Core.Time
                      Yesod.Core.Trans.Class
                      Yesod.Core.Run