From 3d91e0fabdefd98f21120352ec218883c2474f78 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 31 Oct 2018 23:55:29 +0100 Subject: [PATCH 1/8] Setup hlint & yesod --- hlint/Hlint.hs | 1 + models | 2 +- package.yaml | 260 ++++++++++++++++++------------------ src/Application.hs | 17 ++- src/Foundation.hs | 3 +- src/Import/NoFoundation.hs | 2 + src/Jobs.hs | 256 ++++++++++++++++++++--------------- src/Jobs/Queue.hs | 20 ++- src/Jobs/Types.hs | 2 +- src/Model/Migration.hs | 40 +++--- src/Settings.hs | 2 +- src/Utils.hs | 1 + src/Utils/Sql.hs | 4 +- stack.yaml | 7 +- test.sh | 2 +- test/CronSpec.hs | 11 +- test/Handler/HomeSpec.hs | 27 +--- test/Handler/ProfileSpec.hs | 15 +-- test/TestImport.hs | 91 +++++++------ 19 files changed, 405 insertions(+), 358 deletions(-) create mode 100644 hlint/Hlint.hs diff --git a/hlint/Hlint.hs b/hlint/Hlint.hs new file mode 100644 index 000000000..4990226af --- /dev/null +++ b/hlint/Hlint.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hlint-test -optF --git -optF -j -optF src #-} diff --git a/models b/models index 88e88243f..d682b5020 100644 --- a/models +++ b/models @@ -11,7 +11,7 @@ User json dateFormat DateTimeFormat "default='%d.%m.%Y'" timeFormat DateTimeFormat "default='%R'" downloadFiles Bool default=false - mailLanguages MailLanguages "default='[]'" + mailLanguages MailLanguages default='[]' notificationSettings NotificationSettings UniqueAuthentication ident UniqueEmail email diff --git a/package.yaml b/package.yaml index 246f6bcf3..820a16e46 100644 --- a/package.yaml +++ b/package.yaml @@ -2,114 +2,111 @@ name: uniworx version: "0.0.0" dependencies: - -# Due to a bug in GHC 8.0.1, we block its usage -# See: https://ghc.haskell.org/trac/ghc/ticket/12130 -- base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5 - -# version 1.0 had a bug in reexporting Handler, causing trouble -- classy-prelude-yesod >=0.10.2 && <1.0 || >=1.1 - -- foreign-store -- yesod >=1.4.3 && <1.5 -- yesod-core >=1.4.30 && <1.5 -- yesod-auth >=1.4.0 && <1.5 -- yesod-static >=1.4.0.3 && <1.6 -- yesod-form >=1.4.0 && <1.5 -- classy-prelude >=0.10.2 -- classy-prelude-conduit >=0.10.2 -- bytestring >=0.9 && <0.11 -- text >=0.11 && <2.0 -- persistent >=2.7.2 && <2.8 -- persistent-postgresql >=2.1.1 && <2.8 -- persistent-template >=2.0 && <2.8 -- template-haskell -- shakespeare >=2.0 && <2.1 -- hjsmin >=0.1 && <0.3 -- monad-control >=0.3 && <1.1 -- wai-extra >=3.0 && <3.1 -- yaml >=0.8 && <0.9 -- http-conduit >=2.1 && <2.3 -- directory >=1.1 && <1.4 -- warp >=3.0 && <3.3 -- data-default -- aeson >=0.6 && <1.3 -- conduit >=1.0 && <2.0 -- monad-logger >=0.3 && <0.4 -- fast-logger >=2.2 && <2.5 -- wai-logger >=2.2 && <2.4 -- file-embed -- safe -- unordered-containers -- containers -- vector -- time -- case-insensitive -- wai -- cryptonite -- cryptonite-conduit -- saltine -- base64-bytestring -- memory -- http-api-data -- profunctors -- colonnade >=1.1.1 -- yesod-colonnade >=1.1.0 -- blaze-markup -- zip-stream -- filepath -- transformers -- wl-pprint-text -- uuid-types -- path-pieces -- uuid-crypto -- filepath-crypto -- cryptoids-types -- cryptoids -- cryptoids-class -- binary -- cereal -- mtl -- sandi -- esqueleto -- mime-types -- generic-deriving -- blaze-html -- conduit-resumablesink >=0.2 -- parsec -- uuid -- exceptions -- stm -- stm-chans -- stm-conduit -- lens -- MonadRandom -- email-validate -- scientific -- tz -- system-locale -- th-lift-instances -- gitrev -- Glob -- ldap-client -- connection -- universe -- universe-base -- random -- random-shuffle -- th-abstraction -- HaskellNet -- HaskellNet-SSL -- network -- resource-pool -- mime-mail -- hashable -- aeson-pretty -- resourcet -- postgresql-simple -- word24 -- mmorph -- clientsession + # Due to a bug in GHC 8.0.1, we block its usage + # See: https://ghc.haskell.org/trac/ghc/ticket/12130 + - base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5 + # version 1.0 had a bug in reexporting Handler, causing trouble + - classy-prelude-yesod >=0.10.2 && <1.0 || >=1.1 + - foreign-store + - yesod >=1.4.3 && <1.5 + - yesod-core >=1.4.30 && <1.5 + - yesod-auth >=1.4.0 && <1.5 + - yesod-static >=1.4.0.3 && <1.6 + - yesod-form >=1.4.0 && <1.5 + - classy-prelude >=0.10.2 + - classy-prelude-conduit >=0.10.2 + - bytestring >=0.9 && <0.11 + - text >=0.11 && <2.0 + - persistent >=2.7.2 && <2.8 + - persistent-postgresql >=2.1.1 && <2.8 + - persistent-template >=2.0 && <2.8 + - template-haskell + - shakespeare >=2.0 && <2.1 + - hjsmin >=0.1 && <0.3 + - monad-control >=0.3 && <1.1 + - wai-extra >=3.0 && <3.1 + - yaml >=0.8 && <0.9 + - http-conduit >=2.1 && <2.3 + - directory >=1.1 && <1.4 + - warp >=3.0 && <3.3 + - data-default + - aeson >=0.6 && <1.3 + - conduit >=1.0 && <2.0 + - monad-logger >=0.3 && <0.4 + - fast-logger >=2.2 && <2.5 + - wai-logger >=2.2 && <2.4 + - file-embed + - safe + - unordered-containers + - containers + - vector + - time + - case-insensitive + - wai + - cryptonite + - cryptonite-conduit + - saltine + - base64-bytestring + - memory + - http-api-data + - profunctors + - colonnade >=1.1.1 + - yesod-colonnade >=1.1.0 + - blaze-markup + - zip-stream + - filepath + - transformers + - wl-pprint-text + - uuid-types + - path-pieces + - uuid-crypto + - filepath-crypto + - cryptoids-types + - cryptoids + - cryptoids-class + - binary + - cereal + - mtl + - sandi + - esqueleto + - mime-types + - generic-deriving + - blaze-html + - conduit-resumablesink >=0.2 + - parsec + - uuid + - exceptions + - stm + - stm-chans + - stm-conduit + - lens + - MonadRandom + - email-validate + - scientific + - tz + - system-locale + - th-lift-instances + - gitrev + - Glob + - ldap-client + - connection + - universe + - universe-base + - random + - random-shuffle + - th-abstraction + - HaskellNet + - HaskellNet-SSL + - network + - resource-pool + - mime-mail + - hashable + - aeson-pretty + - resourcet + - postgresql-simple + - word24 + - mmorph + - clientsession other-extensions: - GeneralizedNewtypeDeriving @@ -159,6 +156,10 @@ default-extensions: - BinaryLiterals - PolyKinds +ghc-options: + - -Wall + - -fwarn-tabs + # The library contains all of our application code. The executable # defined below is just a thin wrapper. library: @@ -167,16 +168,12 @@ library: - condition: (flag(dev)) || (flag(library-only)) then: ghc-options: - - -Wall - - -fwarn-tabs - - -O0 - - -ddump-splices + - -O0 + - -ddump-splices cpp-options: -DDEVELOPMENT else: ghc-options: - - -Wall - - -fwarn-tabs - - -O2 + - -O2 # Runnable executable for our application executables: @@ -184,28 +181,33 @@ executables: main: main.hs source-dirs: app ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N + - -threaded + - -rtsopts + - -with-rtsopts=-N dependencies: - - uniworx + - uniworx when: - - condition: flag(library-only) - buildable: false + - condition: flag(library-only) + buildable: false # Test suite tests: - test: + yesod: main: Spec.hs source-dirs: test - ghc-options: -Wall dependencies: - - uniworx - - hspec >=2.0.0 - - QuickCheck - - yesod-test - - conduit-extra - - quickcheck-instances + - uniworx + - hspec >=2.0.0 + - QuickCheck + - yesod-test + - conduit-extra + - quickcheck-instances + hlint: + main: Hlint.hs + other-modules: [] + source-dirs: hlint + dependencies: + - hlint-test # Define flags used by "yesod devel" to make compilation faster flags: diff --git a/src/Application.hs b/src/Application.hs index 3757d98f7..94f30e34c 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -30,9 +30,11 @@ import Network.Wai.Middleware.RequestLogger (Destination (Logger), IPAddrSource (..), OutputFormat (..), destination, mkRequestLogger, outputFormat) -import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, +import System.Log.FastLogger (defaultBufSize, newStderrLoggerSet, toLogStr) +import qualified Data.Map.Strict as Map + import Foreign.Store import qualified Data.UUID as UUID @@ -100,16 +102,14 @@ makeFoundation appSettings@(AppSettings{..}) = do appHttpManager <- newManager appLogger <- liftIO $ do tgetter <- newTimeCache "%Y-%m-%d %T %z" - loggerSet <- newStdoutLoggerSet defaultBufSize + loggerSet <- newStderrLoggerSet defaultBufSize return $ Yesod.Logger loggerSet tgetter appStatic <- liftIO $ bool static staticDevel appMutableStatic appStaticDir appInstanceID <- liftIO $ maybe UUID.nextRandom (either readInstanceIDFile return) appInitialInstanceID - (appJobCtl, recvChans) <- fmap unzip . atomically . replicateM appJobWorkers $ do - chan <- newBroadcastTMChan - recvChan <- dupTMChan chan - return (chan, recvChan) + appJobCtl <- liftIO $ newTVarIO Map.empty + appCronThread <- liftIO newEmptyTMVarIO appLogSettings <- liftIO $ newTVarIO appInitialLogSettings @@ -149,7 +149,7 @@ makeFoundation appSettings@(AppSettings{..}) = do let foundation = mkFoundation sqlPool smtpPool appCryptoIDKey appSessionKey appErrorMsgKey - handleJobs recvChans foundation + handleJobs foundation -- Return the foundation return foundation @@ -322,8 +322,7 @@ getApplicationRepl = do return (getPort wsettings, foundation, app1) shutdownApp :: MonadIO m => UniWorX -> m () -shutdownApp UniWorX{..} = do - liftIO . atomically $ mapM_ closeTMChan appJobCtl +shutdownApp = stopJobCtl --------------------------------------------- diff --git a/src/Foundation.hs b/src/Foundation.hs index cd09b4ad8..4cb048b8d 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -118,7 +118,8 @@ data UniWorX = UniWorX , appLogSettings :: TVar LogSettings , appCryptoIDKey :: CryptoIDKey , appInstanceID :: InstanceId - , appJobCtl :: [TMChan JobCtl] + , appJobCtl :: TVar (Map ThreadId (TMChan JobCtl)) + , appCronThread :: TMVar (ReleaseKey, ThreadId) , appErrorMsgKey :: SecretBox.Key , appSessionKey :: ClientSession.Key } diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 51f05a9cb..9d80282a3 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -40,6 +40,8 @@ import Data.List.NonEmpty as Import (NonEmpty(..)) import Control.Monad.Morph as Import (MFunctor(..)) +import Control.Monad.Trans.Resource as Import (ReleaseKey) + import Control.Monad.Trans.RWS (RWST) diff --git a/src/Jobs.hs b/src/Jobs.hs index 112a1376f..e3b4b0276 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -2,6 +2,7 @@ module Jobs ( module Types , module Jobs.Queue , handleJobs + , stopJobCtl ) where import Import @@ -25,7 +26,7 @@ import Data.Semigroup (Max(..)) import Utils.Sql -import Control.Monad.Random (evalRand, mkStdGen) +import Control.Monad.Random (evalRand, mkStdGen, getRandomR) import Cron import qualified Data.HashMap.Strict as HashMap @@ -33,18 +34,19 @@ import Data.HashMap.Strict (HashMap) import qualified Data.List.NonEmpty as NonEmpty +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map + import Data.Foldable (foldrM) import Control.Monad.Trans.Reader (mapReaderT) import Control.Monad.Trans.State (StateT, evalStateT, mapStateT) import qualified Control.Monad.State.Class as State import Control.Monad.Reader.Class (MonadReader(..)) -import Control.Monad.Trans.Resource (MonadResourceBase, ResourceT, runResourceT, allocate) +import Control.Monad.Trans.Resource (MonadResourceBase, ResourceT, runResourceT, allocate, release) import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Logger -import Control.Monad.Random (MonadRandom(..), evalRand) - import Data.Time.Clock import Data.Time.Zones @@ -66,131 +68,171 @@ data JobQueueException = JInvalid QueuedJobId QueuedJob instance Exception JobQueueException -handleJobs :: (MonadResource m, MonadIO m) => [TMChan JobCtl] -> UniWorX -> m () --- | Read control commands from `appJobCtl` and address them as they come in +handleJobs :: ( MonadResource m + , MonadIO m + ) + => UniWorX -> m () +-- | Spawn a set of workers that read control commands from `appJobCtl` and address them as they come in -- -- Uses `unsafeHandler`, as per documentation all HTTP-related fields of state/environment are meaningless placeholders. -- Handling commands in `HandlerT` provides us with the facilities to render urls, unifies logging, provides a value of the foundation type, ... -handleJobs recvChans foundation@UniWorX{..} = do - jobCrontab <- liftIO $ newTVarIO HashMap.empty +handleJobs foundation@UniWorX{..} = do + let num = appJobWorkers appSettings + + jobCrontab <- liftIO $ newTMVarIO HashMap.empty jobConfirm <- liftIO $ newTVarIO HashMap.empty - forM_ (zip [1..] recvChans) $ \(n, chan) -> + forM_ [1..num] $ \n -> do + (bChan, chan) <- atomically $ newBroadcastTMChan >>= (\c -> (c, ) <$> dupTMChan c) let logStart = $logDebugS ("Jobs #" <> tshow n) "Starting" logStop = $logDebugS ("Jobs #" <> tshow n) "Stopping" - doFork = fork . unsafeHandler foundation . bracket_ logStart logStop . flip runReaderT JobContext{..} . runConduit $ sourceTMChan chan .| handleJobs' n - in void $ allocate (liftIO doFork) (\_ -> liftIO . atomically $ closeTMChan chan) + removeChan = atomically . modifyTVar' appJobCtl . Map.delete =<< myThreadId + doFork = flip forkFinally (\_ -> removeChan) . unsafeHandler foundation . bracket_ logStart logStop . flip runReaderT JobContext{..} . runConduit $ sourceTMChan chan .| handleJobs' n + (_, tId) <- allocate (liftIO doFork) (\_ -> liftIO . atomically $ closeTMChan chan) + atomically . modifyTVar' appJobCtl $ Map.insert tId bChan -- Start cron operation - void $ allocate (liftIO . fork . unsafeHandler foundation $ runReaderT execCrontab JobContext{..}) (liftIO . killThread) - liftIO . unsafeHandler foundation . flip runReaderT JobContext{..} $ - writeJobCtlBlock JobCtlDetermineCrontab + registeredCron <- liftIO newEmptyTMVarIO + let execCrontab' = whenM (atomically $ readTMVar registeredCron) $ + unsafeHandler foundation $ runReaderT execCrontab JobContext{..} + unregister = atomically . whenM (fromMaybe False <$> tryReadTMVar registeredCron) . void $ tryTakeTMVar appCronThread + cData <- allocate (liftIO . forkFinally execCrontab' $ \_ -> unregister) (\_ -> liftIO . atomically . void $ tryTakeTMVar jobCrontab) + registeredCron' <- atomically $ do + registeredCron' <- tryPutTMVar appCronThread cData + registeredCron' <$ putTMVar registeredCron registeredCron' + when registeredCron' $ + liftIO . unsafeHandler foundation . flip runReaderT JobContext{..} $ + writeJobCtlBlock JobCtlDetermineCrontab + +stopJobCtl :: MonadIO m => UniWorX -> m () +-- ^ Stop all worker threads currently running +stopJobCtl UniWorX{appJobCtl, appCronThread} = do + mcData <- atomically $ tryReadTMVar appCronThread + whenIsJust mcData $ \(rKey, _) -> do + liftIO $ release rKey + atomically . guardM $ isEmptyTMVar appCronThread + + wMap <- liftIO $ readTVarIO appJobCtl + atomically $ forM_ wMap closeTMChan + atomically $ do + wMap' <- readTVar appJobCtl + guard . none (`Map.member` wMap') $ Map.keysSet wMap execCrontab :: ReaderT JobContext (HandlerT UniWorX IO) () -- ^ Keeping a `HashMap` of the latest execution times of `JobCtl`s we have -- seen, wait for the time of the next job and fire it -execCrontab = flip evalStateT HashMap.empty . forever $ do - mapStateT (liftHandlerT . runDB . setSerializable) $ do - let - merge (Entity leId CronLastExec{..}) - | Just job <- Aeson.parseMaybe parseJSON cronLastExecJob - = State.modify $ HashMap.insertWith (<>) (JobCtlQueue job) (Max cronLastExecTime) - | otherwise = lift $ delete leId - runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ merge - - now <- liftIO getCurrentTime - (currentCrontab, (jobCtl, nextMatch)) <- mapStateT (mapReaderT $ liftIO . atomically) $ do - crontab <- liftBase . readTVar =<< asks jobCrontab - State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab - prevExec <- State.get - case earliestJob prevExec crontab now of - Nothing -> liftBase retry - Just (_, MatchNone) -> liftBase retry - Just x -> return (crontab, x) - - let doJob = mapStateT (mapReaderT $ liftHandlerT . runDBJobs . setSerializable) $ do - newCrontab <- lift . lift . hoist lift $ determineCrontab' - if - | ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab - -> do - now <- liftIO $ getCurrentTime - instanceID <- getsYesod appInstanceID - State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl - case jobCtl of - JobCtlQueue job -> do - lift . lift $ upsertBy - (UniqueCronLastExec $ toJSON job) - CronLastExec - { cronLastExecJob = toJSON job - , cronLastExecTime = now - , cronLastExecInstance = instanceID - } - [ CronLastExecTime =. now ] - lift . lift $ queueDBJob job - other -> writeJobCtl other - | otherwise - -> lift . mapReaderT (liftIO . atomically) $ - lift . flip writeTVar newCrontab =<< asks jobCrontab - - case nextMatch of - MatchAsap -> doJob - MatchNone -> return () - MatchAt nextTime -> do - JobContext{jobCrontab} <- ask - nextTime' <- applyJitter jobCtl nextTime - $logDebugS "Cron" [st|Waiting until #{tshow (utcToLocalTimeTZ appTZ nextTime')} to execute #{tshow jobCtl}|] - logFunc <- askLoggerIO - whenM (liftIO . flip runLoggingT logFunc $ waitUntil jobCrontab currentCrontab nextTime') - doJob +execCrontab = evalStateT go HashMap.empty where - acc :: NominalDiffTime - acc = 1e-3 + go = do + mapStateT (liftHandlerT . runDB . setSerializable) $ do + let + merge (Entity leId CronLastExec{..}) + | Just job <- Aeson.parseMaybe parseJSON cronLastExecJob + = State.modify $ HashMap.insertWith (<>) (JobCtlQueue job) (Max cronLastExecTime) + | otherwise = lift $ delete leId + runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ merge - applyJitter :: (MonadHandler m, HandlerSite m ~ UniWorX, Hashable seed) => seed -> UTCTime -> m UTCTime - applyJitter seed t = do - appInstance <- getsYesod appInstanceID - let - halfRange = truncate $ 0.5 / acc - diff = evalRand ( (* acc) . fromInteger <$> getRandomR (- halfRange, halfRange)) $ mkStdGen (hash appInstance `hashWithSalt` seed) - return $ addUTCTime diff t + now <- liftIO getCurrentTime + currentState <- mapStateT (mapReaderT $ liftIO . atomically) $ do + crontab' <- liftBase . tryReadTMVar =<< asks jobCrontab + case crontab' of + Nothing -> return Nothing + Just crontab -> Just <$> do + State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab + prevExec <- State.get + case earliestJob prevExec crontab now of + Nothing -> liftBase retry + Just (_, MatchNone) -> liftBase retry + Just x -> return (crontab, x) - earliestJob :: HashMap JobCtl (Max UTCTime) -> Crontab JobCtl -> UTCTime -> Maybe (JobCtl, CronNextMatch UTCTime) - earliestJob lastTimes crontab now = foldr go Nothing $ HashMap.toList crontab + case currentState of + Nothing -> return () + Just (currentCrontab, (jobCtl, nextMatch)) -> do + let doJob = mapStateT (mapReaderT $ liftHandlerT . runDBJobs . setSerializable) $ do + newCrontab <- lift . lift . hoist lift $ determineCrontab' + if + | ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab + -> do + now <- liftIO $ getCurrentTime + instanceID <- getsYesod appInstanceID + State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl + case jobCtl of + JobCtlQueue job -> do + lift . lift $ upsertBy + (UniqueCronLastExec $ toJSON job) + CronLastExec + { cronLastExecJob = toJSON job + , cronLastExecTime = now + , cronLastExecInstance = instanceID + } + [ CronLastExecTime =. now ] + lift . lift $ queueDBJob job + other -> writeJobCtl other + | otherwise + -> lift . mapReaderT (liftIO . atomically) $ + lift . void . flip swapTMVar newCrontab =<< asks jobCrontab + + case nextMatch of + MatchAsap -> doJob + MatchNone -> return () + MatchAt nextTime -> do + JobContext{jobCrontab} <- ask + nextTime' <- applyJitter jobCtl nextTime + $logDebugS "Cron" [st|Waiting until #{tshow (utcToLocalTimeTZ appTZ nextTime')} to execute #{tshow jobCtl}|] + logFunc <- askLoggerIO + whenM (liftIO . flip runLoggingT logFunc $ waitUntil jobCrontab currentCrontab nextTime') + doJob + + go where - go (jobCtl, cron) mbPrev - | Just (_, t') <- mbPrev - , t' < t - = mbPrev - | otherwise - = Just (jobCtl, t) + acc :: NominalDiffTime + acc = 1e-3 + + applyJitter :: (MonadHandler m, HandlerSite m ~ UniWorX, Hashable seed) => seed -> UTCTime -> m UTCTime + applyJitter seed t = do + appInstance <- getsYesod appInstanceID + let + halfRange = truncate $ 0.5 / acc + diff = evalRand ( (* acc) . fromInteger <$> getRandomR (- halfRange, halfRange)) $ mkStdGen (hash appInstance `hashWithSalt` seed) + return $ addUTCTime diff t + + earliestJob :: HashMap JobCtl (Max UTCTime) -> Crontab JobCtl -> UTCTime -> Maybe (JobCtl, CronNextMatch UTCTime) + earliestJob lastTimes crontab now = foldr go' Nothing $ HashMap.toList crontab where - t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) now cron + go' (jobCtl, cron) mbPrev + | Just (_, t') <- mbPrev + , t' < t + = mbPrev + | otherwise + = Just (jobCtl, t) + where + t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) now cron - waitUntil :: (Eq a, MonadResourceBase m, MonadLogger m) => TVar a -> a -> UTCTime -> m Bool - waitUntil crontabTV crontab nextTime = runResourceT $ do - diffT <- diffUTCTime nextTime <$> liftIO getCurrentTime - let waitTime = fromInteger (truncate $ diffT / acc) * toRational acc - waitTime' - | diffT < acc = "Done" - | otherwise = tshow (realToFrac waitTime :: NominalDiffTime) - $logDebugS "waitUntil" [st|#{tshow diffT} (#{waitTime'})|] - if - | diffT < acc -> return True - | otherwise -> do - retVar <- liftIO newEmptyTMVarIO - void $ allocate (liftIO $ forkFinally (threadDelay . round $ waitTime * 1e6) $ atomically . putTMVar retVar) (liftIO . killThread) - let - awaitDelayThread = False <$ takeTMVar retVar - awaitCrontabChange = do - crontab' <- readTVar crontabTV - True <$ guard (crontab /= crontab') - crontabChanged <- liftIO . atomically $ awaitCrontabChange <|> awaitDelayThread - bool (waitUntil crontabTV crontab nextTime) (return False) crontabChanged + waitUntil :: (Eq a, MonadResourceBase m, MonadLogger m) => TMVar a -> a -> UTCTime -> m Bool + waitUntil crontabTV crontab nextTime = runResourceT $ do + diffT <- diffUTCTime nextTime <$> liftIO getCurrentTime + let waitTime = fromInteger (truncate $ diffT / acc) * toRational acc + waitTime' + | diffT < acc = "Done" + | otherwise = tshow (realToFrac waitTime :: NominalDiffTime) + $logDebugS "waitUntil" [st|#{tshow diffT} (#{waitTime'})|] + if + | diffT < acc -> return True + | otherwise -> do + retVar <- liftIO newEmptyTMVarIO + void . liftIO . forkFinally (threadDelay . round $ waitTime * 1e6) $ atomically . putTMVar retVar + let + awaitDelayThread = False <$ takeTMVar retVar + awaitCrontabChange = do + crontab' <- tryReadTMVar crontabTV + True <$ guard (Just crontab /= crontab') + crontabChanged <- liftIO . atomically $ awaitCrontabChange <|> awaitDelayThread + bool (waitUntil crontabTV crontab nextTime) (return False) crontabChanged -handleJobs' :: Int -> Sink JobCtl (ReaderT JobContext Handler) () +handleJobs' :: Natural -> Sink JobCtl (ReaderT JobContext Handler) () handleJobs' wNum = C.mapM_ $ \jctl -> do $logDebugS logIdent $ tshow jctl resVars <- mapReaderT (liftIO . atomically) $ @@ -228,7 +270,7 @@ handleJobs' wNum = C.mapM_ $ \jctl -> do newCTab <- liftHandlerT . runDB $ setSerializable determineCrontab' -- $logDebugS logIdent $ tshow newCTab mapReaderT (liftIO . atomically) $ - lift . flip writeTVar newCTab =<< asks jobCrontab + lift . void . flip swapTMVar newCTab =<< asks jobCrontab jLocked :: QueuedJobId -> (QueuedJob -> Handler a) -> Handler a jLocked jId act = do diff --git a/src/Jobs/Queue.hs b/src/Jobs/Queue.hs index db5f2d8e5..bc9ab4fee 100644 --- a/src/Jobs/Queue.hs +++ b/src/Jobs/Queue.hs @@ -17,15 +17,26 @@ import Control.Monad.Trans.Reader (ReaderT, mapReaderT) import qualified Data.Set as Set import qualified Data.List.NonEmpty as NonEmpty import qualified Data.HashMap.Strict as HashMap +import qualified Data.Map.Strict as Map -import Control.Monad.Random (MonadRandom(..), evalRand, mkStdGen, uniform) +import Control.Monad.Random (evalRand, mkStdGen, uniform) + + +data JobQueueException = JobQueuePoolEmpty + deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic) + +instance Exception JobQueueException writeJobCtl :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> m () writeJobCtl cmd = do tid <- liftIO myThreadId - chan <- flip evalRand (mkStdGen (hash tid `hashWithSalt` cmd)) . uniform <$> getsYesod appJobCtl - liftIO . atomically $ writeTMChan chan cmd + wMap <- getsYesod appJobCtl >>= liftIO . readTVarIO + if + | null wMap -> throwM JobQueuePoolEmpty + | otherwise -> do + let chan = flip evalRand (mkStdGen (hash tid `hashWithSalt` cmd)) $ uniform wMap + liftIO . atomically $ writeTMChan chan cmd writeJobCtlBlock :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> ReaderT JobContext m () writeJobCtlBlock cmd = do @@ -72,6 +83,3 @@ runDBJobs act = do (ret, jIds) <- liftHandlerT . runDB $ mapReaderT runWriterT act forM_ jIds $ writeJobCtl . JobCtlPerform return ret - - - diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 20af81933..6a6e65109 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -55,6 +55,6 @@ instance Hashable JobCtl data JobContext = JobContext - { jobCrontab :: TVar (Crontab JobCtl) + { jobCrontab :: TMVar (Crontab JobCtl) , jobConfirm :: TVar (HashMap JobCtl (NonEmpty (TMVar (Maybe SomeException)))) } diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 92bc5c8d3..bfb645af6 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -75,15 +75,15 @@ migrateAll = do Confusion about quotes, from the PostgreSQL Manual: Single quotes for string constants, double quotes for table/column names. - QuasiQuoter: ^{TableName} @{ColumnName} (includes Escaping); - #{anything} (no escaping); + QuasiQuoter: ^{TableName} @{ColumnName} (escaped as column/table-name; value determined from current model); + #{anything} (escaped as value); -} customMigrations :: MonadIO m => Map (Key AppliedMigration) (ReaderT SqlBackend m ()) customMigrations = Map.fromListWith (>>) [ ( AppliedMigrationKey [migrationVersion|initial|] [version|0.0.0|] - , whenM (tableExists "user") $ do -- New theme format + , whenM (columnExists "user" "theme") $ do -- New theme format userThemes <- [sqlQQ| SELECT "id", "theme" FROM "user"; |] forM_ userThemes $ \(uid, Single str) -> case stripPrefix "theme--" str of Just v @@ -98,7 +98,7 @@ customMigrations = Map.fromListWith (>>) |] ) , ( AppliedMigrationKey [migrationVersion|1.0.0|] [version|2.0.0|] - , whenM (tableExists "school") $ do -- SchoolId is the Shorthand CI Text now + , whenM (columnExists "school" "id") $ do -- SchoolId is the Shorthand CI Text now -- Read old table into memory schoolTable <- [sqlQQ| SELECT "id", "shorthand" FROM "school"; |] let _sT = schoolTable :: [(Single Int64, Single (CI Text))] -- Types needed @@ -143,9 +143,9 @@ customMigrations = Map.fromListWith (>>) FOREIGN KEY (school) REFERENCES school(shorthand); |] [executeQQ| - ALTER TABLE "school" DROP COLUMN "id"; - ALTER TABLE "school" ADD PRIMARY KEY (shorthand); - |] + ALTER TABLE "school" DROP COLUMN "id"; + ALTER TABLE "school" ADD PRIMARY KEY (shorthand); + |] ) , ( AppliedMigrationKey [migrationVersion|2.0.0|] [version|3.0.0|] , whenM (tableExists "sheet_corrector") $ do -- Load is encoded as JSON now. @@ -161,7 +161,7 @@ customMigrations = Map.fromListWith (>>) , whenM (tableExists "user") $ do userDisplayNames <- [sqlQQ| SELECT "id", "display_name" FROM "user"; |] [executeQQ| - ALTER TABLE "user" ADD COLUMN "surname" text DEFAULT ''; + ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "surname" text DEFAULT ''; |] forM_ userDisplayNames $ \(uid, Single str) -> case lastMaybe $ words str of Just name -> update uid [UserSurname =. name] @@ -170,23 +170,22 @@ customMigrations = Map.fromListWith (>>) , ( AppliedMigrationKey [migrationVersion|3.1.0|] [version|3.2.0|] , whenM (tableExists "sheet") $ do [executeQQ| - ALTER TABLE "sheet" ADD COLUMN "upload_mode" json DEFAULT '{ "tag": "Upload", "unpackZips": true }'; + ALTER TABLE "sheet" ADD COLUMN IF NOT EXISTS "upload_mode" json DEFAULT '{ "tag": "Upload", "unpackZips": true }'; |] ) , ( AppliedMigrationKey [migrationVersion|3.2.0|] [version|4.0.0|] - , whenM (tableExists "user") $ do + , whenM (columnExists "user" "plugin") $ do -- <> is standard sql for /= [executeQQ| DELETE FROM "user" WHERE "plugin" <> 'LDAP'; ALTER TABLE "user" DROP COLUMN "plugin"; - ALTER TABLE "user" ADD COLUMN "authentication" json DEFAULT '"ldap"'; + ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "authentication" json DEFAULT '"ldap"'; |] ) , ( AppliedMigrationKey [migrationVersion|4.0.0|] [version|5.0.0|] , whenM (tableExists "user") $ do [executeQQ| - ALTER TABLE "user" ADD COLUMN "notification_settings" json DEFAULT null; - UPDATE "user" SET "notification_settings" = (#{def :: NotificationSettings} :: json) WHERE "notification_settings" is null; + ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "notification_settings" json NOT NULL DEFAULT '[]'; |] ) , ( AppliedMigrationKey [migrationVersion|5.0.0|] [version|6.0.0|] @@ -200,7 +199,18 @@ customMigrations = Map.fromListWith (>>) tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool tableExists table = do - haveSchoolTable <- [sqlQQ| SELECT to_regclass(#{table}); |] - case haveSchoolTable :: [Maybe (Single PersistValue)] of + haveTable <- [sqlQQ| SELECT to_regclass(#{table}); |] + case haveTable :: [Maybe (Single PersistValue)] of [Just _] -> return True _other -> return False + +columnExists :: MonadIO m + => Text -- ^ Table + -> Text -- ^ Column + -> ReaderT SqlBackend m Bool +columnExists table column = do + haveColumn <- [sqlQQ|SELECT column_name FROM information_schema.columns WHERE table_name=#{table} and column_name=#{column};|] + case haveColumn :: [Single PersistValue] of + [_] -> return True + _other -> return False + diff --git a/src/Settings.hs b/src/Settings.hs index 82b7f7ec0..46e35fdf1 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -81,7 +81,7 @@ data AppSettings = AppSettings , appMailObjectDomain :: Text , appMailVerp :: VerpMode , appMailSupport :: Address - , appJobWorkers :: Int + , appJobWorkers :: Natural , appJobFlushInterval :: Maybe NominalDiffTime , appJobCronInterval :: NominalDiffTime , appJobStaleThreshold :: NominalDiffTime diff --git a/src/Utils.hs b/src/Utils.hs index a95c79722..9da6dbe8b 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -20,6 +20,7 @@ import Utils.DateTime as Utils import Utils.PathPiece as Utils import Utils.Message as Utils import Utils.Lang as Utils +import Control.Lens as Utils (none) import Text.Blaze (Markup, ToMarkup) diff --git a/src/Utils/Sql.hs b/src/Utils/Sql.hs index f56ac38a2..aae593c05 100644 --- a/src/Utils/Sql.hs +++ b/src/Utils/Sql.hs @@ -6,7 +6,7 @@ import ClassyPrelude.Yesod import Database.Persist.Sql -import Database.PostgreSQL.Simple (sqlErrorHint) +import Database.PostgreSQL.Simple (SqlError(SqlError), sqlErrorHint) import Control.Monad.Catch (handleIf) import Data.Time.Clock @@ -18,7 +18,7 @@ setSerializable act = setSerializable' (0 :: Integer) setSerializable' (min 10 -> logBackoff) = handleIf - (\e -> "The transaction might succeed if retried." `isInfixOf` sqlErrorHint e) + (\SqlError{sqlErrorHint} -> "The transaction might succeed if retried." `isInfixOf` sqlErrorHint) (\e -> do let delay :: NominalDiffTime diff --git a/stack.yaml b/stack.yaml index 2551d1ab6..f046a45e2 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,7 @@ -flags: {} +flags: + uniworx: + dev: true + library-only: true nix: packages: [] @@ -38,4 +41,6 @@ extra-deps: - saltine-0.1.0.1 + - hlint-test-0.1.0.0 + resolver: lts-10.5 diff --git a/test.sh b/test.sh index 9e3db3ebe..26f865cb1 100755 --- a/test.sh +++ b/test.sh @@ -11,4 +11,4 @@ if [[ -d .stack-work-test ]]; then trap move-back EXIT fi -stack test --flag uniworx:dev --flag uniworx:library-only ${@} +stack build --test --fast --flag uniworx:dev --flag uniworx:library-only ${@} diff --git a/test/CronSpec.hs b/test/CronSpec.hs index af942ea77..ee9abe812 100644 --- a/test/CronSpec.hs +++ b/test/CronSpec.hs @@ -5,7 +5,6 @@ module CronSpec where import TestImport import Cron -import Numeric.Natural import Data.Time import Data.Time.Clock.System @@ -22,9 +21,9 @@ sampleCron :: Natural -> Cron -> [UTCTime] sampleCron n = go n baseTime Nothing where go 0 _ _ _ = [] - go n t mPrev cron = case nextCronMatch utcTZ mPrev t cron of - MatchAsap -> t : go (pred n) t (Just t) cron - MatchAt t' -> t' : go (pred n) t' (Just t') cron + go (pred -> n') t mPrev cron = case nextCronMatch utcTZ mPrev t cron of + MatchAsap -> t : go n' t (Just t) cron + MatchAt t' -> t' : go n' t' (Just t') cron MatchNone -> [] @@ -32,8 +31,8 @@ spec :: Spec spec = do describe "Cron" $ do it "generates correct example series" . mapM_ seriesExample $ - [ (Cron CronAsap Nothing CronScheduleBefore, [baseTime]) - , (Cron CronAsap (Just $ CronPeriod 10 CronAsap) CronScheduleBefore, iterate (addUTCTime 10) baseTime) + [ (Cron CronAsap CronRepeatNever 0 (Right CronNotScheduled), [baseTime]) + , (Cron CronAsap (CronRepeatScheduled CronAsap) 10 (Right CronNotScheduled), iterate (addUTCTime 10) baseTime) ] seriesExample :: (Cron, [UTCTime]) -> Expectation diff --git a/test/Handler/HomeSpec.hs b/test/Handler/HomeSpec.hs index 5ad322254..35eb111d1 100644 --- a/test/Handler/HomeSpec.hs +++ b/test/Handler/HomeSpec.hs @@ -6,30 +6,11 @@ import TestImport spec :: Spec spec = withApp $ do - describe "Homepage" $ do it "loads the index and checks it looks right" $ do - get HomeR - statusIs 200 - htmlAnyContain "h1" "a modern framework for blazing fast websites" - request $ do - setMethod "POST" - setUrl HomeR - addToken - fileByLabel "Choose a file" "test/Spec.hs" "text/plain" -- talk about self-reference - byLabel "What's on the file?" "Some Content" - + setMethod "GET" + setUrl HomeR + addRequestHeader ("Accept-Language", "de") statusIs 200 - -- more debugging printBody - htmlAllContain ".upload-response" "text/plain" - htmlAllContain ".upload-response" "Some Content" - - -- This is a simple example of using a database access in a test. The - -- test will succeed for a fresh scaffolded site with an empty database, - -- but will fail on an existing database with a non-empty user table. - it "leaves the user table empty" $ do - get HomeR - statusIs 200 - users <- runDB $ selectList ([] :: [Filter User]) [] - assertEq "user table empty" 0 $ length users + htmlAnyContain "h1" "Aktuelle Termine" diff --git a/test/Handler/ProfileSpec.hs b/test/Handler/ProfileSpec.hs index e0f8ed5c2..b14e59868 100644 --- a/test/Handler/ProfileSpec.hs +++ b/test/Handler/ProfileSpec.hs @@ -4,15 +4,16 @@ module Handler.ProfileSpec (spec) where import TestImport -import qualified Data.CaseInsensitive as CI - spec :: Spec spec = withApp $ do describe "Profile page" $ do it "asserts no access to my-account for anonymous users" $ do get ProfileR - statusIs 403 + loc <- getLocation + assertEq "Redirect is to Login" loc + either (fail . unpack) (\_ -> return ()) =<< followRedirect + statusIs 200 it "asserts access to my-account for authenticated users" $ do userEntity <- createUser "foo" @@ -20,11 +21,3 @@ spec = withApp $ do get ProfileR statusIs 200 - - it "asserts user's information is shown" $ do - userEntity <- createUser "bar" - authenticateAs userEntity - - get ProfileR - let (Entity _ user) = userEntity - htmlAnyContain ".username" . unpack . CI.original $ userIdent user diff --git a/test/TestImport.hs b/test/TestImport.hs index bf7f56729..32b83ad33 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - module TestImport ( module TestImport , module X @@ -11,11 +6,10 @@ module TestImport import Application (makeFoundation, makeLogWare) import ClassyPrelude as X hiding (delete, deleteBy, Handler) import Database.Persist as X hiding (get) -import Database.Persist.Sql (SqlPersistM, SqlBackend, runSqlPersistMPool, rawExecute, rawSql, unSingle, connEscapeName) +import Database.Persist.Sql (SqlPersistM, runSqlPersistMPool, rawExecute, unSingle, connEscapeName, sqlQQ) import Foundation as X import Model as X import Test.Hspec as X -import Text.Shakespeare.Text (st) import Yesod.Default.Config2 (useEnv, loadYamlSettings) import Yesod.Auth as X import Yesod.Test as X @@ -23,8 +17,12 @@ import Yesod.Core.Unsafe (fakeHandlerGetLogger) import Test.QuickCheck as X import Test.QuickCheck.Gen as X import Data.Default as X -import Test.QuickCheck.Instances as X +import Test.QuickCheck.Instances as X () +import System.IO as X (hPrint, hPutStrLn, stderr) +import Jobs (handleJobs, stopJobCtl) +import Control.Monad.Trans.Resource (runResourceT, MonadResourceBase) +import Data.Pool (destroyAllResources) import Settings @@ -34,60 +32,63 @@ import qualified Data.CaseInsensitive as CI runDB :: SqlPersistM a -> YesodExample UniWorX a runDB query = do - app <- getTestYesod - liftIO $ runDBWithApp app query + app <- getTestYesod + liftIO $ runDBWithApp app query -runDBWithApp :: UniWorX -> SqlPersistM a -> IO a -runDBWithApp app query = runSqlPersistMPool query (appConnPool app) +runDBWithApp :: MonadIO m => UniWorX -> SqlPersistM a -> m a +runDBWithApp app query = liftIO $ runSqlPersistMPool query (appConnPool app) runHandler :: Handler a -> YesodExample UniWorX a runHandler handler = do - app <- getTestYesod - fakeHandlerGetLogger appLogger app handler + app <- getTestYesod + fakeHandlerGetLogger appLogger app handler -withApp :: SpecWith (TestApp UniWorX) -> Spec -withApp = before $ do - settings <- loadYamlSettings - ["config/test-settings.yml", "config/settings.yml"] - [] - useEnv - foundation <- makeFoundation settings - wipeDB foundation - logWare <- liftIO $ makeLogWare foundation - return (foundation, logWare) +withApp :: YSpec UniWorX -> Spec +withApp = around $ \act -> runResourceT $ do + settings <- liftIO $ loadYamlSettings + ["config/test-settings.yml", "config/settings.yml"] + [] + useEnv + foundation <- makeFoundation settings + let + stopDBAccess = do + stopJobCtl foundation + liftIO . destroyAllResources $ appConnPool foundation + bracket_ stopDBAccess (handleJobs foundation) $ wipeDB foundation + logWare <- makeLogWare foundation + lift $ act (foundation, logWare) -- This function will truncate all of the tables in your database. -- 'withApp' calls it before each test, creating a clean environment for each -- spec to run in. -wipeDB :: UniWorX -> IO () +wipeDB :: (MonadResourceBase m, MonadMask m) => UniWorX -> m () wipeDB app = runDBWithApp app $ do - tables <- getTables - sqlBackend <- ask + tables <- map unSingle <$> [sqlQQ|SELECT table_name FROM information_schema.tables WHERE table_schema = 'public'|] + sqlBackend <- ask - let escapedTables = map (connEscapeName sqlBackend . DBName) tables - query = "TRUNCATE TABLE " ++ intercalate ", " escapedTables - rawExecute query [] - -getTables :: MonadIO m => ReaderT SqlBackend m [Text] -getTables = do - tables <- rawSql [st| - SELECT table_name - FROM information_schema.tables - WHERE table_schema = 'public'; - |] [] - - return $ map unSingle tables + let escapedTables = map (connEscapeName sqlBackend . DBName) $ filter (not . (`elem` protected)) tables + query = "TRUNCATE TABLE " ++ intercalate ", " escapedTables ++ " RESTART IDENTITY" + protected = ["applied_migration"] + rawExecute query [] -- | Authenticate as a user. This relies on the `auth-dummy-login: true` flag -- being set in test-settings.yaml, which enables dummy authentication in -- Foundation.hs +-- +-- FIXME authenticateAs :: Entity User -> YesodExample UniWorX () authenticateAs (Entity _ User{..}) = do - request $ do - setMethod "POST" - addPostParam "ident" $ CI.original userIdent - setUrl $ AuthR $ PluginR "dummy" [] + request $ do + setMethod "GET" + addRequestHeader ("Accept-Language", "de") + setUrl $ AuthR LoginR + + request $ do + setMethod "POST" + addTokenFromCookie + byLabelExact "Nutzer-Kennung" $ CI.original userIdent + setUrl $ AuthR $ PluginR "dummy" [] -- | Create a user. The dummy email entry helps to confirm that foreign-key -- checking is switched off in wipeDB for those database backends which need it. @@ -106,4 +107,6 @@ createUser userIdent = do userDateFormat = userDefaultDateFormat userTimeFormat = userDefaultTimeFormat userDownloadFiles = userDefaultDownloadFiles + userMailLanguages = def + userNotificationSettings = def runDB $ insertEntity User{..} From 73a00e5731af44375a3b3c21f5fcaa070c2b67fd Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 1 Nov 2018 17:44:12 +0100 Subject: [PATCH 2/8] Get yesod test working --- models | 2 +- templates/widgets/campus-login-form.hamlet | 2 +- templates/widgets/dummy-login-form.hamlet | 2 +- templates/widgets/hash-login-form.hamlet | 2 +- test/Handler/ProfileSpec.hs | 46 ++++++++++++++++------ test/Handler/Utils/ZipSpec.hs | 3 +- test/Model/TypesSpec.hs | 7 ++-- test/TestImport.hs | 4 +- 8 files changed, 45 insertions(+), 23 deletions(-) diff --git a/models b/models index d682b5020..32dba863f 100644 --- a/models +++ b/models @@ -139,7 +139,7 @@ File title FilePath content ByteString Maybe -- Nothing iff this is a directory modified UTCTime - deriving Show Eq + deriving Show Eq Generic Submission sheet SheetId ratingPoints Points Maybe -- "Just" does not mean done diff --git a/templates/widgets/campus-login-form.hamlet b/templates/widgets/campus-login-form.hamlet index 634991289..fee3691a2 100644 --- a/templates/widgets/campus-login-form.hamlet +++ b/templates/widgets/campus-login-form.hamlet @@ -1,2 +1,2 @@ -
+ ^{login} diff --git a/templates/widgets/dummy-login-form.hamlet b/templates/widgets/dummy-login-form.hamlet index f44f82d91..c1c11574d 100644 --- a/templates/widgets/dummy-login-form.hamlet +++ b/templates/widgets/dummy-login-form.hamlet @@ -1,2 +1,2 @@ - + ^{login} diff --git a/templates/widgets/hash-login-form.hamlet b/templates/widgets/hash-login-form.hamlet index 203a02f2e..d097216bd 100644 --- a/templates/widgets/hash-login-form.hamlet +++ b/templates/widgets/hash-login-form.hamlet @@ -1,2 +1,2 @@ - + ^{login} diff --git a/test/Handler/ProfileSpec.hs b/test/Handler/ProfileSpec.hs index b14e59868..aaf7a0da5 100644 --- a/test/Handler/ProfileSpec.hs +++ b/test/Handler/ProfileSpec.hs @@ -4,20 +4,42 @@ module Handler.ProfileSpec (spec) where import TestImport +import qualified Data.CaseInsensitive as CI + +import Yesod.Core.Handler (toTextUrl) +import Yesod.Core.Unsafe (fakeHandlerGetLogger) + spec :: Spec spec = withApp $ do + describe "Profile page" $ do + it "asserts no access to my-account for anonymous users" $ do + get ProfileR - describe "Profile page" $ do - it "asserts no access to my-account for anonymous users" $ do - get ProfileR - loc <- getLocation - assertEq "Redirect is to Login" loc - either (fail . unpack) (\_ -> return ()) =<< followRedirect - statusIs 200 + app <- getTestYesod + loginText <- fakeHandlerGetLogger appLogger app (toTextUrl $ AuthR LoginR) - it "asserts access to my-account for authenticated users" $ do - userEntity <- createUser "foo" - authenticateAs userEntity + assertHeader "Location" $ encodeUtf8 loginText + + either (fail . unpack) (\_ -> return ()) =<< followRedirect + statusIs 200 - get ProfileR - statusIs 200 + it "asserts access to my-account for authenticated users" $ do + userEntity <- createUser "foo" + authenticateAs userEntity + + get ProfileR + statusIs 200 + + it "displays basic user data" $ do + userEntity@(Entity _userId User{..}) <- createUser "foo" + authenticateAs userEntity + + get ProfileDataR + statusIs 200 + + forM_ (words userDisplayName) $ \nameWord -> do + htmlAnyContain ".profile dd" $ unpack nameWord + htmlAnyContain ".profile dd" $ unpack userSurname + htmlAnyContain ".profile dd" . unpack $ CI.original userIdent + htmlAnyContain ".profile dd" . unpack $ CI.original userEmail + diff --git a/test/Handler/Utils/ZipSpec.hs b/test/Handler/Utils/ZipSpec.hs index b384143fd..eca7d9c6a 100644 --- a/test/Handler/Utils/ZipSpec.hs +++ b/test/Handler/Utils/ZipSpec.hs @@ -23,6 +23,7 @@ instance Arbitrary File where fileModified <- addUTCTime <$> arbitrary <*> pure (UTCTime date 0) fileContent <- arbitrary return File{..} + shrink = genericShrink spec :: Spec spec = describe "Zip file handling" $ do @@ -31,7 +32,7 @@ spec = describe "Zip file handling" $ do zipFiles' <- runConduit $ Conduit.sourceList zipFiles =$= produceZip def =$= void consumeZip =$= Conduit.consume forM_ (zipFiles `zip` zipFiles') $ \(file, file') -> do let acceptableFilenameChanges - = makeValid . bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator (isNothing $ fileContent file) . normalise . makeValid + = makeValid . dropWhile isPathSeparator . bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator (isNothing $ fileContent file) . normalise . makeValid acceptableTimeDifference t1 t2 = abs (diffUTCTime t1 t2) <= 2 (shouldBe `on` acceptableFilenameChanges) (fileTitle file') (fileTitle file) when (inZipRange $ fileModified file) $ diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 87302d3c7..568412251 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -14,7 +14,7 @@ instance Arbitrary Season where instance Arbitrary TermIdentifier where arbitrary = do season <- arbitrary - year <- arbitrary + year <- arbitrary `suchThat` (\y -> abs y >= 100) return $ TermIdentifier{..} shrink = genericShrink @@ -24,8 +24,9 @@ spec = do it "has compatible encoding/decoding to/from Text" . property $ \term -> termFromText (termToText term) == Right term it "works for some examples" . mapM_ termExample $ - [ (TermIdentifier 2017 Summer, "S2017") - , (TermIdentifier 1995 Winter, "W1995") + [ (TermIdentifier 2017 Summer, "S17") + , (TermIdentifier 1995 Winter, "W95") + , (TermIdentifier 3068 Winter, "W3068") ] termExample :: (TermIdentifier, Text) -> Expectation diff --git a/test/TestImport.hs b/test/TestImport.hs index 32b83ad33..35464d9ce 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -75,8 +75,6 @@ wipeDB app = runDBWithApp app $ do -- | Authenticate as a user. This relies on the `auth-dummy-login: true` flag -- being set in test-settings.yaml, which enables dummy authentication in -- Foundation.hs --- --- FIXME authenticateAs :: Entity User -> YesodExample UniWorX () authenticateAs (Entity _ User{..}) = do request $ do @@ -86,7 +84,7 @@ authenticateAs (Entity _ User{..}) = do request $ do setMethod "POST" - addTokenFromCookie + addToken_ "#login--dummy" byLabelExact "Nutzer-Kennung" $ CI.original userIdent setUrl $ AuthR $ PluginR "dummy" [] From 9ccc2e3149939c11ce47dcc04586c7e15556edfa Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 1 Nov 2018 22:06:00 +0100 Subject: [PATCH 3/8] Fix warnings --- package.yaml | 39 ++++-- routes | 6 +- src/Cron.hs | 111 +++++++++--------- src/Foundation.hs | 76 ++++++------ src/Handler/Corrections.hs | 70 +++++------ src/Handler/Course.hs | 56 +++++---- src/Handler/Home.hs | 1 - src/Handler/School.hs | 32 +---- src/Handler/Sheet.hs | 56 ++++----- src/Handler/Submission.hs | 17 ++- src/Handler/SystemMessage.hs | 39 +++--- src/Handler/Term.hs | 6 +- src/Handler/Utils/DateTime.hs | 2 - src/Handler/Utils/Form.hs | 12 +- src/Handler/Utils/Mail.hs | 2 +- src/Handler/Utils/Rating.hs | 8 +- src/Handler/Utils/Submission.hs | 45 +++---- src/Handler/Utils/Table/Pagination.hs | 44 +++---- src/Handler/Utils/Templates.hs | 4 +- src/Jobs.hs | 11 +- src/Jobs/Handler/HelpRequest.hs | 2 +- .../SendNotification/CorrectionsAssigned.hs | 7 +- .../Handler/SendNotification/SheetActive.hs | 3 +- .../Handler/SendNotification/SheetInactive.hs | 3 +- .../SendNotification/SubmissionRated.hs | 2 + src/Jobs/Queue.hs | 1 - src/Mail.hs | 26 ++-- src/Model.hs | 2 +- src/Model/Migration/Types.hs | 8 +- src/Model/Types/JSON.hs | 10 +- src/Utils/Lens.hs | 2 +- templates/correction-user.hamlet | 2 +- templates/default-layout.hamlet | 2 +- templates/login.hamlet | 2 +- templates/mail/submissionRated.hamlet | 2 +- templates/mail/support.hamlet | 2 +- .../messages/submissionFilesIgnored.hamlet | 2 +- templates/widgets/asidenav.hamlet | 14 +-- templates/widgets/rating.hamlet | 2 +- 39 files changed, 331 insertions(+), 400 deletions(-) diff --git a/package.yaml b/package.yaml index 820a16e46..0820ca9d3 100644 --- a/package.yaml +++ b/package.yaml @@ -156,24 +156,35 @@ default-extensions: - BinaryLiterals - PolyKinds -ghc-options: - - -Wall - - -fwarn-tabs +when: + - condition: flag(pedantic) + then: + ghc-options: + - -Wall + - -Werror + - -fwarn-tabs + - -fno-warn-type-defaults + - -fno-warn-partial-type-signatures + else: + ghc-options: + - -Wall + - -fno-warn-type-defaults + - -fno-warn-partial-type-signatures # The library contains all of our application code. The executable # defined below is just a thin wrapper. library: source-dirs: src when: - - condition: (flag(dev)) || (flag(library-only)) - then: - ghc-options: - - -O0 - - -ddump-splices - cpp-options: -DDEVELOPMENT - else: - ghc-options: - - -O2 + - condition: (flag(dev)) || (flag(library-only)) + then: + ghc-options: + - -O0 + - -ddump-splices + cpp-options: -DDEVELOPMENT + else: + ghc-options: + - -O2 # Runnable executable for our application executables: @@ -219,3 +230,7 @@ flags: description: Turn on development settings, like auto-reload templates. manual: false default: false + pedantic: + description: Be very pedantic about warnings and errors + manual: true + default: true diff --git a/routes b/routes index 17a653125..f953da2e5 100644 --- a/routes +++ b/routes @@ -50,8 +50,8 @@ !/term/#TermId TermCourseListR GET !free !/term/#TermId/#SchoolId TermSchoolCourseListR GET !free -/school SchoolListR GET -/school/#SchoolId SchoolShowR GET +/school SchoolListR GET !development +/school/#SchoolId SchoolShowR GET !development -- For Pattern Synonyms see Foundation @@ -64,7 +64,7 @@ /edit CEditR GET POST /delete CDeleteR GET POST !lecturerANDempty /users CUsersR GET - /user/#CryptoUUIDUser CUserR GET + /user/#CryptoUUIDUser CUserR GET !development /correctors CHiWisR GET /subs CCorrectionsR GET POST /ex SheetListR GET !registered !materials diff --git a/src/Cron.hs b/src/Cron.hs index cb2d9a338..600eb873c 100644 --- a/src/Cron.hs +++ b/src/Cron.hs @@ -1,5 +1,6 @@ module Cron - ( CronNextMatch(..) + ( evalCronMatch + , CronNextMatch(..) , nextCronMatch , module Cron.Types ) where @@ -18,11 +19,7 @@ import Data.Ratio ((%)) import qualified Data.Set as Set -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NonEmpty - -import Utils.Lens.TH -import Control.Lens +import Utils.Lens hiding (from, to) data CronDate = CronDate @@ -38,7 +35,7 @@ makeLenses_ ''CronDate evalCronMatch :: CronMatch -> Natural -> Bool evalCronMatch CronMatchAny _ = True evalCronMatch CronMatchNone _ = False -evalCronMatch (CronMatchSome set) x = Set.member x $ toNullable set +evalCronMatch (CronMatchSome xs) x = Set.member x $ toNullable xs evalCronMatch (CronMatchStep step) x = (x `mod` step) == 0 evalCronMatch (CronMatchContiguous from to) x = from <= x && x <= to evalCronMatch (CronMatchIntersect a b) x = evalCronMatch a x && evalCronMatch b x @@ -115,7 +112,7 @@ genMatch :: Int -- ^ Period -> [Natural] genMatch p m st CronMatchAny = take p $ map (bool id (succ . (`mod` fromIntegral p)) m) [st..] genMatch _ _ _ CronMatchNone = [] -genMatch p m _ (CronMatchSome set) = take p . map (bool id (succ . (`mod` fromIntegral p)) m) . Set.toAscList $ toNullable set +genMatch p m _ (CronMatchSome xs) = take p . map (bool id (succ . (`mod` fromIntegral p)) m) . Set.toAscList $ toNullable xs genMatch p m st (CronMatchStep step) = do start <- [st..st + step] guard $ (start `mod` step) == 0 @@ -135,9 +132,9 @@ genMatch p m st (CronMatchIntersect aGen bGen) mergeAnd [] _ = [] mergeAnd _ [] = [] mergeAnd (a:as) (b:bs) - | a < b = mergeAnd as (b:bs) - | a == b = a : mergeAnd as bs - | a > b = mergeAnd (a:as) bs + | a < b = mergeAnd as (b:bs) + | a == b = a : mergeAnd as bs + | otherwise = mergeAnd (a:as) bs genMatch p m st (CronMatchUnion CronMatchNone other) = genMatch p m st other genMatch p m st (CronMatchUnion other CronMatchNone) = genMatch p m st other genMatch p m st (CronMatchUnion CronMatchAny _) = genMatch p m st CronMatchAny @@ -147,9 +144,9 @@ genMatch p m st (CronMatchUnion aGen bGen) = merge (genMatch p m st aGen) (genMa merge [] bs = bs merge as [] = as merge (a:as) (b:bs) - | a < b = a : merge as (b:bs) - | a == b = a : merge as bs - | a > b = b : merge (a:as) bs + | a < b = a : merge as (b:bs) + | a == b = a : merge as bs + | otherwise = b : merge (a:as) bs nextCronMatch :: TZ -- ^ Timezone of the `Cron`-Entry -> Maybe UTCTime -- ^ Time of last execution of the job @@ -166,7 +163,6 @@ nextCronMatch tz mPrev now c@Cron{..} = case notAfter of | otherwise -> MatchNone MatchNone -> nextMatch where - nextMatch = nextCronMatch' tz mPrev now c notAfter | Right c' <- cronNotAfter , Just ref <- notAfterRef @@ -178,34 +174,34 @@ nextCronMatch tz mPrev now c@Cron{..} = case notAfter of notAfterRef | Just prevT <- mPrev = Just prevT | otherwise = case execRef' now False cronInitial of + MatchAsap -> error "execRef' should not return MatchAsap" MatchAt t -> Just t MatchNone -> Nothing - - nextCronMatch' tz mPrev now c@Cron{..} - | isNothing mPrev - = execRef now False cronInitial - | Just prevT <- mPrev - = case cronRepeat of - CronRepeatOnChange - | not $ matchesCron tz Nothing prevT c - -> let - cutoffTime = addUTCTime cronRateLimit prevT - in case execRef now False cronInitial of - MatchAsap - | now < cutoffTime -> MatchAt cutoffTime - MatchAt ts - | ts < cutoffTime -> MatchAt cutoffTime - other -> other - CronRepeatScheduled cronNext - -> case cronNext of - CronAsap - | addUTCTime cronRateLimit prevT <= now - -> MatchAsap - | otherwise - -> MatchAt $ addUTCTime cronRateLimit prevT - cronNext - -> execRef (addUTCTime cronRateLimit prevT) True cronNext - _other -> MatchNone + nextMatch = case mPrev of + Nothing + -> execRef now False cronInitial + Just prevT + -> case cronRepeat of + CronRepeatOnChange + | not $ matchesCron tz Nothing prevT c + -> let + cutoffTime = addUTCTime cronRateLimit prevT + in case execRef now False cronInitial of + MatchAsap + | now < cutoffTime -> MatchAt cutoffTime + MatchAt ts + | ts < cutoffTime -> MatchAt cutoffTime + other -> other + CronRepeatScheduled cronNext + -> case cronNext of + CronAsap + | addUTCTime cronRateLimit prevT <= now + -> MatchAsap + | otherwise + -> MatchAt $ addUTCTime cronRateLimit prevT + _other + -> execRef (addUTCTime cronRateLimit prevT) True cronNext + _other -> MatchNone execRef ref wasExecd cronAbsolute = case execRef' ref wasExecd cronAbsolute of MatchAt t @@ -219,19 +215,26 @@ nextCronMatch tz mPrev now c@Cron{..} = case notAfter of | otherwise -> MatchNone CronCalendar{..} -> listToMatch $ do let CronDate{..} = toCronDate $ utcToLocalTimeTZ tz ref - cronYear <- genMatch 400 False cdYear cronYear - cronWeekOfYear <- genMatch 53 True cdWeekOfYear cronWeekOfYear - cronDayOfYear <- genMatch 366 True cdDayOfYear cronDayOfYear - cronMonth <- genMatch 12 True cdMonth cronMonth - cronWeekOfMonth <- genMatch 5 True cdWeekOfMonth cronWeekOfMonth - cronDayOfMonth <- genMatch 31 True cdDayOfMonth cronDayOfMonth - cronDayOfWeek <- genMatch 7 True cdDayOfWeek cronDayOfWeek - cronHour <- genMatch 24 True cdHour cronHour - cronMinute <- genMatch 60 True cdMinute cronMinute - cronSecond <- genMatch 60 True cdSecond cronSecond - guard $ consistentCronDate CronDate{..} - localDay <- maybeToList $ fromGregorianValid (fromIntegral cronYear) (fromIntegral cronMonth) (fromIntegral cronDayOfMonth) - let localTimeOfDay = TimeOfDay (fromIntegral cronHour) (fromIntegral cronMinute) (fromIntegral cronSecond) + + mCronYear <- genMatch 400 False cdYear cronYear + mCronWeekOfYear <- genMatch 53 True cdWeekOfYear cronWeekOfYear + mCronDayOfYear <- genMatch 366 True cdDayOfYear cronDayOfYear + mCronMonth <- genMatch 12 True cdMonth cronMonth + mCronWeekOfMonth <- genMatch 5 True cdWeekOfMonth cronWeekOfMonth + mCronDayOfMonth <- genMatch 31 True cdDayOfMonth cronDayOfMonth + mCronDayOfWeek <- genMatch 7 True cdDayOfWeek cronDayOfWeek + mCronHour <- genMatch 24 True cdHour cronHour + mCronMinute <- genMatch 60 True cdMinute cronMinute + mCronSecond <- genMatch 60 True cdSecond cronSecond + guard $ consistentCronDate CronDate + { cdYear = mCronYear, cdMonth = mCronMonth, cdDayOfMonth = mCronDayOfMonth + , cdHour = mCronHour, cdMinute = mCronMinute, cdSecond = mCronSecond + , cdWeekOfYear = mCronWeekOfYear, cdWeekOfMonth = mCronWeekOfMonth + , cdDayOfYear = mCronDayOfYear, cdDayOfWeek = mCronDayOfWeek + } + + localDay <- maybeToList $ fromGregorianValid (fromIntegral mCronYear) (fromIntegral mCronMonth) (fromIntegral mCronDayOfMonth) + let localTimeOfDay = TimeOfDay (fromIntegral mCronHour) (fromIntegral mCronMinute) (fromIntegral mCronSecond) return $ localTimeToUTCTZ tz LocalTime{..} CronNotScheduled -> MatchNone diff --git a/src/Foundation.hs b/src/Foundation.hs index 4cb048b8d..ca40aa24a 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1,4 +1,5 @@ {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- MonadCrypto module Foundation where @@ -10,20 +11,18 @@ import Text.Jasmine (minifym) import qualified Web.ClientSession as ClientSession import Yesod.Auth.Message -import Yesod.Auth.Dummy import Auth.LDAP import Auth.PWHash import Auth.Dummy import Jobs.Types -import qualified Network.Wai as W (requestMethod, pathInfo) +import qualified Network.Wai as W (pathInfo) import Yesod.Default.Util (addStaticContentExternal) import Yesod.Core.Types (Logger) import qualified Yesod.Core.Unsafe as Unsafe import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI -import qualified Data.Text.Encoding as TE import qualified Data.CryptoID as E @@ -40,12 +39,10 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.List (foldr1) -import qualified Data.List as List import Data.Set (Set) import qualified Data.Set as Set import Data.Map (Map, (!?)) import qualified Data.Map as Map -import Data.List (findIndex) import Data.Monoid (Any(..)) @@ -61,22 +58,14 @@ import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Trans.Reader (runReader, mapReaderT) import Control.Monad.Trans.Writer (WriterT(..)) import Control.Monad.Writer.Class (MonadWriter(..)) -import Control.Monad.Catch (handleAll) import qualified Control.Monad.Catch as C -import System.FilePath - -import Handler.Utils.Templates import Handler.Utils.StudyFeatures import Control.Lens -import Utils import Utils.Form -import Utils.Lens import Utils.SystemMessage import Data.Aeson hiding (Error, Success) -import Data.Aeson.TH -import qualified Data.Yaml as Yaml import Text.Shakespeare.Text (st) @@ -147,9 +136,11 @@ type MsgRenderer = MsgRendererS UniWorX -- see Utils type MailM a = MailT (HandlerT UniWorX IO) a -- Pattern Synonyms for convenience +pattern CSheetR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetR -> Route UniWorX pattern CSheetR tid ssh csh shn ptn = CourseR tid ssh csh (SheetR shn ptn) +pattern CSubmissionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionR -> Route UniWorX pattern CSubmissionR tid ssh csh shn cid ptn = CSheetR tid ssh csh shn (SubmissionR cid ptn) @@ -212,9 +203,10 @@ instance RenderMessage UniWorX Load where newtype MsgLanguage = MsgLanguage Lang deriving (Eq, Ord, Show, Read) instance RenderMessage UniWorX MsgLanguage where - renderMessage foundation ls (MsgLanguage lang) - | lang == "de-DE" = mr MsgGermanGermany - | "de" `isPrefixOf` lang = mr MsgGerman + renderMessage foundation ls (MsgLanguage lang@(Text.splitOn "-" -> lang')) + | ["de", "DE"] <- lang' = mr MsgGermanGermany + | ("de" : _) <- lang' = mr MsgGerman + | otherwise = lang where mr = renderMessage foundation ls @@ -280,8 +272,8 @@ orAR _ _ AuthenticationRequired = AuthenticationRequired orAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedOr x y -- and andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedAnd x y -andAR _ reason@(Unauthorized x) _ = reason -andAR _ _ reason@(Unauthorized x) = reason +andAR _ reason@(Unauthorized _) _ = reason +andAR _ _ reason@(Unauthorized _) = reason andAR _ Authorized other = other andAR _ AuthenticationRequired _ = AuthenticationRequired @@ -338,6 +330,14 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req allow <- appAllowDeprecated . appSettings <$> getYesod return $ bool (Unauthorized "Deprecated Route") Authorized allow ) + ,("development", APHandler $ \r _ -> do + $logWarnS "AccessControl" ("route in development: " <> tshow r) +#ifdef DEVELOPMENT + return Authorized +#else + return $ Unauthorized "Route under development" +#endif + ) ,("lecturer", APDB $ \route _ -> case route of CourseR tid ssh csh _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId @@ -406,7 +406,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req return Authorized CourseR tid ssh csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do - Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh + Entity _ Course{courseRegisterFrom, courseRegisterTo} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh cTime <- (NTop . Just) <$> liftIO getCurrentTime guard $ NTop courseRegisterFrom <= cTime && NTop courseRegisterTo >= cTime @@ -414,7 +414,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do smId <- decrypt cID - SystemMessage{..} <- MaybeT $ get smId + SystemMessage{systemMessageFrom, systemMessageTo} <- MaybeT $ get smId cTime <- (NTop . Just) <$> liftIO getCurrentTime guard $ NTop systemMessageFrom <= cTime && NTop systemMessageTo >= cTime @@ -617,14 +617,14 @@ instance Yesod UniWorX where errPage = case err of NotFound -> [whamlet|

_{MsgErrorResponseNotFound}|] - InternalError err -> encrypted err [whamlet|

#{err}|] + InternalError err' -> encrypted err' [whamlet|

#{err'}|] InvalidArgs errs -> [whamlet|