fix(errors): better handling of errors from separated approots

2020-12-03 15:51:23 +01:00 · 2020-12-03 15:51:23 +01:00 · 833b674c31
commit 833b674c31
parent fbf21d7313
10 changed files with 161 additions and 43 deletions
--- a/messages/uniworx/de-de-formal.msg
+++ b/messages/uniworx/de-de-formal.msg
@ -548,6 +548,8 @@ UnauthorizedWorkflowRead: Der Workflow enthält aktuell keine Zustände oder Dat
 UnauthorizedWorkflowInstancesNotEmpty: Es gibt Workflow Instanzen für die Sie einen neuen laufenden Workflow initiieren dürfen
 UnauthorizedWorkflowWorkflowsNotEmpty: Es gibt laufende Workflows, die Sie einsehen dürfen
 UnauthorizedWorkflowFiles: Sie dürfen die angegebenen Workflow-Dateien nicht im angegebenen historischen Zustand herunterladen
+UnauthorizedNotAuthenticatedInDifferentApproot: Sie konnten im Kontext einer separierten Domain (z.B. zum sicheren Download von Dateien) nicht authentifiziert werden. Vermutlich haben Sie kein oder ein abgelaufenes Token verwendet. Sie können versuchen auf die gewünschte Resource mit einem neu generierten Download-Link zuzugreifen.
+UnauthorizedCsrfDisabled: Ihre Anfrage hätte wmgl. Änderungen am Server-Zustand ausgelöst. Da die sog. CSRF-Protection für Ihre Anfrage deaktiviert ist, musste sie daher abgelehnt werden.

 WorkflowRoleUserMismatch: Sie sind nicht einer der vom Workflow geforderten Benutzer
 WorkflowRoleAlreadyInitiated: Dieser Workflow wurde bereits initiiert
--- a/messages/uniworx/en-eu.msg
+++ b/messages/uniworx/en-eu.msg
@ -545,6 +545,8 @@ UnauthorizedWorkflowRead: The workflow currently contains no states or data you
 UnauthorizedWorkflowInstancesNotEmpty: There are workflow instances for which you are allowed to initiate a new running workflow
 UnauthorizedWorkflowWorkflowsNotEmpty: There are running workflows, which you may view
 UnauthorizedWorkflowFiles: You are not allowed to download the given workflow files in the given historical state
+UnauthorizedNotAuthenticatedInDifferentApproot: You could not be authenticated in the context of a separate domain (e.g. for secure downloading of files). You probably used no or an expired token. You can try to access the resource with a newly generated download link.
+UnauthorizedCsrfDisabled: Your request might have triggered a state change on the server. Since CSRF-protection was disabled for your request, it had to be rejected.

 WorkflowRoleUserMismatch: You aren't any of the users authorized by the workflow
 WorkflowRoleAlreadyInitiated: This workflow was already initiated
