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

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

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

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
+  let shouldEncrypt' = getsYesod $ view _appEncryptErrors
-  --   authed <- is _Just <$> maybeAuthId
+      canDecrypt' = is _Authorized <$> evalAccess AdminErrMsgR True
-  --   unless authed $ do
+  decrypted' <- runMaybeT $ do
-  --     mCurrent <- getCurrentRoute
+    internalErrorContent <- hoistMaybe $ err ^? _InternalError
-  --     gets' <- reqGetParams <$> getRequest
+    exceptTMaybe $ encodedSecretBoxOpen @Text internalErrorContent
-  --     wai <- waiRequest
+  let isEncrypted = is _Just decrypted'
-  --     maybe clearUltDest setUltDest $ do
+  shouldEncrypt <- andM
-  --       current <- mCurrent
+    [ shouldEncrypt'
-  --       case current of
+    , return $ not isEncrypted
-  --         _ | W.requestMethod wai `notElem` ["GET"] -> Nothing
+    , not <$> canDecrypt'
-  --         ErrorR -> Nothing
+    ]
-  --         current' -> Just (current', gets')
+  let decrypted = guardOnM (not shouldEncrypt) decrypted'
-  --     $logInfoS "errorHandler" "Redirect to LoginR"
-  --     redirect $ AuthR LoginR
-  
-  shouldEncrypt <- do
-    canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True
-    shouldEncrypt <- getsYesod $ view _appEncryptErrors
-    return $ shouldEncrypt && not canDecrypt
 
-  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
+          let displayEncrypted ciphertext = 
-            | shouldEncrypt -> do
-                ciphertext <- encodedSecretBox SecretBoxPretty plaintextJson
-
                 [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

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

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

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

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

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

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

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'