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

Better error handling and auth checking

Browse Source
This commit is contained in:
Michael Snoyman 2013-03-10 14:03:10 +02:00
parent dc79ddecd9
commit ee01aaf268
6 changed files with 51 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
yesod-core/Yesod/Core/Class.hs
View File

@ -291,13 +291,32 @@ $doctype 5
-- | A Yesod middleware, which will wrap every handler function. This
-- allows you to run code before and after a normal handler.
--
-- Default: Adds the response header \"Vary: Accept, Accept-Language\".
-- Default: Adds the response header \"Vary: Accept, Accept-Language\" and
-- performs authorization checks.
--
-- Since: 1.1.6
yesodMiddleware :: GHandler sub a res -> GHandler sub a res
yesodMiddleware handler = do
setHeader "Vary" "Accept, Accept-Language"
handler
route <- getCurrentRoute
toMaster <- getRouteToMaster
case fmap toMaster route of
Nothing -> handler
Just url -> do
isWrite <- isWriteRequest url
ar <- isAuthorized url isWrite
case ar of
Authorized -> return ()
AuthenticationRequired -> do
master <- getYesod
case authRoute master of
Nothing ->
permissionDenied "Authentication required"
Just url' -> do
setUltDestCurrent
redirect url'
Unauthorized s' -> permissionDenied s'
handler
-- | Convert a widget to a 'PageContent'.
widgetToPageContent :: (Eq (Route master), Yesod master)

45
yesod-core/Yesod/Core/Run.hs
View File

@ -39,7 +39,6 @@ import Web.Cookie (renderSetCookie)
import Yesod.Content
import Yesod.Core.Class
import Yesod.Core.Types
import Yesod.Handler
import Yesod.Internal (tokenKey)
import Yesod.Internal.Request (parseWaiRequest,
tooLargeResponse)
@ -118,9 +117,8 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = do
let headers = ghsHeaders state
let contents = either id (HCContent H.status200 . chooseRep) contents'
let handleError e = do
yar <- eh e yreq
{ reqOnError = safeEh
, reqSession = finalSession
yar <- rheOnError e yreq
{ reqSession = finalSession
}
case yar of
YRPlain _ hs ct c sess ->
@ -160,7 +158,6 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = do
finalSession
HCWai r -> return $ YRWai r
where
eh = reqOnError yreq
cts = reqAccept yreq
initSession = reqSession yreq
@ -229,6 +226,7 @@ runFakeHandler fakeSessionMap logger master handler = liftIO $ do
, rheSub = master
, rheUpload = fileUpload master
, rheLog = messageLoggerSource master $ logger master
, rheOnError = errHandler
}
handler'
errHandler err req = do
@ -263,7 +261,6 @@ runFakeHandler fakeSessionMap logger master handler = liftIO $ do
, reqWaiRequest = fakeWaiRequest
, reqLangs = []
, reqToken = Just "NaN" -- not a nonce =)
, reqOnError = errHandler
, reqAccept = []
, reqSession = fakeSessionMap
}
@ -279,30 +276,16 @@ defaultYesodRunner YesodRunnerEnv {..} handler' req
| KnownLength len <- requestBodyLength req, maxLen < len = return tooLargeResponse
| otherwise = do
let dontSaveSession _ = return []
let onError _ = error "FIXME: Yesod.Internal.Core.defaultYesodRunner.onError"
(session, saveSession) <- liftIO $ do
maybe (return (Map.empty, dontSaveSession)) (\sb -> sbLoadSession sb yreMaster req) yreSessionBackend
rr <- liftIO $ parseWaiRequest req session onError (isJust yreSessionBackend) maxLen <$> newStdGen
let h = {-# SCC "h" #-} do
case yreRoute of
Nothing -> handler
Just url -> do
isWrite <- isWriteRequest $ yreToMaster url
ar <- isAuthorized (yreToMaster url) isWrite
case ar of
Authorized -> return ()
AuthenticationRequired ->
case authRoute yreMaster of
Nothing ->
permissionDenied "Authentication required"
Just url' -> do
setUltDestCurrent
redirect url'
Unauthorized s' -> permissionDenied s'
handler
yreq <- liftIO $ parseWaiRequest req session (isJust yreSessionBackend) maxLen <$> newStdGen
let ra = resolveApproot yreMaster req
let log' = messageLoggerSource yreMaster yreLogger
rhe = RunHandlerEnv
-- We set up two environments: the first one has a "safe" error handler
-- which will never throw an exception. The second one uses the
-- user-provided errorHandler function. If that errorHandler function
-- errors out, it will use the safeEh below to recover.
rheSafe = RunHandlerEnv
{ rheRender = yesodRender yreMaster ra
, rheRoute = yreRoute
, rheToMaster = yreToMaster
@ -310,16 +293,18 @@ defaultYesodRunner YesodRunnerEnv {..} handler' req
, rheSub = yreSub
, rheUpload = fileUpload yreMaster
, rheLog = log'
, rheOnError = safeEh
}
yar <- runHandler rhe h rr
{ reqOnError = runHandler rhe . localNoCurrent . errorHandler
}
rhe = rheSafe
{ rheOnError = runHandler rheSafe . localNoCurrent . errorHandler
}
yar <- runHandler rhe handler yreq
extraHeaders <- case yar of
(YRPlain _ _ ct _ newSess) -> do
let nsToken = maybe
newSess
(\n -> Map.insert tokenKey (encodeUtf8 n) newSess)
(reqToken rr)
(reqToken yreq)
sessionHeaders <- liftIO (saveSession nsToken)
return $ ("Content-Type", ct) : map headerToPair sessionHeaders
_ -> return []

8
yesod-core/Yesod/Core/Types.hs
View File

@ -105,10 +105,6 @@ data YesodRequest = YesodRequest
-- ^ An ordered list of the accepted content types.
--
-- Since 1.2.0
, reqOnError :: !(ErrorResponse -> YesodApp)
-- ^ How to respond when an error is thrown internally.
--
-- Since 1.2.0
}
-- | An augmented WAI 'W.Response'. This can either be a standard @Response@,
@ -177,6 +173,10 @@ data RunHandlerEnv sub master = RunHandlerEnv
, rheSub :: !sub
, rheUpload :: !(RequestBodyLength -> FileUpload)
, rheLog :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ())
, rheOnError :: !(ErrorResponse -> YesodApp)
-- ^ How to respond when an error is thrown internally.
--
-- Since 1.2.0
}
data HandlerData sub master = HandlerData

