diff --git a/aula.cabal b/aula.cabal index 464fcbc1..b305522b 100644 --- a/aula.cabal +++ b/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 diff --git a/package.yaml b/package.yaml index 5aead5d7..48463022 100644 --- a/package.yaml +++ b/package.yaml @@ -70,6 +70,7 @@ dependencies: - vector - wai - wai-app-static + - wai-extra - warp - yaml diff --git a/src/Action.hs b/src/Action.hs index d99814a0..1cd1c1ef 100644 --- a/src/Action.hs +++ b/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) diff --git a/src/Action/Implementation.hs b/src/Action/Implementation.hs index 02533a9b..60e42637 100644 --- a/src/Action/Implementation.hs +++ b/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 diff --git a/src/Frontend.hs b/src/Frontend.hs index bcefef97..93a93fe5 100644 --- a/src/Frontend.hs +++ b/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 diff --git a/src/Persistent/Pure.hs b/src/Persistent/Pure.hs index 7ba0c24c..6bc26215 100644 --- a/src/Persistent/Pure.hs +++ b/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) }