Error handling improvements

aula.cabal

@@ -79,6 +79,7 @@ library
     , vector
     , wai
     , wai-app-static
+    , wai-extra
     , warp
     , yaml
   exposed-modules:
@@ -211,6 +212,7 @@ executable aula-avatars
     , vector
     , wai
     , wai-app-static
+    , wai-extra
     , warp
     , yaml
     , aula
@@ -279,6 +281,7 @@ executable aula-html-dummies
     , vector
     , wai
     , wai-app-static
+    , wai-extra
     , warp
     , yaml
     , aula
@@ -350,6 +353,7 @@ executable aula-server
     , vector
     , wai
     , wai-app-static
+    , wai-extra
     , warp
     , yaml
     , aula
@@ -419,6 +423,7 @@ test-suite spec
     , vector
     , wai
     , wai-app-static
+    , wai-extra
     , warp
     , yaml
     , aula

package.yaml

@@ -70,6 +70,7 @@ dependencies:
     - vector
     - wai
     - wai-app-static
+    - wai-extra
     - warp
     - yaml
 

src/Action.hs

@@ -363,6 +363,7 @@ modifyCurrentUser ev =
 isLoggedIn :: ActionUserHandler m => m Bool
 isLoggedIn = userState $ to validLoggedIn
 
+-- TODO this is not checking much?
 validLoggedIn :: UserState -> Bool
 validLoggedIn us = isJust (us ^. usUserId) && isJust (us ^. usSessionToken)
 

src/Action/Implementation.hs

@@ -44,6 +44,7 @@ import qualified Data.ByteString.Lazy as LBS
 import qualified Thentos.Frontend.CSRF as CSRF (checkCsrfToken)
 
 import Action
+--import Access
 import Config
 import Logger.EventLog
 import Persistent
@@ -173,7 +174,15 @@ instance ActionAvatar Action where
 mkRunAction :: ActionEnv -> Action :~> ExceptT ServantErr IO
 mkRunAction env = Nat run
   where
-    run = withExceptT runActionExcept . ExceptT . fmap (view _1) . runRWSTflip env userLoggedOut
+    handleExns m = ExceptT $ do
+        (e, s, _) <- m
+        pure $ e & _Left %~ mayRedirectToLogin s . runActionExcept
+        -- withExceptT runActionExcept . ExceptT . fmap (view _1) . _H
+    mayRedirectToLogin :: UserState -> ServantErr -> ServantErr
+    mayRedirectToLogin _s e = e {-| validLoggedIn s      = e
+                        -- | errHTTPCode e == 303 = e
+                           | otherwise            = redirectLoginErr-}
+    run = handleExns . runRWSTflip env userLoggedOut
         . runExceptT . unAction . (checkCurrentUser >>)
     runRWSTflip r s comp = runRWST comp r s
 

src/Frontend.hs

@@ -28,6 +28,8 @@ import Network.Wai.Application.Static
     ( StaticSettings
     , ssRedirectToIndex, ssAddTrailingSlash, ssGetMimeType, defaultFileServerSettings, staticApp
     )
+import Network.Wai.Middleware.RequestLogger -- (mkRequestLogger, OutputFormat(..))
+import Network.Wai.Middleware.RequestLogger.JSON (formatAsJSON)
 import Servant
 import System.FilePath (addTrailingPathSeparator)
 import Web.Cookie (SetCookie, def, setCookieName, setCookiePath)
@@ -51,6 +53,7 @@ import Frontend.Testing
 import Logger
 import Persistent.Api (RunPersist)
 import Persistent (withPersist, findUser)
+import System.IO
 
 import qualified Action
 import qualified Backend
@@ -97,9 +100,15 @@ runFrontend' cfg log rp = do
                  . setPort (cfg ^. listenerPort)
                  $ Warp.defaultSettings
 
+    h <- openFile "log.json" AppendMode
+    reqLogging <- mkRequestLogger def
+                    { outputFormat = CustomOutputFormatWithDetails formatAsJSON
+                    , destination = Handle h }
+
     runSettings settings
         . createPageSamples
-        . catch404
+        . catch404 -- TODO
+        . reqLogging
         . serve aulaTopProxy $ aulaTop cfg app
 
 
@@ -432,6 +441,7 @@ aulaAdmin =
     postAdminRemRole user = runPostHandler (pure NeedAdmin) . Page.adminRemRole user
 
 
+-- TODO
 catch404 :: Middleware
 catch404 app req cont = app req $ \resp -> cont $ f resp
   where

src/Persistent/Pure.hs

@@ -338,6 +338,7 @@ deriveSafeCopy 0 'base ''PersistExcept
 runPersistExcept :: PersistExcept -> ServantErr
 runPersistExcept (PersistError500 msg)            = err500 { errBody = cs msg }
 runPersistExcept (PersistError404 msg)            = err404 { errBody = cs msg }
+-- TODO
 runPersistExcept (PersistErrorNotImplemented msg) = err500 { errBody = cs msg }
 runPersistExcept (UserLoginInUse li) =
     err403 { errBody = "user login in use: " <> cs (show li) }