--- a/src/Foundation/Yesod/ErrorHandler.hs
+++ b/src/Foundation/Yesod/ErrorHandler.hs
@ -20,6 +20,7 @@ import qualified Network.Wai as W

 errorHandler :: ( MonadSecretBox (HandlerFor UniWorX)
                , MonadSecretBox (WidgetFor UniWorX)
+                , MonadSecretBox (ExceptT EncodedSecretBoxException (HandlerFor UniWorX))
                , MonadAuth (HandlerFor UniWorX)
                , BearerAuthSite UniWorX
                , Button UniWorX ButtonSubmit
@ -28,27 +29,20 @@ errorHandler :: ( MonadSecretBox (HandlerFor UniWorX)
                )
             => ErrorResponse -> HandlerFor UniWorX TypedContent
 errorHandler err = do
-  -- when (is _NotAuthenticated err) $ do
-  --   authed <- is _Just <$> maybeAuthId
-  --   unless authed $ do
-  --     mCurrent <- getCurrentRoute
-  --     gets' <- reqGetParams <$> getRequest
-  --     wai <- waiRequest
-  --     maybe clearUltDest setUltDest $ do
-  --       current <- mCurrent
-  --       case current of
-  --         _ | W.requestMethod wai `notElem` ["GET"] -> Nothing
-  --         ErrorR -> Nothing
-  --         current' -> Just (current', gets')
-  --     $logInfoS "errorHandler" "Redirect to LoginR"
-  --     redirect $ AuthR LoginR
-  
-  shouldEncrypt <- do
-    canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True
-    shouldEncrypt <- getsYesod $ view _appEncryptErrors
-    return $ shouldEncrypt && not canDecrypt
+  let shouldEncrypt' = getsYesod $ view _appEncryptErrors
+      canDecrypt' = is _Authorized <$> evalAccess AdminErrMsgR True
+  decrypted' <- runMaybeT $ do
+    internalErrorContent <- hoistMaybe $ err ^? _InternalError
+    exceptTMaybe $ encodedSecretBoxOpen @Text internalErrorContent
+  let isEncrypted = is _Just decrypted'
+  shouldEncrypt <- andM
+    [ shouldEncrypt'
+    , return $ not isEncrypted
+    , not <$> canDecrypt'
+    ]
+  let decrypted = guardOnM (not shouldEncrypt) decrypted'

-  sessErr <- bool return (_InternalError $ encodedSecretBox SecretBoxShort) shouldEncrypt err
+  sessErr <- bool return (traverseOf _InternalError $ encodedSecretBox SecretBoxShort) shouldEncrypt err

  void . runMaybeT $ do
    reqHost <- MaybeT $ W.requestHeaderHost <$> waiRequest
@ -57,28 +51,44 @@ errorHandler err = do
      authErr <- lift $ encodedAuth sessErr
      redirect (ErrorR, [(toPathPiece GetError, authErr)])
  
+  when (is _NotAuthenticated err) $ do
+    authed <- is _Just <$> maybeAuthId
+    unless authed $ do
+      mCurrent <- getCurrentRoute
+      gets' <- reqGetParams <$> getRequest
+      wai <- waiRequest
+      maybe clearUltDest setUltDest $ do
+        current <- mCurrent
+        case current of
+          _ | W.requestMethod wai `notElem` ["GET"] -> Nothing
+          ErrorR -> Nothing
+          current' -> Just (current', gets')
+      $logInfoS "errorHandler" "Redirect to LoginR"
+      redirect $ AuthR LoginR
+  
  setSessionJson SessionError sessErr

  selectRep $ do
    provideRep $ do
      mr <- getMessageRender
      let
-        encrypted :: ToJSON a => a -> WidgetFor UniWorX () -> WidgetFor UniWorX ()
+        encrypted :: Text -> WidgetFor UniWorX () -> WidgetFor UniWorX ()
        encrypted plaintextJson plaintext = do
-          if
-            | shouldEncrypt -> do
-                ciphertext <- encodedSecretBox SecretBoxPretty plaintextJson
-
+          let displayEncrypted ciphertext = 
                [whamlet|
+                  $newline never
                  <p>_{MsgErrorResponseEncrypted}
                  <pre .literal-error>
                    #{ciphertext}
                |]
+          if
+            | isEncrypted && shouldEncrypt -> displayEncrypted plaintextJson
+            | shouldEncrypt -> displayEncrypted =<< encodedSecretBox SecretBoxPretty plaintextJson
            | otherwise -> plaintext

        errPage = case err of
          NotFound -> [whamlet|<p>_{MsgErrorResponseNotFound}|]
-          InternalError err' -> encrypted err' [whamlet|<p .literal-error>#{err'}|]
+          InternalError err' -> encrypted err' [whamlet|<p .literal-error>#{fromMaybe err' decrypted}|]
          InvalidArgs errs -> [whamlet|
              <ul>
                $forall err' <- errs
@ -93,20 +103,27 @@ errorHandler err = do
    provideRep . fmap PrettyValue $ case err of
      PermissionDenied err' -> return $ object [ "message" JSON..= err' ]
      InternalError err'
+        | isEncrypted && shouldEncrypt
+          -> return $ object [ "message" JSON..= err'
+                             , "encrypted" JSON..= True
+                             ]
        | shouldEncrypt -> do
            ciphertext <- encodedSecretBox SecretBoxShort err'
            return $ object [ "message" JSON..= ciphertext
                            , "encrypted" JSON..= True
                            ]
-        | otherwise -> return $ object [ "message" JSON..= err' ]
+        | otherwise -> return $ object [ "message" JSON..= fromMaybe err' decrypted ]
      InvalidArgs errs -> return $ object [ "messages" JSON..= errs ]
      _other -> return $ object []
    provideRep $ case err of
      PermissionDenied err' -> return err'
      InternalError err'
+        | isEncrypted && shouldEncrypt -> do
+            addHeader "Encrypted-Error-Message" "True"
+            return err'
        | shouldEncrypt -> do
            addHeader "Encrypted-Error-Message" "True"
            encodedSecretBox SecretBoxPretty err'
-        | otherwise -> return err'
+        | otherwise -> return $ fromMaybe err' decrypted
      InvalidArgs errs -> return . Text.unlines . map (Text.replace "\n" "\n\t") $ errs
      _other -> return Text.empty
--- a/src/Foundation/Yesod/Middleware.hs
+++ b/src/Foundation/Yesod/Middleware.hs
@ -10,6 +10,7 @@ import Import.NoFoundation hiding (yesodMiddleware)
 import Foundation.Type
 import Foundation.Routes
 import Foundation.Authorization
+import Foundation.I18n

 import Utils.Metrics
 import Utils.Workflow
@ -30,7 +31,7 @@ yesodMiddleware :: ( BearerAuthSite UniWorX
                   , BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
                   )
                => HandlerFor UniWorX res -> HandlerFor UniWorX res
-yesodMiddleware = storeBearerMiddleware . csrfMiddleware . dryRunMiddleware . observeYesodCacheSizeMiddleware . languagesMiddleware appLanguages . headerMessagesMiddleware . defaultYesodMiddleware . normalizeRouteMiddleware . updateFavouritesMiddleware . setActiveAuthTagsMiddleware
+yesodMiddleware = cacheControlMiddleware . storeBearerMiddleware . csrfMiddleware . dryRunMiddleware . observeYesodCacheSizeMiddleware . languagesMiddleware appLanguages . headerMessagesMiddleware . securityMiddleware . normalizeRouteMiddleware . updateFavouritesMiddleware . setActiveAuthTagsMiddleware
  where
    dryRunMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
    dryRunMiddleware handler = do
@ -90,9 +91,19 @@ yesodMiddleware = storeBearerMiddleware . csrfMiddleware . dryRunMiddleware . ob
      reqHost <- W.requestHeaderHost <$> waiRequest
      userGeneratedHost <- getsYesod $ \app ->
        guardOnM (views _appRoot ($ ApprootDefault) app /= views _appRoot ($ ApprootUserGenerated) app) $ approotScopeHost ApprootUserGenerated app
+      mCurrentRoute <- getCurrentRoute
+      let isError = case mCurrentRoute of
+            Just ErrorR -> True
+            _other -> False

-      if | hasBearer || fromMaybe False ((==) <$> reqHost <*> userGeneratedHost)
+      if | hasBearer 
           -> local (\HandlerData{..} -> HandlerData{ handlerRequest = handlerRequest { reqToken = Nothing }, .. }) handler
+         | fromMaybe False ((==) <$> reqHost <*> userGeneratedHost) || isError -> do
+             whenIsJust mCurrentRoute $ \currentRoute -> do
+               isWrite <- isWriteRequest currentRoute
+               when isWrite $
+                 permissionDeniedI MsgUnauthorizedCsrfDisabled
+             handler
         | otherwise
           -> csrfSetCookieMiddleware' . defaultCsrfCheckMiddleware $ handler
      where
@ -115,6 +126,15 @@ yesodMiddleware = storeBearerMiddleware . csrfMiddleware . dryRunMiddleware . ob
        for_ mAuthTagActive $ setSessionJson SessionActiveAuthTags . review _ReducedActiveAuthTags

      handler
+    securityMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
+    securityMiddleware handler = do
+      addHeader "X-XSS-Protection" "1; mode=block"
+      addHeader "X-Frame-Options" "sameorigin"
+      addHeader "X-Content-Type-Options" "nosniff"
+      authorizationCheck
+      handler
+    cacheControlMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
+    cacheControlMiddleware = (addHeader "Vary" "Accept, Accept-Language" *>)

 updateFavourites :: forall m backend.
                    ( MonadHandler m, HandlerSite m ~ UniWorX
--- a/src/Foundation/Yesod/Session.hs
+++ b/src/Foundation/Yesod/Session.hs
@ -4,6 +4,7 @@ module Foundation.Yesod.Session

 import Import.NoFoundation hiding (makeSessionBackend)

+import Foundation.Routes
 import Foundation.Type

 import qualified Web.ServerSession.Core as ServerSession
@ -12,12 +13,15 @@ import qualified Web.ServerSession.Frontend.Yesod.Jwt as JwtSession
 import qualified Network.Wai as W
 import qualified Network.HTTP.Types.Header as W
 import qualified Network.Wai.Middleware.HttpAuth as W (extractBearerAuth)
+import qualified Network.HTTP.Types as HTTP
+
+import qualified Data.Map as Map

 import Web.Cookie


 makeSessionBackend :: Yesod UniWorX => UniWorX -> IO (Maybe SessionBackend)
-makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = notFor isUserGenerated . notFor isBearer . sameSite $ case appSessionStore of
+makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = noCreateFor (return . forRoute isError) . notFor isUserGenerated . notFor isBearer . sameSite $ case appSessionStore of
  SessionStorageMemcachedSql sqlStore
    -> mkBackend . stateSettings =<< ServerSession.createState sqlStore
  SessionStorageAcid acidStore
@ -58,6 +62,24 @@ makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = notFor isU
              if | not pMatches -> load req
                 | otherwise    -> return (mempty, const $ return [])

+    noCreateFor :: (W.Request -> IO Bool) -> IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
+    noCreateFor f = fmap $ fmap notFor'
+      where notFor' :: SessionBackend -> SessionBackend
+            notFor' (SessionBackend load) = SessionBackend $ \req -> do
+              pMatches <- f req
+              if | not pMatches -> load req
+                 | otherwise    -> noCreate <$> load req
+            noCreate resp@(session, _)
+              | Map.null session = (session, const $ return [])
+              | otherwise = resp
+
+    forRoute :: (Route UniWorX -> Bool) -> (W.Request -> Bool)
+    forRoute f req = maybe False f mRoute
+      where mRoute = parseRoute
+              ( W.pathInfo req
+              , over (mapped . _2) (fromMaybe "") . HTTP.queryToQueryText $ W.queryString req
+              )
+

    isBearer req = return $ if
      | aHdrs <- mapMaybe (\(h, v) -> v <$ guard (h == W.hAuthorization)) $ W.requestHeaders req
@ -74,3 +96,7 @@ makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = notFor isU
        -> True
      | otherwise
        -> False
+
+    isError = \case
+      ErrorR -> True
+      _other -> False
--- a/src/Handler/Error.hs
+++ b/src/Handler/Error.hs
@ -9,4 +9,9 @@ import Yesod.Core.Types (HandlerContents(HCError))
 getErrorR :: Handler Void
 getErrorR = do
  encodedErrResponse <- maybe (redirect NewsR) return =<< lookupGlobalGetParam GetError
-  throwM . HCError =<< throwExceptT (encodedAuthVerify encodedErrResponse)
+  errResponse <- throwExceptT (encodedAuthVerify encodedErrResponse)
+
+  isAuthed <- is _Just <$> maybeAuthId
+  case errResponse of
+    NotAuthenticated | isAuthed -> permissionDeniedI MsgUnauthorizedNotAuthenticatedInDifferentApproot
+    _ -> throwM $ HCError errResponse
--- a/src/Handler/Material.hs
+++ b/src/Handler/Material.hs
@ -157,7 +157,7 @@ getMaterialListR tid ssh csh = do


 getMFileR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> FilePath -> Handler TypedContent
-getMFileR tid ssh csh mnm title = serveOneFile $ fileQuery .| C.map entityVal
+getMFileR tid ssh csh mnm title = error "MFileR" . serveOneFile $ fileQuery .| C.map entityVal
  where
    fileQuery = E.selectSource $ E.from $
      \(course `E.InnerJoin` material `E.InnerJoin` matFile) -> do
--- a/src/Import/NoModel.hs
+++ b/src/Import/NoModel.hs
@ -2,7 +2,6 @@ module Import.NoModel
  ( module Import
  , MForm
  , WeekDay
-  , requireAuthId
  ) where

 import ClassyPrelude.Yesod    as Import
@ -21,6 +20,8 @@ import ClassyPrelude.Yesod    as Import
         , htmlField, fileField, urlField
         , mreq, areq, wreq -- Use `mreqMsg`, `areqMsg`, `wreqMsg`
         , sinkFile, sourceFile
+         , defaultYesodMiddleware
+         , authorizationCheck
         )

 import UnliftIO.Async.Utils as Import
@ -30,7 +31,7 @@ import Model.Types.TH.Wordlist as Import

 import Mail                   as Import

-import Yesod.Auth             as Import hiding (requireAuthId)
+import Yesod.Auth             as Import hiding (requireAuth, requireAuthId, requireAuthPair)
 import Yesod.Core.Types       as Import (loggerSet)
 import Yesod.Default.Config2  as Import
 import Yesod.Core.Types.Instances as Import
@ -40,6 +41,7 @@ import Utils.Frontend.I18n    as Import
 import Utils.DB               as Import
 import Utils.Sql              as Import
 import Utils.Widgets          as Import
+import Utils.Auth             as Import

 import Data.Fixed             as Import

@ -213,14 +215,7 @@ import Data.Scientific as Import (Scientific, formatScientific)

 import Control.Monad.Trans.RWS (RWST)

-import qualified Yesod.Auth as Yesod
-import GHC.Stack

 type MForm m = RWST (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m

 type WeekDay = DayOfWeek
-
-requireAuthId :: (MonadHandler m, YesodAuth (HandlerSite m), HasCallStack) => m (AuthId (HandlerSite m))
-requireAuthId = do
-  $logDebugS "requireAuthId" . pack $ prettyCallStack callStack
-  Yesod.requireAuthId
--- a/src/Utils.hs
+++ b/src/Utils.hs
@ -1136,7 +1136,8 @@ encodedSecretBox pretty val = do
  sKey <- secretBoxKey
  encodedSecretBox' sKey pretty val

-encodedSecretBoxOpen :: ( FromJSON a, MonadError EncodedSecretBoxException m, MonadSecretBox m )
+encodedSecretBoxOpen :: forall a m.
+                        ( FromJSON a, MonadError EncodedSecretBoxException m, MonadSecretBox m )
                     => Text -> m a
 encodedSecretBoxOpen ciphertext = do
  sKey <- secretBoxKey
--- a/src/Utils/Auth.hs
+++ b/src/Utils/Auth.hs
@ -0,0 +1,50 @@
+module Utils.Auth
+  ( requireAuth, requireAuthId, requireAuthPair, authorizationCheck
+  ) where
+
+import ClassyPrelude.Yesod hiding (authorizationCheck)
+import Yesod.Auth hiding (requireAuth, requireAuthId, requireAuthPair)
+import GHC.Stack
+
+
+requireAuthId :: (MonadHandler m, YesodAuth (HandlerSite m), HasCallStack) => m (AuthId (HandlerSite m))
+requireAuthId = do
+  $logDebugS "requireAuthId" . pack $ prettyCallStack callStack
+  maybeAuthId >>= maybe notAuthenticated return
+
+requireAuth :: ( YesodAuthPersist master
+               , val ~ AuthEntity master
+               , Key val ~ AuthId master
+               , PersistEntity val
+               , Typeable val
+               , MonadHandler m
+               , HandlerSite m ~ master
+               , HasCallStack
+               ) => m (Entity val)
+requireAuth = do
+  $logDebugS "requireAuth" . pack $ prettyCallStack callStack
+  maybeAuth >>= maybe notAuthenticated return
+
+requireAuthPair :: ( YesodAuthPersist master
+                   , Typeable (AuthEntity master)
+                   , MonadHandler m
+                   , HandlerSite m ~ master
+                   , HasCallStack
+                   )
+                => m (AuthId master, AuthEntity master)
+requireAuthPair = do
+  $logDebugS "requireAuthPair" . pack $ prettyCallStack callStack
+  maybeAuthPair >>= maybe notAuthenticated return
+
+authorizationCheck :: (Yesod site, HasCallStack) => HandlerFor site ()
+authorizationCheck = do
+  $logDebugS "authorizationCheck" . pack $ prettyCallStack callStack
+  getCurrentRoute >>= maybe (return ()) checkUrl
+  where
+    checkUrl url = do
+      isWrite <- isWriteRequest url
+      ar <- isAuthorized url isWrite
+      case ar of
+        Authorized -> return ()
+        AuthenticationRequired -> notAuthenticated
+        Unauthorized s' -> permissionDenied s'