4
yesod-core/Yesod/Internal/Request.hs
View File

@ -70,12 +70,11 @@ tooLargeResponse = W.responseLBS
parseWaiRequest :: RandomGen g
=> W.Request
-> SessionMap
-> (ErrorResponse -> YesodApp)
-> Bool
-> Word64 -- ^ max body size
-> g
-> YesodRequest
parseWaiRequest env session onError useToken maxBodySize gen =
parseWaiRequest env session useToken maxBodySize gen =
YesodRequest
{ reqGetParams = gets
, reqCookies = cookies
@ -86,7 +85,6 @@ parseWaiRequest env session onError useToken maxBodySize gen =
then Map.delete tokenKey session
else session
, reqAccept = httpAccept env
, reqOnError = onError
}
where
gets = map (second $ fromMaybe "")

22
yesod-core/test/YesodCoreTest/InternalRequest.hs
View File

@ -11,7 +11,6 @@ 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
@ -41,19 +40,19 @@ tokenSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqToken)" $ do
noDisabledToken :: Bool
noDisabledToken = reqToken r == Nothing where
r = parseWaiRequest defaultRequest mempty onError False 1000 g
r = parseWaiRequest defaultRequest mempty False 1000 g
ignoreDisabledToken :: Bool
ignoreDisabledToken = reqToken r == Nothing where
r = parseWaiRequest defaultRequest (singleton "_TOKEN" "old") onError False 1000 g
r = parseWaiRequest defaultRequest (singleton "_TOKEN" "old") False 1000 g
useOldToken :: Bool
useOldToken = reqToken r == Just "old" where
r = parseWaiRequest defaultRequest (singleton "_TOKEN" "old") onError True 1000 g
r = parseWaiRequest defaultRequest (singleton "_TOKEN" "old") True 1000 g
generateToken :: Bool
generateToken = reqToken r /= Nothing where
r = parseWaiRequest defaultRequest (singleton "_TOKEN" "old") onError True 1000 g
r = parseWaiRequest defaultRequest (singleton "_TOKEN" "old") True 1000 g
langSpecs :: Spec
@ -67,21 +66,21 @@ langSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqLangs)" $ do
respectAcceptLangs :: Bool
respectAcceptLangs = reqLangs r == ["en-US", "es", "en"] where
r = parseWaiRequest defaultRequest
{ requestHeaders = [("Accept-Language", "en-US, es")] } mempty onError False 1000 g
{ requestHeaders = [("Accept-Language", "en-US, es")] } mempty False 1000 g
respectSessionLang :: Bool
respectSessionLang = reqLangs r == ["en"] where
r = parseWaiRequest defaultRequest (singleton "_LANG" "en") onError False 1000 g
r = parseWaiRequest defaultRequest (singleton "_LANG" "en") False 1000 g
respectCookieLang :: Bool
respectCookieLang = reqLangs r == ["en"] where
r = parseWaiRequest defaultRequest
{ requestHeaders = [("Cookie", "_LANG=en")]
} mempty onError False 1000 g
} mempty False 1000 g
respectQueryLang :: Bool
respectQueryLang = reqLangs r == ["en-US", "en"] where
r = parseWaiRequest defaultRequest { queryString = [("_LANG", Just "en-US")] } mempty onError False 1000 g
r = parseWaiRequest defaultRequest { queryString = [("_LANG", Just "en-US")] } mempty False 1000 g
prioritizeLangs :: Bool
prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "es"] where
@ -90,10 +89,7 @@ prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "e
, ("Cookie", "_LANG=en-COOKIE")
]
, queryString = [("_LANG", Just "en-QUERY")]
} (singleton "_LANG" "en-SESSION") onError False 10000 g
onError :: ErrorResponse -> YesodApp
onError _ = error "Yesod.InternalRequest.onError"
} (singleton "_LANG" "en-SESSION") False 10000 g
internalRequestTest :: Spec
internalRequestTest = describe "Test.InternalRequestTest" $ do

2
yesod-core/yesod-core.cabal
View File

@ -97,7 +97,6 @@ library
Yesod.Request
Yesod.Widget
Yesod.Internal.TestApi
Yesod.Core.Types
other-modules: Yesod.Internal
Yesod.Internal.Cache
Yesod.Internal.Core
@ -107,6 +106,7 @@ library
Yesod.Core.Trans.Class
Yesod.Core.Run
Yesod.Core.Class
Yesod.Core.Types
Paths_yesod_core
ghc-options: -Wall