From bc675006d8c72a2994be832236036447ebe1efc1 Mon Sep 17 00:00:00 2001 From: Felix Hamann Date: Sun, 21 Jul 2019 00:18:49 +0200 Subject: [PATCH 01/77] feat(alert-icons): add custom icons for alerts --- frontend/src/utils/alerts/alert-icons.js | 16 ++++++++++++++++ frontend/src/utils/alerts/alerts.js | 14 ++++++++++++++ frontend/src/utils/alerts/alerts.scss | 8 ++++---- templates/widgets/alerts/alerts.hamlet | 5 +++++ 4 files changed, 39 insertions(+), 4 deletions(-) create mode 100644 frontend/src/utils/alerts/alert-icons.js diff --git a/frontend/src/utils/alerts/alert-icons.js b/frontend/src/utils/alerts/alert-icons.js new file mode 100644 index 000000000..85fe1d3aa --- /dev/null +++ b/frontend/src/utils/alerts/alert-icons.js @@ -0,0 +1,16 @@ +// +// Fontawesome icons to be used on alerts. +// +// If you want to add new icons stick to the format of the existing ones. +// They are necessary due to weird unicode conversions during transpilation. +// https://fontawesome.com/icons + +export const ALERT_ICONS = { + info: '"\\f05a"', + checkmark: '"\\f058"', + exclamation: '"\\f06a"', + warning: '"\\f071"', + cross: '"\\f00d"', + registered: '"\\f274"', + deregistered: '"\\f273"', +}; diff --git a/frontend/src/utils/alerts/alerts.js b/frontend/src/utils/alerts/alerts.js index e7e04ddbb..4d1a1cf7a 100644 --- a/frontend/src/utils/alerts/alerts.js +++ b/frontend/src/utils/alerts/alerts.js @@ -1,5 +1,6 @@ import { Utility } from '../../core/utility'; import './alerts.scss'; +import { ALERT_ICONS } from './alert-icons'; const ALERTS_INITIALIZED_CLASS = 'alerts--initialized'; const ALERTS_ELEVATED_CLASS = 'alerts--elevated'; @@ -16,6 +17,12 @@ const ALERT_INVISIBLE_CLASS = 'alert--invisible'; const ALERT_AUTO_HIDE_DELAY = 10; const ALERT_AUTOCLOSING_MATCHER = '.alert-info, .alert-success'; +/* + * Dataset-Inputs: + * - decay (data-decay): Custom time (in seconds) for this alert to stay visible + * - icon (data-icon): Custom icon (from the list in alert-icons.js) to show on the alert + */ + @Utility({ selector: '[uw-alerts]', }) @@ -87,6 +94,13 @@ export class Alerts { this._toggleAlert(alertElement); }); + const customIcon = alertElement.dataset.icon; + if (customIcon && ALERT_ICONS[customIcon]) { + alertElement.style.setProperty('--alert-icon', ALERT_ICONS[customIcon]); + } else if (customIcon) { + throw new Error('Alert: Custom icon "' + customIcon + '" could not be found!'); + } + if (autoHideDelay > 0 && alertElement.matches(ALERT_AUTOCLOSING_MATCHER)) { window.setTimeout(() => this._toggleAlert(alertElement), autoHideDelay * 1000); } diff --git a/frontend/src/utils/alerts/alerts.scss b/frontend/src/utils/alerts/alerts.scss index d2faf1b22..8beff3b70 100644 --- a/frontend/src/utils/alerts/alerts.scss +++ b/frontend/src/utils/alerts/alerts.scss @@ -124,7 +124,7 @@ z-index: 40; &::before { - content: '\f05a'; + content: var(--alert-icon, var(--alert-icon-default, '\f05a')); position: absolute; font-family: 'Font Awesome 5 Free'; font-size: 24px; @@ -189,7 +189,7 @@ background-color: var(--color-success); .alert__icon::before { - content: '\f058'; + --alert-icon-default: '\f058'; } } @@ -197,7 +197,7 @@ background-color: var(--color-warning); .alert__icon::before { - content: '\f06a'; + --alert-icon-default: '\f06a'; } } @@ -205,6 +205,6 @@ background-color: var(--color-error); .alert__icon::before { - content: '\f071'; + --alert-icon-default: '\f071'; } } diff --git a/templates/widgets/alerts/alerts.hamlet b/templates/widgets/alerts/alerts.hamlet index 4527e62d3..8ddc0f6cd 100644 --- a/templates/widgets/alerts/alerts.hamlet +++ b/templates/widgets/alerts/alerts.hamlet @@ -3,6 +3,11 @@ $newline never
$forall (status, msg) <- mmsgs $with status2 <- bool status "info" (status == "") +
From 20686f185b49b790481876b4efae74148dc579c3 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 24 Jul 2019 08:21:31 +0200 Subject: [PATCH 02/77] refactor(jobs): switch to linked asyncs --- src/Application.hs | 9 +- .../Concurrent/Async/Lifted/Safe/Utils.hs | 15 + src/Foundation.hs | 3 +- src/Import/NoModel.hs | 2 +- src/Jobs.hs | 392 +++++++++++------- src/Jobs/Queue.hs | 4 +- src/Jobs/Types.hs | 28 +- src/Utils.hs | 1 + 8 files changed, 281 insertions(+), 173 deletions(-) create mode 100644 src/Control/Concurrent/Async/Lifted/Safe/Utils.hs diff --git a/src/Application.hs b/src/Application.hs index 3e20e6613..6e2d45fd7 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -38,8 +38,6 @@ import System.Log.FastLogger ( defaultBufSize, newStderrLoggerSet import Handler.Utils (runAppLoggingT) -import qualified Data.Map.Strict as Map - import Foreign.Store import qualified Data.UUID as UUID @@ -158,8 +156,7 @@ makeFoundation appSettings'@AppSettings{..} = do appInstanceID <- liftIO $ maybe UUID.nextRandom (either readInstanceIDFile return) appInitialInstanceID - appJobCtl <- liftIO $ newTVarIO Map.empty - appCronThread <- liftIO newEmptyTMVarIO + appJobState <- liftIO newEmptyTMVarIO appHealthReport <- liftIO $ newTVarIO Set.empty -- We need a log function to create a connection pool. We need a connection @@ -371,7 +368,7 @@ develMain = runResourceT $ do wsettings <- liftIO . getDevSettings $ warpSettings foundation app <- makeApplication foundation - handleJobs foundation + runAppLoggingT foundation $ handleJobs foundation liftIO . develMainHelper $ return (wsettings, app) -- | The @main@ function for an executable running this site. @@ -471,7 +468,7 @@ getApplicationRepl :: (MonadResource m, MonadBaseControl IO m) => m (Int, UniWor getApplicationRepl = do settings <- getAppDevSettings foundation <- makeFoundation settings - handleJobs foundation + runAppLoggingT foundation $ handleJobs foundation wsettings <- liftIO . getDevSettings $ warpSettings foundation app1 <- makeApplication foundation diff --git a/src/Control/Concurrent/Async/Lifted/Safe/Utils.hs b/src/Control/Concurrent/Async/Lifted/Safe/Utils.hs new file mode 100644 index 000000000..f7f395b64 --- /dev/null +++ b/src/Control/Concurrent/Async/Lifted/Safe/Utils.hs @@ -0,0 +1,15 @@ +module Control.Concurrent.Async.Lifted.Safe.Utils + ( allocateLinkedAsync + ) where + +import ClassyPrelude hiding (cancel) + +import Control.Concurrent.Async.Lifted.Safe + +import Control.Monad.Trans.Resource + + +allocateLinkedAsync :: forall m a. + MonadResource m + => IO a -> m (Async a) +allocateLinkedAsync act = allocate (async act) cancel >>= (\(_k, a) -> a <$ link a) diff --git a/src/Foundation.hs b/src/Foundation.hs index 8103ebfda..855f5c4a0 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -110,8 +110,7 @@ data UniWorX = UniWorX , appCryptoIDKey :: CryptoIDKey , appClusterID :: ClusterId , appInstanceID :: InstanceId - , appJobCtl :: TVar (Map ThreadId (TMChan JobCtl)) - , appCronThread :: TMVar (ReleaseKey, ThreadId) + , appJobState :: TMVar JobState , appSessionKey :: ClientSession.Key , appSecretBoxKey :: SecretBox.Key , appJSONWebKeySet :: Jose.JwkSet diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index cd1bd66c2..0c437f9e9 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -44,7 +44,7 @@ import Data.Hashable as Import import Data.List.NonEmpty as Import (NonEmpty(..), nonEmpty) import Data.Text.Encoding.Error as Import(UnicodeException(..)) import Data.Semigroup as Import (Semigroup) -import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..)) +import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..), Endo(..)) import Data.Binary as Import (Binary) import Numeric.Natural as Import (Natural) diff --git a/src/Jobs.hs b/src/Jobs.hs index 867718bab..3da01ebee 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -7,14 +7,12 @@ module Jobs import Import import Utils.Lens -import Handler.Utils import Jobs.Types as Types hiding (JobCtl(JobCtlQueue)) import Jobs.Types (JobCtl(JobCtlQueue)) import Jobs.Queue import Jobs.Crontab -import Data.Conduit.TMChan import qualified Data.Conduit.List as C import qualified Data.Text.Lazy as LT @@ -28,7 +26,7 @@ import Data.Semigroup (Max(..)) import Utils.Sql -import Control.Monad.Random (evalRand, mkStdGen, getRandomR) +import Control.Monad.Random (evalRand, mkStdGen, getRandomR, uniformMay) import Cron import qualified Data.HashMap.Strict as HashMap @@ -38,20 +36,26 @@ import qualified Data.Set as Set import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map.Strict as Map +import Data.Map.Strict ((!)) import Data.Foldable (foldrM) import Control.Monad.Trans.Reader (mapReaderT) -import Control.Monad.Trans.State (evalStateT, mapStateT) +import Control.Monad.Trans.Writer (execWriterT) +import Control.Monad.Trans.RWS.Lazy (RWST, mapRWST, evalRWST) import qualified Control.Monad.State.Class as State +import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Reader.Class (MonadReader(..)) -import Control.Monad.Trans.Resource (MonadResourceBase, runResourceT, allocate, release) +import Control.Monad.Trans.Resource (MonadResourceBase, runResourceT) import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Monad.Trans.Cont (ContT(..), callCC) +import Control.Monad.Random.Lazy (evalRandTIO, mapRandT) import Control.Monad.Logger import Data.Time.Zones import Control.Concurrent.STM (retry) +import Control.Concurrent.STM.Delay import Jobs.Handler.SendNotification @@ -75,191 +79,259 @@ instance Exception JobQueueException handleJobs :: ( MonadResource m - , MonadIO m + , MonadLoggerIO 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 foundation@UniWorX{..} = do - let num = foundation ^. _appJobWorkers +handleJobs foundation@UniWorX{..} + | foundation ^. _appJobWorkers == 0 = return () + | otherwise = do + logger <- askLoggerIO + let runInIO = flip runLoggingT logger . runResourceT - jobCrontab <- liftIO $ newTMVarIO HashMap.empty - jobConfirm <- liftIO $ newTVarIO HashMap.empty + jobPoolManager <- allocateLinkedAsync . runInIO $ manageJobPool foundation - 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" - removeChan = atomically . modifyTVar' appJobCtl . Map.delete =<< myThreadId - doFork = flip forkFinally (\_ -> removeChan) . runAppLoggingT foundation . bracket_ logStart logStop . flip runReaderT JobContext{..} . runConduit $ sourceTMChan chan .| handleJobs' foundation n - (_, tId) <- allocate (liftIO doFork) (\_ -> liftIO . atomically $ closeTMChan chan) - atomically . modifyTVar' appJobCtl $ Map.insert tId bChan + jobCron <- allocateLinkedAsync . runInIO $ manageCrontab foundation - -- Start cron operation - when (num > 0) $ do - registeredCron <- liftIO newEmptyTMVarIO - let execCrontab' = whenM (atomically $ readTMVar registeredCron) $ - runReaderT (execCrontab foundation) 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 + let jobWorkers = Map.empty + jobWorkerName = const $ error "Unknown worker" + jobCrontab <- liftIO $ newTVarIO HashMap.empty + jobConfirm <- liftIO $ newTVarIO HashMap.empty + jobShutdown <- liftIO newEmptyTMVarIO + atomically $ putTMVar appJobState JobState + { jobContext = JobContext{..} + , .. + } + +manageJobPool, manageCrontab :: forall m. + ( MonadResource m + , MonadLogger m + ) + => UniWorX -> m () +manageCrontab foundation@UniWorX{..} = do + context <- atomically . fmap jobContext $ readTMVar appJobState + liftIO . unsafeHandler foundation . void $ do + runReaderT ?? context $ + writeJobCtlBlock JobCtlDetermineCrontab + evalRWST execCrontab' context HashMap.empty + where + execCrontab' = do + shouldTerminate <- atomically $ readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown + if + | shouldTerminate -> return () + | otherwise -> execCrontab *> execCrontab' + + +manageJobPool foundation@UniWorX{..} + = flip runContT return . forever . join . atomically $ asum + [ spawnMissingWorkers + , reapDeadWorkers + , terminateGracefully + ] + where + num :: Int + num = fromIntegral $ foundation ^. _appJobWorkers + + spawnMissingWorkers, reapDeadWorkers, terminateGracefully :: STM (ContT () m ()) + spawnMissingWorkers = do + oldState <- takeTMVar appJobState + let missing = num - Map.size (jobWorkers oldState) + guard $ missing > 0 + return $ do + $logDebugS "manageJobPool" [st|Spawning #{missing} workers|] + endo <- execWriterT . replicateM_ missing $ do + workerId <- newWorkerId + let logIdent = mkLogIdent workerId + (bChan, chan) <- atomically $ newBroadcastTChan >>= (\c -> (c, ) <$> dupTChan c) + let + streamChan = join . atomically $ do + shouldTerminate <- readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown + if + | shouldTerminate -> + return $ return () + | otherwise -> do + nextVal <- readTChan chan + return $ yield nextVal >> streamChan + runWorker = unsafeHandler foundation . flip runReaderT (jobContext oldState) $ do + $logInfoS logIdent "Started" + runConduit $ streamChan .| handleJobs' workerId + worker <- allocateLinkedAsync runWorker + + tell . Endo $ \cSt -> cSt + { jobWorkers = Map.insert worker bChan $ jobWorkers cSt + , jobWorkerName = \a -> bool (jobWorkerName cSt a) workerId $ a == worker + } + atomically . putTMVar appJobState $ endo `appEndo` oldState + + reapDeadWorkers = do + oldState <- takeTMVar appJobState + deadWorkers <- fmap (Map.fromList . catMaybes) . forM (Map.keys $ jobWorkers oldState) $ \a -> fmap (a,) <$> pollSTM a + putTMVar appJobState oldState + { jobWorkers = jobWorkers oldState `Map.withoutKeys` Map.keysSet deadWorkers + } + guard . not $ Map.null deadWorkers + return . forM_ (Map.toList deadWorkers) $ \(jobAsync, result) -> do + case result of + Right () -> $logInfoS "JobPoolManager" [st|Job-Executor #{showWorkerId (jobWorkerName oldState jobAsync)} terminated|] + Left e -> $logErrorS "JobPoolManager" [st|Job-Executer #{showWorkerId (jobWorkerName oldState jobAsync)} crashed: #{tshow e}|] + void . lift . allocateLinkedAsync $ + let go = do + next <- evalRandTIO . mapRandT (liftIO . atomically) . runMaybeT $ do + nextVal <- MaybeT . lift . tryReadTChan $ jobWorkers oldState ! jobAsync + jobWorkers' <- lift . lift $ jobWorkers <$> readTMVar appJobState + receiver <- maybe (lift $ lift retry) return =<< uniformMay jobWorkers' + return (nextVal, receiver) + whenIsJust next $ \(nextVal, receiver) -> do + atomically $ writeTChan receiver nextVal + go + in go + + terminateGracefully = do + shouldTerminate <- readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown + guard shouldTerminate + return . callCC $ \terminate -> do + $logInfoS "JobPoolManager" "Shutting down" + terminate () 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 +stopJobCtl UniWorX{appJobState} = do atomically $ do - wMap' <- readTVar appJobCtl - guard . none (`Map.member` wMap') $ Map.keysSet wMap + JobState{..} <- readTMVar appJobState + putTMVar jobShutdown () + atomically $ do + JobState{..} <- takeTMVar appJobState + mapM_ (void . waitCatchSTM) $ + [ jobPoolManager + , jobCron + ] ++ Map.keys jobWorkers - -execCrontab :: MonadIO m => UniWorX -> ReaderT JobContext m () +execCrontab :: RWST JobContext () (HashMap JobCtl (Max UTCTime)) (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 foundation = evalStateT go HashMap.empty - where - go = do - cont <- mapStateT (mapReaderT $ liftIO . unsafeHandler foundation) $ 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 +execCrontab = do + mapRWST (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 - refT <- liftIO getCurrentTime - settings <- getsYesod appSettings' - 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 settings prevExec crontab refT of - Nothing -> liftBase retry - Just (_, MatchNone) -> liftBase retry - Just x -> return (crontab, x) + refT <- liftIO getCurrentTime + settings <- getsYesod appSettings' + (currentCrontab, (jobCtl, nextMatch)) <- mapRWST (liftIO . atomically) $ do + crontab <- liftBase . readTVar =<< asks jobCrontab - case currentState of - Nothing -> return False - 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 - void . 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 + State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab + prevExec <- State.get + case earliestJob settings prevExec crontab refT of + Nothing -> liftBase retry + Just (_, MatchNone) -> liftBase retry + Just x -> return (crontab, x) - 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 - - return True - when cont go - where - acc :: NominalDiffTime - acc = 1e-3 - - debouncingAcc :: AppSettings -> JobCtl -> NominalDiffTime - debouncingAcc AppSettings{appNotificationRateLimit} = \case - JobCtlQueue (JobQueueNotification _) -> appNotificationRateLimit - _ -> acc - - 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 :: AppSettings -> HashMap JobCtl (Max UTCTime) -> Crontab JobCtl -> UTCTime -> Maybe (JobCtl, CronNextMatch UTCTime) - earliestJob settings lastTimes crontab now = foldr go' Nothing $ HashMap.toList crontab - where - go' (jobCtl, cron) mbPrev - | Just (_, t') <- mbPrev - , t' < t - = mbPrev - | otherwise - = Just (jobCtl, t) - where - t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) (debouncingAcc settings jobCtl) now cron - - 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'})|] + let doJob = mapRWST (liftHandlerT . runDBJobs . setSerializable) $ do + newCrontab <- lift . hoist lift $ determineCrontab' 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 + | ((==) `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 + void . lift $ upsertBy + (UniqueCronLastExec $ toJSON job) + CronLastExec + { cronLastExecJob = toJSON job + , cronLastExecTime = now + , cronLastExecInstance = instanceID' + } + [ CronLastExecTime =. now ] + lift $ queueDBJob job + other -> writeJobCtl other + | otherwise + -> mapRWST (liftIO . atomically) $ + liftBase . void . flip swapTVar 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 + where + acc :: NominalDiffTime + acc = 1e-3 -handleJobs' :: (MonadIO m, MonadLogger m, MonadCatch m) => UniWorX -> Natural -> Sink JobCtl (ReaderT JobContext m) () -handleJobs' foundation wNum = C.mapM_ $ \jctl -> do + debouncingAcc :: AppSettings -> JobCtl -> NominalDiffTime + debouncingAcc AppSettings{appNotificationRateLimit} = \case + JobCtlQueue (JobQueueNotification _) -> appNotificationRateLimit + _ -> acc + + 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 :: AppSettings -> HashMap JobCtl (Max UTCTime) -> Crontab JobCtl -> UTCTime -> Maybe (JobCtl, CronNextMatch UTCTime) + earliestJob settings lastTimes crontab now = foldr go' Nothing $ HashMap.toList crontab + where + go' (jobCtl, cron) mbPrev + | Just (_, t') <- mbPrev + , t' < t + = mbPrev + | otherwise + = Just (jobCtl, t) + where + t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) (debouncingAcc settings jobCtl) 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 + delay <- liftIO . newDelay . round $ waitTime * 1e6 + let + awaitDelayThread = False <$ waitDelay delay + awaitCrontabChange = do + crontab' <- readTVar crontabTV + True <$ guard (crontab /= crontab') + crontabChanged <- liftIO . atomically $ awaitCrontabChange <|> awaitDelayThread + bool (waitUntil crontabTV crontab nextTime) (return False) crontabChanged + +mkLogIdent :: JobWorkerId -> Text +mkLogIdent wId = "Job-Executor " <> showWorkerId wId + +handleJobs' :: JobWorkerId -> Sink JobCtl (ReaderT JobContext Handler) () +handleJobs' wNum = C.mapM_ $ \jctl -> do $logDebugS logIdent $ tshow jctl resVars <- mapReaderT (liftIO . atomically) $ HashMap.lookup jctl <$> (lift . readTVar =<< asks jobConfirm) - res <- fmap (either Just $ const Nothing) . try . (mapReaderT $ liftIO . unsafeHandler foundation) $ handleCmd jctl + res <- fmap (either Just $ const Nothing) . try $ handleCmd jctl sentRes <- liftIO . atomically $ foldrM (\resVar -> bool (tryPutTMVar resVar res) $ return True) False (maybe [] NonEmpty.toList resVars) case res of Just err | not sentRes -> $logErrorS logIdent $ tshow err _other -> return () where - logIdent = "Jobs #" <> tshow wNum + logIdent = mkLogIdent wNum handleQueueException :: MonadLogger m => JobQueueException -> m () handleQueueException (JInvalid jId j) = $logWarnS logIdent $ "Invalid QueuedJob (#" ++ tshow (fromSqlKey jId) ++ "): " ++ tshow j @@ -285,7 +357,7 @@ handleJobs' foundation wNum = C.mapM_ $ \jctl -> do newCTab <- liftHandlerT . runDB $ setSerializable determineCrontab' -- logDebugS logIdent $ tshow newCTab mapReaderT (liftIO . atomically) $ - lift . void . flip swapTMVar newCTab =<< asks jobCrontab + lift . void . flip swapTVar newCTab =<< asks jobCrontab handleCmd (JobCtlGenerateHealthReport kind) = do hrStorage <- getsYesod appHealthReport newReport@(healthReportStatus -> newStatus) <- lift $ generateHealthReport kind diff --git a/src/Jobs/Queue.hs b/src/Jobs/Queue.hs index 8152ffbfb..f0ddede48 100644 --- a/src/Jobs/Queue.hs +++ b/src/Jobs/Queue.hs @@ -39,12 +39,12 @@ writeJobCtl :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> m () -- While this means that they might be executed later than desireable, rouge threads that queue the same instruction many times do not deny service to others writeJobCtl cmd = do tid <- liftIO myThreadId - wMap <- getsYesod appJobCtl >>= liftIO . readTVarIO + wMap <- fmap jobWorkers $ getsYesod appJobState >>= atomically . readTMVar if | null wMap -> throwM JobQueuePoolEmpty | otherwise -> do let chan = flip evalRand (mkStdGen (hash tid `hashWithSalt` cmd)) $ uniform wMap - liftIO . atomically $ writeTMChan chan cmd + liftIO . atomically $ writeTChan chan cmd writeJobCtlBlock :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> ReaderT JobContext m () -- | Pass an instruction to the `Job`-Workers and block until it was acted upon diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 3522ff802..9e4cbc56b 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -2,15 +2,20 @@ module Jobs.Types ( Job(..), Notification(..) , JobCtl(..) , JobContext(..) + , JobState(..) + , JobWorkerId + , showWorkerId, newWorkerId ) where -import Import.NoFoundation +import Import.NoFoundation hiding (Unique) import Data.Aeson (defaultOptions, Options(..), SumEncoding(..)) import Data.Aeson.TH (deriveJSON) import Data.List.NonEmpty (NonEmpty) +import Data.Unique + data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification } | JobSendTestEmail { jEmail :: Email, jMailContext :: MailContext } @@ -75,7 +80,26 @@ data JobCtl = JobCtlFlush instance Hashable JobCtl +newtype JobWorkerId = JobWorkerId { jobWorkerUnique :: Unique } + deriving (Eq, Ord) + +showWorkerId :: JobWorkerId -> Text +-- ^ Make a `JobWorkerId` somewhat human readable as a small-ish Number +showWorkerId = tshow . hashUnique . jobWorkerUnique + +newWorkerId :: MonadIO m => m JobWorkerId +newWorkerId = JobWorkerId <$> liftIO newUnique + data JobContext = JobContext - { jobCrontab :: TMVar (Crontab JobCtl) + { jobCrontab :: TVar (Crontab JobCtl) , jobConfirm :: TVar (HashMap JobCtl (NonEmpty (TMVar (Maybe SomeException)))) } + +data JobState = JobState + { jobWorkers :: Map (Async ()) (TChan JobCtl) + , jobWorkerName :: Async () -> JobWorkerId + , jobContext :: JobContext + , jobPoolManager :: Async () + , jobCron :: Async () + , jobShutdown :: TMVar () + } diff --git a/src/Utils.hs b/src/Utils.hs index 7fbe88857..1792d9af8 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -26,6 +26,7 @@ import Utils.Route as Utils import Utils.Message as Utils import Utils.Lang as Utils import Utils.Parameters as Utils +import Control.Concurrent.Async.Lifted.Safe.Utils as Utils import Text.Blaze (Markup, ToMarkup) From d1abe530b60939f69289b60216f52eab7e7ba6a4 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 24 Jul 2019 09:41:17 +0200 Subject: [PATCH 03/77] feat(health): check for active job workers --- config/settings.yml | 2 ++ messages/uniworx/de.msg | 1 + src/Handler/Health.hs | 3 +++ src/Jobs.hs | 16 ++++++------ src/Jobs/HealthReport.hs | 30 ++++++++++++++++++++++ src/Jobs/Queue.hs | 53 +++++++++++++++++++++++++++------------ src/Jobs/Types.hs | 8 ++++++ src/Model/Types/Health.hs | 6 +++++ src/Settings.hs | 2 ++ 9 files changed, 98 insertions(+), 23 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index edd971e64..d35732623 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -36,8 +36,10 @@ health-check-interval: ldap-admins: "_env:HEALTHCHECK_INTERVAL_LDAP_ADMINS:600" smtp-connect: "_env:HEALTHCHECK_INTERVAL_SMTP_CONNECT:600" widget-memcached: "_env:HEALTHCHECK_INTERVAL_WIDGET_MEMCACHED:600" + active-job-executors: "_env:HEALTHCHECK_INTERVAL_ACTIVE_JOB_EXECUTORS:60" health-check-delay-notify: "_env:HEALTHCHECK_DELAY_NOTIFY:true" health-check-http: "_env:HEALTHCHECK_HTTP:true" # Can we assume, that we can reach ourselves under APPROOT via HTTP (reverse proxies or firewalls might prevent this)? +health-check-active-job-executors-timeout: "_env:HEALTHCHECK_ACTIVE_JOB_EXECUTORS_TIMEOUT:5" log-settings: detailed: "_env:DETAILED_LOGGING:false" diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 99ed87ddf..563aede8a 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1061,6 +1061,7 @@ HealthHTTPReachable: Cluster kann an der erwarteten URL über HTTP erreicht werd HealthLDAPAdmins: Anteil der Administratoren, die im LDAP-Verzeichnis gefunden werden können HealthSMTPConnect: SMTP-Server kann erreicht werden HealthWidgetMemcached: Memcached-Server liefert Widgets korrekt aus +HealthActiveJobExecutors: Anteil der job-workers, die neue Befehle annehmen CourseParticipants n@Int: Derzeit #{n} angemeldete Kursteilnehmer CourseParticipantsInvited n@Int: #{n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs index 7b29e2bbd..36649a436 100644 --- a/src/Handler/Health.hs +++ b/src/Handler/Health.hs @@ -70,6 +70,9 @@ getHealthR = do $of HealthWidgetMemcached (Just passed)
_{MsgHealthWidgetMemcached}
#{boolSymbol passed} + $of HealthActiveJobExecutors (Just active) +
_{MsgHealthActiveJobExecutors} +
#{textPercent active 1} $of _ |] provideJson healthReports diff --git a/src/Jobs.hs b/src/Jobs.hs index 3da01ebee..f8cdb2ee5 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -114,7 +114,7 @@ manageJobPool, manageCrontab :: forall m. manageCrontab foundation@UniWorX{..} = do context <- atomically . fmap jobContext $ readTMVar appJobState liftIO . unsafeHandler foundation . void $ do - runReaderT ?? context $ + runReaderT ?? foundation $ writeJobCtlBlock JobCtlDetermineCrontab evalRWST execCrontab' context HashMap.empty where @@ -239,7 +239,8 @@ execCrontab = do | ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab -> do now <- liftIO $ getCurrentTime - instanceID' <- getsYesod appInstanceID + foundation <- getYesod + let instanceID' = foundation ^. _appInstanceID State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl case jobCtl of JobCtlQueue job -> do @@ -252,7 +253,7 @@ execCrontab = do } [ CronLastExecTime =. now ] lift $ queueDBJob job - other -> writeJobCtl other + other -> runReaderT ?? foundation $ writeJobCtl other | otherwise -> mapRWST (liftIO . atomically) $ liftBase . void . flip swapTVar newCrontab =<< asks jobCrontab @@ -322,10 +323,10 @@ mkLogIdent wId = "Job-Executor " <> showWorkerId wId handleJobs' :: JobWorkerId -> Sink JobCtl (ReaderT JobContext Handler) () handleJobs' wNum = C.mapM_ $ \jctl -> do $logDebugS logIdent $ tshow jctl - resVars <- mapReaderT (liftIO . atomically) $ - HashMap.lookup jctl <$> (lift . readTVar =<< asks jobConfirm) res <- fmap (either Just $ const Nothing) . try $ handleCmd jctl - sentRes <- liftIO . atomically $ foldrM (\resVar -> bool (tryPutTMVar resVar res) $ return True) False (maybe [] NonEmpty.toList resVars) + sentRes <- mapReaderT (liftIO . atomically) $ do + resVars <- HashMap.lookup jctl <$> (lift . readTVar =<< asks jobConfirm) + lift $ foldrM (\resVar -> bool (tryPutTMVar resVar res) $ return True) False (maybe [] NonEmpty.toList resVars) case res of Just err | not sentRes -> $logErrorS logIdent $ tshow err @@ -338,7 +339,8 @@ handleJobs' wNum = C.mapM_ $ \jctl -> do handleQueueException (JNonexistant jId) = $logInfoS logIdent $ "Saw nonexistant queue id: " ++ tshow (fromSqlKey jId) handleQueueException (JLocked jId lInstance lTime) = $logDebugS logIdent $ "Saw locked QueuedJob: " ++ tshow (fromSqlKey jId, lInstance, lTime) - handleCmd JobCtlFlush = void . lift . runDB . runConduit $ selectKeys [] [ Asc QueuedJobCreationTime ] .| C.mapM_ (writeJobCtl . JobCtlPerform) + handleCmd JobCtlNoOp = return () + handleCmd JobCtlFlush = void . lift . runDB . runConduit $ selectKeys [] [ Asc QueuedJobCreationTime ] .| C.mapM_ (lift . writeJobCtl . JobCtlPerform) handleCmd (JobCtlQueue job) = lift $ queueJob' job handleCmd (JobCtlPerform jId) = lift . handle handleQueueException . jLocked jId $ \j@QueuedJob{..} -> do content <- case fromJSON queuedJobContent of diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs index bf65049f9..6aecd01f6 100644 --- a/src/Jobs/HealthReport.hs +++ b/src/Jobs/HealthReport.hs @@ -7,6 +7,7 @@ module Jobs.HealthReport import Import import Data.List (genericLength) +import qualified Data.Map.Strict as Map import qualified Data.Aeson as Aeson import Data.Proxy (Proxy(..)) @@ -27,6 +28,12 @@ import qualified Data.CaseInsensitive as CI import qualified Network.HaskellNet.SMTP as SMTP import Data.Pool (withResource) +import System.Timeout + +import Jobs.Queue + +import Control.Concurrent.Async.Lifted.Safe (forConcurrently) + generateHealthReport :: HealthCheck -> Handler HealthReport generateHealthReport = $(dispatchTH ''HealthCheck) @@ -135,3 +142,26 @@ dispatchHealthCheckWidgetMemcached = HealthWidgetMemcached <$> do (== content) . responseBody <$> httpLBS httpRequest _other -> return False + +dispatchHealthCheckActiveJobExecutors :: Handler HealthReport +dispatchHealthCheckActiveJobExecutors = HealthActiveJobExecutors <$> do + app <- getYesod + jState <- atomically . tryReadTMVar $ appJobState app + let configuredNumber = app ^. _appJobWorkers + timeoutLength = app ^. _appHealthCheckActiveJobExecutorsTimeout + case jState of + Nothing + | configuredNumber == 0 -> return Nothing + Nothing -> return $ Just 0 + Just JobState{jobWorkers, jobWorkerName} -> do + tid <- liftIO myThreadId + let workers' = Map.fromSet jobWorkerName (Map.keysSet jobWorkers) + workers = Map.filterWithKey (\a _ -> asyncThreadId a /= tid) workers' + timeoutMicro = let (MkFixed micro :: Micro) = realToFrac timeoutLength + in fromInteger micro + $logDebugS "HealthCheckActiveJobExecutors" . tshow . map showWorkerId $ Map.elems workers' + responders <- fmap (getSum . fold) . liftIO . forConcurrently (Map.toList workers) $ \(_, wName) + -> fromMaybe (Sum 0) <$> timeout timeoutMicro (runReaderT ?? app $ Sum 1 <$ writeJobCtlBlock' (writeJobCtl' wName) JobCtlNoOp) + if + | Map.null workers -> return Nothing + | otherwise -> return . Just $ responders % fromIntegral (Map.size workers) diff --git a/src/Jobs/Queue.hs b/src/Jobs/Queue.hs index f0ddede48..8b71c2960 100644 --- a/src/Jobs/Queue.hs +++ b/src/Jobs/Queue.hs @@ -1,5 +1,6 @@ module Jobs.Queue ( writeJobCtl, writeJobCtlBlock + , writeJobCtl', writeJobCtlBlock' , queueJob, queueJob' , YesodJobDB , runDBJobs, queueDBJob, sinkDBJobs @@ -9,12 +10,14 @@ module Jobs.Queue import Import hiding ((<>)) import Utils.Sql +import Utils.Lens import Jobs.Types import Control.Monad.Trans.Writer (WriterT, runWriterT) import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Trans.Reader (ReaderT, mapReaderT) +import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Data.List.NonEmpty as NonEmpty import qualified Data.HashMap.Strict as HashMap @@ -27,39 +30,54 @@ import Data.Semigroup ((<>)) data JobQueueException = JobQueuePoolEmpty + | JobQueueWorkerNotFound deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic) instance Exception JobQueueException -writeJobCtl :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> m () +writeJobCtl' :: (MonadThrow m, MonadIO m, MonadReader UniWorX m) => JobWorkerId -> JobCtl -> m () +-- | Pass an instruction to the given `Job`-Worker +writeJobCtl' target cmd = do + JobState{jobWorkers, jobWorkerName} <- asks appJobState >>= atomically . readTMVar + if + | null jobWorkers + -> throwM JobQueuePoolEmpty + | [(_, chan)] <- filter ((== target) . jobWorkerName . view _1) $ Map.toList jobWorkers + -> atomically $ writeTChan chan cmd + | otherwise + -> throwM JobQueueWorkerNotFound + +writeJobCtl :: (MonadThrow m, MonadIO m, MonadReader UniWorX m) => JobCtl -> m () -- | Pass an instruction to the `Job`-Workers -- -- Instructions are assigned deterministically and pseudo-randomly to one specific worker. -- While this means that they might be executed later than desireable, rouge threads that queue the same instruction many times do not deny service to others writeJobCtl cmd = do + names <- fmap jobWorkerNames $ asks appJobState >>= atomically . readTMVar tid <- liftIO myThreadId - wMap <- fmap jobWorkers $ getsYesod appJobState >>= atomically . readTMVar - if - | null wMap -> throwM JobQueuePoolEmpty - | otherwise -> do - let chan = flip evalRand (mkStdGen (hash tid `hashWithSalt` cmd)) $ uniform wMap - liftIO . atomically $ writeTChan chan cmd + let target = evalRand ?? mkStdGen (hash tid `hashWithSalt` cmd) $ uniform names + writeJobCtl' target cmd -writeJobCtlBlock :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> ReaderT JobContext m () --- | Pass an instruction to the `Job`-Workers and block until it was acted upon -writeJobCtlBlock cmd = do - getResVar <- asks jobConfirm - resVar <- liftIO . atomically $ do + +writeJobCtlBlock' :: (MonadThrow m, MonadIO m, MonadReader UniWorX m) => (JobCtl -> m ()) -> JobCtl -> m () +-- | Pass an instruction to a `Job`-Worker using the provided callback and block until it was acted upon +writeJobCtlBlock' writeCtl cmd = do + getResVar <- fmap (jobConfirm . jobContext) $ asks appJobState >>= atomically . readTMVar + resVar <- atomically $ do var <- newEmptyTMVar modifyTVar' getResVar $ HashMap.insertWith (<>) cmd (pure var) return var - lift $ writeJobCtl cmd + writeCtl cmd let removeResVar = HashMap.update (NonEmpty.nonEmpty . NonEmpty.filter (/= resVar)) cmd - mExc <- liftIO . atomically $ takeTMVar resVar <* modifyTVar' getResVar removeResVar + mExc <- atomically $ takeTMVar resVar <* modifyTVar' getResVar removeResVar maybe (return ()) throwM mExc +writeJobCtlBlock :: (MonadThrow m, MonadIO m, MonadReader UniWorX m) => JobCtl -> m () +-- | Pass an instruction to the `Job`-Workers and block until it was acted upon +writeJobCtlBlock = writeJobCtlBlock' writeJobCtl + queueJobUnsafe :: Job -> YesodDB UniWorX QueuedJobId queueJobUnsafe job = do now <- liftIO getCurrentTime @@ -83,7 +101,9 @@ queueJob = liftHandlerT . runDB . setSerializable . queueJobUnsafe queueJob' :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m () -- ^ `queueJob` followed by `writeJobCtl` `JobCtlPerform` to ensure, that it is executed asap -queueJob' job = queueJob job >>= writeJobCtl . JobCtlPerform +queueJob' job = do + app <- getYesod + queueJob job >>= flip runReaderT app . writeJobCtl . JobCtlPerform -- | Slightly modified Version of `YesodDB` for `runDBJobs` type YesodJobDB site = ReaderT (YesodPersistBackend site) (WriterT (Set QueuedJobId) (HandlerT site IO)) @@ -102,5 +122,6 @@ runDBJobs :: (MonadHandler m, HandlerSite m ~ UniWorX) => YesodJobDB UniWorX a - -- Jobs get immediately executed if the transaction succeeds runDBJobs act = do (ret, jIds) <- liftHandlerT . runDB $ mapReaderT runWriterT act - forM_ jIds $ writeJobCtl . JobCtlPerform + app <- getYesod + forM_ jIds $ flip runReaderT app . writeJobCtl . JobCtlPerform return ret diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 9e4cbc56b..74fd7afe3 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -3,6 +3,7 @@ module Jobs.Types , JobCtl(..) , JobContext(..) , JobState(..) + , jobWorkerNames , JobWorkerId , showWorkerId, newWorkerId ) where @@ -16,6 +17,9 @@ import Data.List.NonEmpty (NonEmpty) import Data.Unique +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification } | JobSendTestEmail { jEmail :: Email, jMailContext :: MailContext } @@ -75,6 +79,7 @@ data JobCtl = JobCtlFlush | JobCtlDetermineCrontab | JobCtlQueue Job | JobCtlGenerateHealthReport HealthCheck + | JobCtlNoOp deriving (Eq, Ord, Read, Show, Generic, Typeable) instance Hashable JobCtl @@ -103,3 +108,6 @@ data JobState = JobState , jobCron :: Async () , jobShutdown :: TMVar () } + +jobWorkerNames :: JobState -> Set JobWorkerId +jobWorkerNames JobState{..} = Set.map jobWorkerName $ Map.keysSet jobWorkers diff --git a/src/Model/Types/Health.hs b/src/Model/Types/Health.hs index aea99d735..ce0f53e23 100644 --- a/src/Model/Types/Health.hs +++ b/src/Model/Types/Health.hs @@ -15,6 +15,7 @@ data HealthCheck | HealthCheckLDAPAdmins | HealthCheckSMTPConnect | HealthCheckWidgetMemcached + | HealthCheckActiveJobExecutors deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) instance Universe HealthCheck instance Finite HealthCheck @@ -39,6 +40,8 @@ data HealthReport -- ^ Can we connect to the SMTP server and say @NOOP@? | HealthWidgetMemcached { healthWidgetMemcached :: Maybe Bool } -- ^ Can we store values in memcached and retrieve them via HTTP? + | HealthActiveJobExecutors { healthActiveJobExecutors :: Maybe Rational } + -- ^ Proportion of job executors (excluding the one running the healthcheck) responding within a timeout deriving (Eq, Ord, Read, Show, Data, Generic, Typeable) instance NFData HealthReport @@ -57,6 +60,7 @@ classifyHealthReport HealthLDAPAdmins{} = HealthCheckLDAPAdmins classifyHealthReport HealthHTTPReachable{} = HealthCheckHTTPReachable classifyHealthReport HealthSMTPConnect{} = HealthCheckSMTPConnect classifyHealthReport HealthWidgetMemcached{} = HealthCheckWidgetMemcached +classifyHealthReport HealthActiveJobExecutors{} = HealthCheckActiveJobExecutors -- | `HealthReport` classified (`classifyHealthReport`) by badness -- @@ -84,4 +88,6 @@ healthReportStatus = \case | prop <= 0 -> HealthFailure HealthSMTPConnect (Just False) -> HealthFailure HealthWidgetMemcached (Just False) -> HealthFailure -- TODO: investigate this failure mode; do we just handle it gracefully? + HealthActiveJobExecutors (Just prop ) + | prop < 1 -> HealthFailure _other -> maxBound -- Minimum badness diff --git a/src/Settings.hs b/src/Settings.hs index c53e90269..191e1ca1d 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -118,6 +118,7 @@ data AppSettings = AppSettings , appHealthCheckInterval :: HealthCheck -> Maybe NominalDiffTime , appHealthCheckDelayNotify :: Bool , appHealthCheckHTTP :: Bool + , appHealthCheckActiveJobExecutorsTimeout :: NominalDiffTime , appInitialLogSettings :: LogSettings @@ -389,6 +390,7 @@ instance FromJSON AppSettings where appHealthCheckInterval <- (assertM' (> 0) . ) <$> o .: "health-check-interval" appHealthCheckDelayNotify <- o .: "health-check-delay-notify" appHealthCheckHTTP <- o .: "health-check-http" + appHealthCheckActiveJobExecutorsTimeout <- o .: "health-check-active-job-executors-timeout" appSessionTimeout <- o .: "session-timeout" From 55f7e0795fa45257191dc6b809130ce79c1391c2 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 24 Jul 2019 10:16:24 +0200 Subject: [PATCH 04/77] refactor(js): move i18n.js to own file, remove default-layout.julius --- src/Foundation.hs | 1 + src/Import/NoModel.hs | 1 + templates/{default-layout.julius => i18n.julius} | 0 3 files changed, 2 insertions(+) rename templates/{default-layout.julius => i18n.julius} (100%) diff --git a/src/Foundation.hs b/src/Foundation.hs index 8103ebfda..aa4cafd6a 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1435,6 +1435,7 @@ siteLayout' headingOverride widget = do addScript $ StaticR bundles_js_polyfills_js addScript $ StaticR bundles_js_vendor_js addScript $ StaticR bundles_js_main_js + toWidgetHead $(juliusFile "templates/i18n.julius") -- widgets $(widgetFile "default-layout") withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index cd1bd66c2..41d12dcff 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -27,6 +27,7 @@ import Data.UUID as Import (UUID) import Data.CaseInsensitive as Import (CI, FoldCase(..), foldedCase) import Text.Lucius as Import +import Text.Julius as Import import Text.Shakespeare.Text as Import hiding (text, stext) import Data.Universe as Import diff --git a/templates/default-layout.julius b/templates/i18n.julius similarity index 100% rename from templates/default-layout.julius rename to templates/i18n.julius From da59a2f9da0c3500ded597e9aa801cd97add945a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 24 Jul 2019 11:12:47 +0200 Subject: [PATCH 05/77] chore(tests): fix tests --- src/Application.hs | 2 +- src/Jobs.hs | 33 ++++++++++++++++----------------- test/TestImport.hs | 16 +++++++--------- 3 files changed, 24 insertions(+), 27 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index 6e2d45fd7..7291fda1c 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -478,7 +478,7 @@ getApplicationRepl = do return (getPort wsettings, foundation, app1) -shutdownApp :: MonadIO m => UniWorX -> m () +shutdownApp :: (MonadIO m, MonadBaseControl IO m) => UniWorX -> m () shutdownApp app = do stopJobCtl app liftIO $ do diff --git a/src/Jobs.hs b/src/Jobs.hs index f8cdb2ee5..4769178ff 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -113,16 +113,14 @@ manageJobPool, manageCrontab :: forall m. => UniWorX -> m () manageCrontab foundation@UniWorX{..} = do context <- atomically . fmap jobContext $ readTMVar appJobState - liftIO . unsafeHandler foundation . void $ do + let awaitTermination = atomically $ do + shouldTerminate <- readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown + guard shouldTerminate + liftIO . race_ awaitTermination . unsafeHandler foundation . void $ do + atomically . assertM_ (not . Map.null . jobWorkers) $ readTMVar appJobState runReaderT ?? foundation $ writeJobCtlBlock JobCtlDetermineCrontab - evalRWST execCrontab' context HashMap.empty - where - execCrontab' = do - shouldTerminate <- atomically $ readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown - if - | shouldTerminate -> return () - | otherwise -> execCrontab *> execCrontab' + evalRWST (forever execCrontab) context HashMap.empty manageJobPool foundation@UniWorX{..} @@ -158,6 +156,7 @@ manageJobPool foundation@UniWorX{..} runWorker = unsafeHandler foundation . flip runReaderT (jobContext oldState) $ do $logInfoS logIdent "Started" runConduit $ streamChan .| handleJobs' workerId + $logInfoS logIdent "Stopped" worker <- allocateLinkedAsync runWorker tell . Endo $ \cSt -> cSt @@ -196,18 +195,18 @@ manageJobPool foundation@UniWorX{..} $logInfoS "JobPoolManager" "Shutting down" terminate () -stopJobCtl :: MonadIO m => UniWorX -> m () +stopJobCtl :: (MonadIO m, MonadBaseControl IO m) => UniWorX -> m () -- ^ Stop all worker threads currently running stopJobCtl UniWorX{appJobState} = do - atomically $ do - JobState{..} <- readTMVar appJobState - putTMVar jobShutdown () - atomically $ do - JobState{..} <- takeTMVar appJobState + didStop <- atomically $ do + jState <- tryReadTMVar appJobState + for jState $ \jSt'@JobState{jobShutdown} -> jSt' <$ tryPutTMVar jobShutdown () + whenIsJust didStop $ \jSt' -> void . fork . atomically $ do + workers <- maybe [] (Map.keys . jobWorkers) <$> tryTakeTMVar appJobState mapM_ (void . waitCatchSTM) $ - [ jobPoolManager - , jobCron - ] ++ Map.keys jobWorkers + [ jobPoolManager jSt' + , jobCron jSt' + ] ++ workers execCrontab :: RWST JobContext () (HashMap JobCtl (Max UTCTime)) (HandlerT UniWorX IO) () -- ^ Keeping a `HashMap` of the latest execution times of `JobCtl`s we have diff --git a/test/TestImport.hs b/test/TestImport.hs index 9164c3144..48e0b5d27 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -3,7 +3,7 @@ module TestImport , module X ) where -import Application (makeFoundation, makeLogWare) +import Application (makeFoundation, makeLogWare, shutdownApp) import ClassyPrelude as X hiding (delete, deleteBy, Handler, Index, (<.>), (<|), index, uncons, unsnoc, cons, snoc) import Database.Persist as X hiding (get) import Database.Persist.Sql as X (SqlPersistM) @@ -31,7 +31,7 @@ import Test.QuickCheck.Classes.Binary as X import Data.Proxy as X import Data.UUID as X (UUID) import System.IO as X (hPrint, hPutStrLn, stderr) -import Jobs (handleJobs, stopJobCtl) +import Jobs (handleJobs) import Numeric.Natural as X import Control.Lens as X hiding ((<.), elements) @@ -42,7 +42,6 @@ import Database (truncateDb) import Database as X (fillDb) import Control.Monad.Trans.Resource (runResourceT, MonadResourceBase) -import Data.Pool (destroyAllResources) import Settings @@ -51,6 +50,8 @@ import qualified Data.CaseInsensitive as CI import Data.Typeable +import Handler.Utils (runAppLoggingT) + runDB :: SqlPersistM a -> YesodExample UniWorX a runDB query = do @@ -74,13 +75,10 @@ withApp = around $ \act -> runResourceT $ do [] useEnv foundation <- makeFoundation settings - let - stopDBAccess = do - stopJobCtl foundation - liftIO . destroyAllResources $ appConnPool foundation - bracket_ stopDBAccess (handleJobs foundation) $ wipeDB foundation + wipeDB foundation + runAppLoggingT foundation $ handleJobs foundation logWare <- makeLogWare foundation - lift $ act (foundation, logWare) + lift $ act (foundation, logWare) `finally` shutdownApp foundation -- This function will truncate all of the tables in your database. -- 'withApp' calls it before each test, creating a clean environment for each From d81d6306f3b9866e2d07204604f8fcd10a60115f Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 24 Jul 2019 11:22:13 +0200 Subject: [PATCH 06/77] chore(release): 4.3.0 --- CHANGELOG.md | 9 +++++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 12 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index ce0147d38..d1fb64481 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,15 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [4.3.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.2.0...v4.3.0) (2019-07-24) + + +### Features + +* **health:** check for active job workers ([d1abe53](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d1abe53)) + + + ## [4.2.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.1.2...v4.2.0) (2019-07-23) diff --git a/package-lock.json b/package-lock.json index ec336c331..569bcb96b 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "4.2.0", + "version": "4.3.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 2e27c53a7..16d2764cf 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "4.2.0", + "version": "4.3.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index cf631c001..557a87837 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 4.2.0 +version: 4.3.0 dependencies: # Due to a bug in GHC 8.0.1, we block its usage From a278cc5048a3c15c393cca86ea12b3ea095ae65c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 24 Jul 2019 11:29:32 +0200 Subject: [PATCH 07/77] fix(exam-csv): audit registrations/deregistrations --- src/Handler/Exam.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs index e8c2b8ea4..ee7d96bed 100644 --- a/src/Handler/Exam.hs +++ b/src/Handler/Exam.hs @@ -1095,6 +1095,8 @@ postEUsersR tid ssh csh examn = do , courseParticipantRegistration = now , courseParticipantField = examUserCsvActCourseField } + User{userIdent} <- getJust examUserCsvActUser + audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent insert_ ExamRegistration { examRegistrationExam = eid , examRegistrationUser = examUserCsvActUser @@ -1113,7 +1115,11 @@ postEUsersR tid ssh csh examn = do update examUserCsvActRegistration [ ExamRegistrationOccurrence =. examUserCsvActOccurrence ] ExamUserCsvSetCourseFieldData{..} -> update examUserCsvActCourseParticipant [ CourseParticipantField =. examUserCsvActCourseField ] - ExamUserCsvDeregisterData{..} -> delete examUserCsvActRegistration + ExamUserCsvDeregisterData{..} -> do + ExamRegistration{examRegistrationUser} <- getJust examUserCsvActRegistration + User{userIdent} <- getJust examRegistrationUser + audit' $ TransactionExamDeregister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent + delete examUserCsvActRegistration return $ CExamR tid ssh csh examn EUsersR , dbtCsvRenderKey = \(registeredUserName -> registeredUserName') -> \case ExamUserCsvCourseRegisterData{..} -> do From f2963cff0765073b2be0cff84a3cd21c6f5e5db9 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 24 Jul 2019 15:02:12 +0200 Subject: [PATCH 08/77] refactor(icons): only allow semantic icons from now on --- src/Utils/Icon.hs | 182 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 182 insertions(+) create mode 100644 src/Utils/Icon.hs diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs new file mode 100644 index 000000000..865bba69f --- /dev/null +++ b/src/Utils/Icon.hs @@ -0,0 +1,182 @@ +module Utils.Icon where + +-- | A @Widget@ for any site; no language interpolation, etc. +type WidgetSiteless = forall site. forall m. (MonadIO m, MonadThrow m, MonadBaseControl IO m) + => WidgetT site m () + +import Data.Universe +import Utils.PathPiece +import Text.Hamlet + + +----------- +-- Icons -- +----------- +-- We collect all used icons here for an overview. +-- For consistency, some conditional icons are also provided, having suffix True/False +-- IMPORTANT: Alert-Icons must be registered in alert-icons.js as well + +data Icon + = IconNew + | IconOK + | IconNotOK + | IconWarning + | IconProblem + | IconVisible + | IconNotVisible + | IconCourse + | IconEnrolTrue + | IconEnrolFalse + | IconExam + | IconExamRegisterTrue + | IconExamRegisterFalse + | IconCommentTrue + | IconCommentFalse + | IconFileDownload + | IconFileZip + | IconFileCSV + | IconSFTQuestion -- for SheetFileType only + | IconSFTHint -- for SheetFileType only + | IconSFTSolution -- for SheetFileType only + | IconSFTMarking -- for SheetFileType only + deriving (Eq, Enum, Bounded, Show, Read) + +iconText :: Icon -> Text +iconText = \case + IconNew -> "seedling" + IconOK -> "check" + IconNotOK -> "times" + IconWarning -> "exclamation" + IconProblem -> "bolt" + IconVisible -> "eye" + IconNotVisible -> "eye-slash" + IconCourse -> "graduation-cap" + IconEnrolTrue -> "user-plus" + IconEnrolFalse -> "user-slash" + IconExam -> "file-invoice" + IconExamRegisterTrue -> "calendar-check" + IconExamRegisterFalse -> "calendar-times" + IconCommentTrue -> "comment-alt" + IconCommentFalse -> "comment-slash" + IconFileDownload -> "file-download" + IconFileZip -> "file-archive" + IconFileCSV -> "file-csv" + IconSFTQuestion -> "question-circle" -- for SheetFileType only, should all be round (similar) + IconSFTHint -> "life-ring" -- for SheetFileType only + IconSFTSolution -> "exclamation-circle" -- for SheetFileType only + IconSFTMarking -> "check-circle" -- for SheetFileType only + +instance Universe Icon +instance Finte Icon +nullaryPathPiece ''Icon $ camelToPathPiece' 1 + +-- Create an icon from font-awesome without additional space +icon :: Icon -> Markup +icon iconName = + [shamlet|$newline never + |] + + +-- for compatibility and convenience +iconShortcuts :: Q [Dec] +iconShortcuts = forM universeF + (\ic -> + iname <- newName $ 'i' : (drop 1 $ show ic) + valD (varP iname) (normalB [|icon iname|]) + ) + +iconQuestion :: Markup +iconQuestion = icon IconQuestion + +iconNew :: Markup +iconNew = icon IconNew + +iconOK :: Markup +iconOK = icon IconOK + +iconNotOK :: Markup +iconNotOK = icon IconNotOK + +iconWarning :: Markup +iconWarning = icon IconWarning + +iconProblem :: Markup +iconProblem = icon IconProblem + +iconHint :: Markup +iconHint = icon + +-- Icons for Course +iconCourse :: Markup +iconCourse = fontAwesomeIcon "graduation-cap" + +iconExam :: Markup +iconExam = fontAwesomeIcon "file-invoice" + +iconEnrol :: Bool -> Markup +iconEnrol True = fontAwesomeIcon "user-plus" +iconEnrol False = fontAwesomeIcon "user-slash" + +iconExamRegister :: Bool -> Markup +iconExamRegister True = fontAwesomeIcon "calendar-check" +iconExamRegister False = fontAwesomeIcon "calendar-times" + + +-- Icons for SheetFileType +iconSolution :: Markup +iconSolution =fontAwesomeIcon "exclamation-circle" + +iconMarking :: Markup +iconMarking = fontAwesomeIcon "check-circle" + +fileDownload :: Markup +fileDownload = fontAwesomeIcon "file-download" + +zipDownload :: Markup +zipDownload = fontAwesomeIcon "file-archive" + +iconCSV :: Markup +iconCSV = fontAwesomeIcon "file-csv" + + +-- Generic Conditional icons + +isVisible :: Bool -> Markup +-- ^ Display an icon that denotes that something™ is visible or invisible +isVisible True = fontAwesomeIcon "eye" +isVisible False = fontAwesomeIcon "eye-slash" +-- +-- For documentation on how to avoid these unneccessary functions +-- we implement them here just once for the first icon: +-- +isVisibleWidget :: Bool -> WidgetSiteless +-- ^ Widget having an icon that denotes that something™ is visible or invisible +isVisibleWidget = toWidget . isVisible + +maybeIsVisibleWidget :: Maybe Bool -> WidgetSiteless +-- ^ Maybe a widget with an icon that denotes that something™ is visible or invisible +maybeIsVisibleWidget = toWidget . foldMap isVisible + +-- Other _frequently_ used icons: +hasComment :: Bool -> Markup +-- ^ Display an icon that denotes that something™ has a comment or not +hasComment True = fontAwesomeIcon "comment-alt" +hasComment False = fontAwesomeIcon "comment-slash" -- comment-alt-slash is not available for free + +hasTickmark :: Bool -> Markup +-- ^ Display an icon that denotes that something™ is okay +hasTickmark True = iconOK +hasTickmark False = mempty + +isBad :: Bool -> Markup +-- ^ Display an icon that denotes that something™ is bad +isBad True = iconProblem +isBad False = mempty + +isNew :: Bool -> Markup +isNew True = iconNew +isNew False = mempty + +boolSymbol :: Bool -> Markup +boolSymbol True = iconOK +boolSymbol False = iconNotOK From 495fdd18dd2579b652b6caf93629e5be5d3b2974 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 24 Jul 2019 15:03:35 +0200 Subject: [PATCH 09/77] refactor(icons): only allow semantics icons from now on --- src/Handler/Utils/Table/Cells.hs | 15 ++- src/Handler/Utils/Table/Pagination.hs | 2 +- src/Language/Haskell/TH/Instances.hs | 12 +- src/Model/Types/Sheet.hs | 8 +- src/Utils.hs | 120 +----------------- src/Utils/Icon.hs | 170 +++++++++++--------------- src/Utils/Message.hs | 1 + templates/exam-show.hamlet | 8 +- 8 files changed, 105 insertions(+), 231 deletions(-) diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 948febc54..2620ee83f 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -122,8 +122,7 @@ isNewCell = cell . toWidget . isNew -- | Maybe display comment icon linking a given URL or show nothing at all commentCell :: IsDBTable m a => Maybe (Route UniWorX) -> DBCell m a commentCell Nothing = mempty -commentCell (Just link) = anchorCell link icon - where icon = hasComment True +commentCell (Just link) = anchorCell link $ hasComment True -- | whether something is visible or hidden isVisibleCell :: (IsDBTable m a) => Bool -> DBCell m a @@ -134,11 +133,15 @@ isVisibleCell False = (cell . toWidget $ isVisible False) & addUrgencyClass -- | for simple file downloads fileCell :: IsDBTable m a => Route UniWorX -> DBCell m a -fileCell route = anchorCell route fileDownload +fileCell route = anchorCell route iconFileDownload -- | for zip-archive downloads zipCell :: IsDBTable m a => Route UniWorX -> DBCell m a -zipCell route = anchorCell route zipDownload +zipCell route = anchorCell route iconFileZip + +-- | for csv downloads +csvCell :: IsDBTable m a => Route UniWorX -> DBCell m a +csvCell route = anchorCell route iconFileCSV -- | Display an icon that opens a modal upon clicking modalCell :: (IsDBTable m a, ToWidget UniWorX w) => w -> DBCell m a @@ -197,11 +200,11 @@ cellHasEMail = emailCell . view _userEmail cellHasSemester :: (IsDBTable m c, HasStudyFeatures a) => a -> DBCell m c cellHasSemester = numCell . view _studyFeaturesSemester - + cellHasField :: (IsDBTable m c, HasStudyTerms a) => a -> DBCell m c cellHasField x = maybe (numCell $ x ^. _studyTermsKey) textCell $ x ^. _studyTermsName <|> x ^. _studyTermsShorthand - + cellHasDegreeShort :: (IsDBTable m c, HasStudyDegree a) => a -> DBCell m c cellHasDegreeShort x = maybe (numCell $ x ^. _studyDegreeKey) textCell $ x ^. _studyDegreeShorthand <|> x ^. _studyDegreeName diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 4f6676899..ad436a996 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -285,7 +285,7 @@ instance Button UniWorX ButtonCsvMode where btnLabel BtnCsvExport = [whamlet| $newline never - #{iconCSV} + #{iconFileCSV} \ _{BtnCsvExport} |] btnLabel BtnCsvImport diff --git a/src/Language/Haskell/TH/Instances.hs b/src/Language/Haskell/TH/Instances.hs index 48c419705..d4730efe6 100644 --- a/src/Language/Haskell/TH/Instances.hs +++ b/src/Language/Haskell/TH/Instances.hs @@ -7,8 +7,18 @@ module Language.Haskell.TH.Instances import Language.Haskell.TH import Language.Haskell.TH.Lift (deriveLift) import Data.Binary (Binary) - +import Data.Semigroup +import Data.Monoid () +import Control.Applicative instance Binary Loc deriveLift ''Loc + + +instance Semigroup (Q [Dec]) where + (<>) = liftA2 (<>) + +instance Monoid (Q [Dec]) where + mempty = pure mempty + mappend = (<>) diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs index 4a6c60a32..2f6e43200 100644 --- a/src/Model/Types/Sheet.hs +++ b/src/Model/Types/Sheet.hs @@ -171,10 +171,10 @@ instance PathPiece SheetFileType where fromPathPiece = finiteFromPathPiece sheetFile2markup :: SheetFileType -> Markup -sheetFile2markup SheetExercise = iconQuestion -sheetFile2markup SheetHint = iconHint -sheetFile2markup SheetSolution = iconSolution -sheetFile2markup SheetMarking = iconMarking +sheetFile2markup SheetExercise = iconSFTQuestion +sheetFile2markup SheetHint = iconSFTHint +sheetFile2markup SheetSolution = iconSFTSolution +sheetFile2markup SheetMarking = iconSFTMarking -- partitionFileType' :: Ord a => [(SheetFileType,a)] -> Map SheetFileType (Set a) -- partitionFileType' = groupMap diff --git a/src/Utils.hs b/src/Utils.hs index 7fbe88857..11db44ba0 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -23,6 +23,7 @@ import Utils.TH as Utils import Utils.DateTime as Utils import Utils.PathPiece as Utils import Utils.Route as Utils +import Utils.Icon as Utils import Utils.Message as Utils import Utils.Lang as Utils import Utils.Parameters as Utils @@ -79,9 +80,10 @@ import Algebra.Lattice (top, bottom, (/\), (\/), BoundedJoinSemiLattice, Bounded import Data.Constraint (Dict(..)) -{-# ANN choice ("HLint: ignore Use asum" :: String) #-} +{- # ANN choice ("HLint: ignore Use asum" :: String) # -} +$(iconShortcuts) -- declares constants for all known icons ----------- -- Yesod -- @@ -114,122 +116,6 @@ unsupportedAuthPredicate = do --- | A @Widget@ for any site; no language interpolation, etc. -type WidgetSiteless = forall site. forall m. (MonadIO m, MonadThrow m, MonadBaseControl IO m) - => WidgetT site m () - - ------------ --- Icons -- ------------ - --- Create an icon from font-awesome without additional space -fontAwesomeIcon :: Text -> Markup -fontAwesomeIcon iconName = - [shamlet|$newline never - |] - --- We collect all used icons here for an overview. --- For consistency, some conditional icons are also provided, e.g. `isIvisble` - -iconQuestion :: Markup -iconQuestion = fontAwesomeIcon "question-circle" - -iconNew :: Markup -iconNew = fontAwesomeIcon "seedling" - -iconOK :: Markup -iconOK = fontAwesomeIcon "check" - -iconNotOK :: Markup -iconNotOK = fontAwesomeIcon "times" - -iconWarning :: Markup -iconWarning = fontAwesomeIcon "exclamation" - -iconProblem :: Markup -iconProblem = fontAwesomeIcon "bolt" - -iconHint :: Markup -iconHint = fontAwesomeIcon "life-ring" - --- Icons for Course -iconCourse :: Markup -iconCourse = fontAwesomeIcon "graduation-cap" - -iconExam :: Markup -iconExam = fontAwesomeIcon "file-invoice" - -iconEnrol :: Bool -> Markup -iconEnrol True = fontAwesomeIcon "user-plus" -iconEnrol False = fontAwesomeIcon "user-slash" - -iconExamRegister :: Bool -> Markup -iconExamRegister True = fontAwesomeIcon "calendar-check" -iconExamRegister False = fontAwesomeIcon "calendar-times" - - --- Icons for SheetFileType -iconSolution :: Markup -iconSolution =fontAwesomeIcon "exclamation-circle" - -iconMarking :: Markup -iconMarking = fontAwesomeIcon "check-circle" - -fileDownload :: Markup -fileDownload = fontAwesomeIcon "file-download" - -zipDownload :: Markup -zipDownload = fontAwesomeIcon "file-archive" - -iconCSV :: Markup -iconCSV = fontAwesomeIcon "file-csv" - - --- Generic Conditional icons - -isVisible :: Bool -> Markup --- ^ Display an icon that denotes that something™ is visible or invisible -isVisible True = fontAwesomeIcon "eye" -isVisible False = fontAwesomeIcon "eye-slash" --- --- For documentation on how to avoid these unneccessary functions --- we implement them here just once for the first icon: --- -isVisibleWidget :: Bool -> WidgetSiteless --- ^ Widget having an icon that denotes that something™ is visible or invisible -isVisibleWidget = toWidget . isVisible - -maybeIsVisibleWidget :: Maybe Bool -> WidgetSiteless --- ^ Maybe a widget with an icon that denotes that something™ is visible or invisible -maybeIsVisibleWidget = toWidget . foldMap isVisible - --- Other _frequently_ used icons: -hasComment :: Bool -> Markup --- ^ Display an icon that denotes that something™ has a comment or not -hasComment True = fontAwesomeIcon "comment-alt" -hasComment False = fontAwesomeIcon "comment-slash" -- comment-alt-slash is not available for free - -hasTickmark :: Bool -> Markup --- ^ Display an icon that denotes that something™ is okay -hasTickmark True = iconOK -hasTickmark False = mempty - -isBad :: Bool -> Markup --- ^ Display an icon that denotes that something™ is bad -isBad True = iconProblem -isBad False = mempty - -isNew :: Bool -> Markup -isNew True = iconNew -isNew False = mempty - -boolSymbol :: Bool -> Markup -boolSymbol True = iconOK -boolSymbol False = iconNotOK - - - --------------------- -- Text and String -- --------------------- diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 865bba69f..09299e310 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -1,13 +1,22 @@ module Utils.Icon where +import ClassyPrelude.Yesod hiding (foldlM, Proxy) + +import Data.Universe +import Data.Char +import Utils.PathPiece +-- import Text.Hamlet +import Text.Blaze (Markup) +import Control.Lens +import Language.Haskell.TH +import Language.Haskell.TH.Instances () +import Language.Haskell.TH.Lift (deriveLift) +import Instances.TH.Lift () + -- | A @Widget@ for any site; no language interpolation, etc. type WidgetSiteless = forall site. forall m. (MonadIO m, MonadThrow m, MonadBaseControl IO m) => WidgetT site m () -import Data.Universe -import Utils.PathPiece -import Text.Hamlet - ----------- -- Icons -- @@ -23,7 +32,7 @@ data Icon | IconWarning | IconProblem | IconVisible - | IconNotVisible + | IconInvisible | IconCourse | IconEnrolTrue | IconEnrolFalse @@ -49,7 +58,7 @@ iconText = \case IconWarning -> "exclamation" IconProblem -> "bolt" IconVisible -> "eye" - IconNotVisible -> "eye-slash" + IconInvisible -> "eye-slash" IconCourse -> "graduation-cap" IconEnrolTrue -> "user-plus" IconEnrolFalse -> "user-slash" @@ -57,7 +66,7 @@ iconText = \case IconExamRegisterTrue -> "calendar-check" IconExamRegisterFalse -> "calendar-times" IconCommentTrue -> "comment-alt" - IconCommentFalse -> "comment-slash" + IconCommentFalse -> "comment-slash" -- comment-alt-slash is not available for free IconFileDownload -> "file-download" IconFileZip -> "file-archive" IconFileCSV -> "file-csv" @@ -67,85 +76,74 @@ iconText = \case IconSFTMarking -> "check-circle" -- for SheetFileType only instance Universe Icon -instance Finte Icon +instance Finite Icon nullaryPathPiece ''Icon $ camelToPathPiece' 1 +deriveLift ''Icon -- Create an icon from font-awesome without additional space icon :: Icon -> Markup -icon iconName = +icon ic = let ict = iconText ic in [shamlet|$newline never - |] + |] - --- for compatibility and convenience +-- declare constats for all icons for compatibility and convenience +-- "IconCourse" generates "iconCourse = icon IconCourse" iconShortcuts :: Q [Dec] -iconShortcuts = forM universeF - (\ic -> - iname <- newName $ 'i' : (drop 1 $ show ic) - valD (varP iname) (normalB [|icon iname|]) - ) - -iconQuestion :: Markup -iconQuestion = icon IconQuestion - -iconNew :: Markup -iconNew = icon IconNew - -iconOK :: Markup -iconOK = icon IconOK - -iconNotOK :: Markup -iconNotOK = icon IconNotOK - -iconWarning :: Markup -iconWarning = icon IconWarning - -iconProblem :: Markup -iconProblem = icon IconProblem - -iconHint :: Markup -iconHint = icon - --- Icons for Course -iconCourse :: Markup -iconCourse = fontAwesomeIcon "graduation-cap" - -iconExam :: Markup -iconExam = fontAwesomeIcon "file-invoice" - -iconEnrol :: Bool -> Markup -iconEnrol True = fontAwesomeIcon "user-plus" -iconEnrol False = fontAwesomeIcon "user-slash" - -iconExamRegister :: Bool -> Markup -iconExamRegister True = fontAwesomeIcon "calendar-check" -iconExamRegister False = fontAwesomeIcon "calendar-times" +iconShortcuts = foldMap mkIcon (universeF :: [Icon]) + where + mkIcon :: Icon -> Q [Dec] + mkIcon ic = do + do + iname <- newName $ over (ix 0) Data.Char.toLower $ show ic + isig <- sigD iname [t|Markup|] + idef <- valD (varP iname) (normalB [|icon ic|]) [] + return $ [isig, idef] --- Icons for SheetFileType -iconSolution :: Markup -iconSolution =fontAwesomeIcon "exclamation-circle" - -iconMarking :: Markup -iconMarking = fontAwesomeIcon "check-circle" - -fileDownload :: Markup -fileDownload = fontAwesomeIcon "file-download" - -zipDownload :: Markup -zipDownload = fontAwesomeIcon "file-archive" - -iconCSV :: Markup -iconCSV = fontAwesomeIcon "file-csv" - - --- Generic Conditional icons +---------------------- +-- Conditional icons +-- +-- Some case are special, hence no Template Haskell here isVisible :: Bool -> Markup -- ^ Display an icon that denotes that something™ is visible or invisible -isVisible True = fontAwesomeIcon "eye" -isVisible False = fontAwesomeIcon "eye-slash" --- +isVisible True = icon IconVisible +isVisible False = icon IconInvisible + +hasComment :: Bool -> Markup +-- ^ Display an icon that denotes that something™ has a comment or not +hasComment True = icon IconCommentTrue +hasComment False = icon IconCommentFalse + +hasTickmark :: Bool -> Markup +-- ^ Maybe display an icon that denotes that something™ is okay +hasTickmark True = icon IconOK +hasTickmark False = mempty + +isBad :: Bool -> Markup +-- ^ Maybe display an icon that denotes that something™ is bad +isBad True = icon IconProblem +isBad False = mempty + +-- ^ Maybe display an icon that denotes that something™ is bad +isNew :: Bool -> Markup +isNew True = icon IconNew +isNew False = mempty + +boolSymbol :: Bool -> Markup +boolSymbol True = icon IconOK +boolSymbol False = icon IconNotOK + +iconEnrol :: Bool -> Markup +iconEnrol True = icon IconEnrolTrue +iconEnrol False = icon IconEnrolFalse + +iconExamRegister :: Bool -> Markup +iconExamRegister True = icon IconExamRegisterTrue +iconExamRegister False = icon IconExamRegisterTrue + + +---------------- -- For documentation on how to avoid these unneccessary functions -- we implement them here just once for the first icon: -- @@ -156,27 +154,3 @@ isVisibleWidget = toWidget . isVisible maybeIsVisibleWidget :: Maybe Bool -> WidgetSiteless -- ^ Maybe a widget with an icon that denotes that something™ is visible or invisible maybeIsVisibleWidget = toWidget . foldMap isVisible - --- Other _frequently_ used icons: -hasComment :: Bool -> Markup --- ^ Display an icon that denotes that something™ has a comment or not -hasComment True = fontAwesomeIcon "comment-alt" -hasComment False = fontAwesomeIcon "comment-slash" -- comment-alt-slash is not available for free - -hasTickmark :: Bool -> Markup --- ^ Display an icon that denotes that something™ is okay -hasTickmark True = iconOK -hasTickmark False = mempty - -isBad :: Bool -> Markup --- ^ Display an icon that denotes that something™ is bad -isBad True = iconProblem -isBad False = mempty - -isNew :: Bool -> Markup -isNew True = iconNew -isNew False = mempty - -boolSymbol :: Bool -> Markup -boolSymbol True = iconOK -boolSymbol False = iconNotOK diff --git a/src/Utils/Message.hs b/src/Utils/Message.hs index 04dc41dcf..c4153b17d 100644 --- a/src/Utils/Message.hs +++ b/src/Utils/Message.hs @@ -47,6 +47,7 @@ instance Exception UnknownMessageStatus data Message = Message { messageStatus :: MessageStatus , messageContent :: Html + -- , messageIcon :: Maybe Icon } instance Eq Message where diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet index e7d2a777b..188b76453 100644 --- a/templates/exam-show.hamlet +++ b/templates/exam-show.hamlet @@ -24,7 +24,7 @@ $maybe Entity _ ExamResult{examResultResult} <- result $maybe desc <- examDescription
#{desc} - +
$if not examVisible @@ -84,7 +84,7 @@ $maybe desc <- examDescription $maybe registerWdgt <- registerWidget
_{MsgExamRegistration}
^{registerWdgt} - + $if not (null occurrences)
@@ -121,7 +121,7 @@ $if not (null occurrences) $if occurrenceAssignmentsShown $if registered - #{fontAwesomeIcon "check"} + #{iconOK} $if gradingShown && not (null parts)
@@ -148,7 +148,7 @@ $if gradingShown && not (null parts) $of Just (ExamAttended (Just ps)) #{showFixed True ps} $of Just (ExamAttended Nothing) - #{fontAwesomeIcon "check"} + #{iconOK} $of Just ExamNoShow _{MsgExamNoShow} $of Just ExamVoided From dd90fd04a3ebf43e35837d41ca14424f7568bc2c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 24 Jul 2019 18:31:38 +0200 Subject: [PATCH 10/77] feat(exams): implement exam registration invitations --- messages/uniworx/de.msg | 24 +- src/Audit.hs | 32 +-- src/Foundation.hs | 11 + src/Handler/Course.hs | 28 +-- src/Handler/Exam.hs | 234 +++++++++++++++++- src/Handler/Sheet.hs | 11 +- src/Handler/Submission.hs | 15 +- src/Handler/Tutorial.hs | 11 +- src/Handler/Utils/Invitations.hs | 84 ++++--- src/Import/NoModel.hs | 2 +- ...nvitationNotRegisteredWithoutCourse.hamlet | 5 + ...ionInvitationRegisteredWithoutField.hamlet | 5 + 12 files changed, 371 insertions(+), 91 deletions(-) create mode 100644 templates/messages/examRegistrationInvitationNotRegisteredWithoutCourse.hamlet create mode 100644 templates/messages/examRegistrationInvitationRegisteredWithoutField.hamlet diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 563aede8a..7ee1af4aa 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -668,6 +668,8 @@ MailSubjectTutorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand tutn@Tuto MailSubjectExamCorrectorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand examn@ExamName: [#{tid}-#{ssh}-#{csh}] Einladung zum Korrektor für #{examn} +MailSubjectExamRegistrationInvitation tid@TermId ssh@SchoolId csh@CourseShorthand examn@ExamName: [#{tid}-#{ssh}-#{csh}] Einladung zum Teilnehmer für #{examn} + MailSubjectSubmissionUserInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{tid}-#{ssh}-#{csh}] Einladung zu einer Abgabe für #{shn} SheetGrading: Bewertung @@ -879,6 +881,7 @@ MenuExamList: Klausuren MenuExamNew: Neue Klausur anlegen MenuExamEdit: Bearbeiten MenuExamUsers: Teilnehmer +MenuExamAddMembers: Klausurteilnehmer hinzufügen AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate schlagen immer fehl. Abgewählte Prädikate werden also nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. Diese Einstellungen gelten nur temporär bis Ihre Sitzung abgelaufen ist, d.h. bis ihr Browser-Cookie abgelaufen ist. Durch Abwahl von Prädikaten kann man sich höchstens temporär aussperren. AuthPredsActive: Aktive Authorisierungsprädikate @@ -953,7 +956,7 @@ CourseLecInviteExplanation: Sie wurden eingeladen, Verwalter für einen Kurs zu CourseParticipantInviteHeading courseName@Text: Einladung zum Kursteilnahmer für #{courseName} CourseParticipantInviteExplanation: Sie wurden eingeladen, an einem Kurs teilzunehmen. -CourseParticipantEnlistDirectly: Bekannte Teilnehmer sofort als Teilnehmer eintragen +CourseParticipantEnlistDirectly: Bekannte Nutzer sofort als Teilnehmer eintragen CourseParticipantInviteField: Einzuladende EMail Adressen CourseParticipantInvitationAccepted courseName@Text: Sie wurden als Teilnehmer für #{courseName} eingetragen @@ -970,10 +973,15 @@ TutorInviteHeading tutn@TutorialName: Einladung zum Tutor für #{tutn} TutorInviteExplanation: Sie wurden eingeladen, Tutor zu sein. ExamCorrectorInvitationAccepted examn@ExamName: Sie wurden als Korrektor für #{examn} eingetragen -ExamCorrectorInvitationDeclined examn@ExamName: Sie haben die Einladung, Korrektor für #{examn} zu werden, abgelehnt +ExamCorrectorInvitationDeclined examn@ExamName: Sie haben die Einladung, Korrektor für #{examn} zu werden, abgelehnt ExamCorrectorInviteHeading examn@ExamName: Einladung zum Korrektor für #{examn} ExamCorrectorInviteExplanation: Sie wurden eingeladen, Klausur-Korrektor zu sein. +ExamRegistrationInvitationAccepted examn@ExamName: Sie wurden als Teilnehmer für #{examn} eingetragen +ExamRegistrationInvitationDeclined examn@ExamName: Sie haben die Einladung, Teilnehmer für #{examn} zu werden, abgelehnt +ExamRegistrationInviteHeading examn@ExamName: Einladung zum Teilnehmer für #{examn} +ExamRegistrationInviteExplanation: Sie wurden eingeladen, Klausurteilnehmer zu sein. + SubmissionUserInvitationAccepted shn@SheetName: Sie wurden als Mitabgebende(r) für eine Abgabe zu #{shn} eingetragen SubmissionUserInvitationDeclined shn@SheetName: Sie haben die Einladung, Mitabgebende(r) für #{shn} zu werden, abgelehnt SubmissionUserInviteHeading shn@SheetName: Einladung zu einer Abgabe für #{shn} @@ -1070,6 +1078,18 @@ CourseParticipantsRegisteredWithoutField n@Int: #{n} Teilnehmer #{pluralDE n "wu CourseParticipantsRegistered n@Int: #{n} Teilnehmer erfolgreich angemeldet CourseParticipantsRegisterHeading: Kursteilnehmer hinzufügen +ExamRegistrationAndCourseParticipantsRegistered n@Int: #{n} Teilnehmer #{pluralDE n "wurde" "wurden"} sowohl zum Kurs, als auch zur Klausur angemeldet +ExamRegistrationNotRegisteredWithoutCourse n@Int: #{n} Teilnehmer #{pluralDE n "wurde" "wurden"} nicht zur Klausur angemeldet, da #{pluralDE n "er" "sie"} nicht zum Kurs angemeldet #{pluralDE n "ist" "sind"} +ExamRegistrationRegisteredWithoutField n@Int: #{n} Teilnehmer #{pluralDE n "wurde" "wurden"} sowohl zur Klausur, als auch #{pluralDE n "ohne assoziiertes Hauptfach" "ohne assoziierte Hauptfächer"} zum Kurs angemeldet, da #{pluralDE n "kein eindeutiges Hauptfach bestimmt werden konnte" "keine eindeutigen Hauptfächer bestimmt werden konnten"} +ExamRegistrationParticipantsRegistered n@Int: #{n} Teilnehmer #{pluralDE n "wurde" "wurden"} zur Klausur angemeldet +ExamRegistrationInviteDeadline: Einladung nur gültig bis +ExamRegistrationEnlistDirectly: Bekannte Nutzer sofort als Teilnehmer eintragen +ExamRegistrationRegisterCourse: Nutzer auch zum Kurs anmelden +ExamRegistrationRegisterCourseTip: Nutzer, die keine Kursteilnehmer sind, werden sonst nicht zur Klausur angemeldet. +ExamRegistrationInviteField: Einzuladende EMail Addressen +ExamParticipantsRegisterHeading: Klausurteilnehmer hinzufügen +ExamParticipantsInvited n@Int: #{n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt + ExamName: Name ExamTime: Termin ExamsHeading: Klausuren diff --git a/src/Audit.hs b/src/Audit.hs index a3c7d623a..8a058485c 100644 --- a/src/Audit.hs +++ b/src/Audit.hs @@ -43,16 +43,18 @@ data AuditException instance Exception AuditException -audit :: ( AuthId site ~ Key User - , AuthEntity site ~ User - , IsSqlBackend (YesodPersistBackend site) - , SqlBackendCanWrite (YesodPersistBackend site) - , HasInstanceID site InstanceId - , YesodAuthPersist site +audit :: ( AuthId (HandlerSite m) ~ Key User + , AuthEntity (HandlerSite m) ~ User + , IsSqlBackend (YesodPersistBackend (HandlerSite m)) + , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m)) + , HasInstanceID (HandlerSite m) InstanceId + , YesodAuthPersist (HandlerSite m) + , MonadHandler m + , MonadCatch m ) => Transaction -- ^ Transaction to record -> [UserId] -- ^ Affected users - -> YesodDB site () + -> ReaderT (YesodPersistBackend (HandlerSite m)) m () -- ^ Log a transaction using information available from `HandlerT`: -- -- - `transactionLogTime` is now @@ -71,14 +73,16 @@ audit (toJSON -> transactionLogInfo) affected = do affectedUsers <- forM affected $ \uid' -> maybe (throwM $ AuditUserNotFound uid') (return . userIdent) =<< get uid' insertMany_ $ map (TransactionLogAffected tlId) affectedUsers -audit' :: ( AuthId site ~ Key User - , AuthEntity site ~ User - , IsSqlBackend (YesodPersistBackend site) - , SqlBackendCanWrite (YesodPersistBackend site) - , HasInstanceID site InstanceId - , YesodAuthPersist site +audit' :: ( AuthId (HandlerSite m) ~ Key User + , AuthEntity (HandlerSite m) ~ User + , IsSqlBackend (YesodPersistBackend (HandlerSite m)) + , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m)) + , HasInstanceID (HandlerSite m) InstanceId + , YesodAuthPersist (HandlerSite m) + , MonadHandler m + , MonadCatch m ) => Transaction -- ^ Transaction to record - -> YesodDB site () + -> ReaderT (YesodPersistBackend (HandlerSite m)) m () -- ^ Special case of `audit` for when there are no affected users audit' = flip audit [] diff --git a/src/Foundation.hs b/src/Foundation.hs index 3233cda52..44a4ad4d7 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1527,6 +1527,7 @@ instance YesodBreadcrumbs UniWorX where breadcrumb (CExamR tid ssh csh examn EShowR) = return (original examn, Just $ CourseR tid ssh csh CExamListR) breadcrumb (CExamR tid ssh csh examn EEditR) = return ("Bearbeiten", Just $ CExamR tid ssh csh examn EShowR) breadcrumb (CExamR tid ssh csh examn EUsersR) = return ("Teilnehmer", Just $ CExamR tid ssh csh examn EShowR) + breadcrumb (CExamR tid ssh csh examn EAddUserR) = return ("Klausurteilnehmer hinzufügen", Just $ CExamR tid ssh csh examn EUsersR) breadcrumb (CTutorialR tid ssh csh tutn TUsersR) = return (original tutn, Just $ CourseR tid ssh csh CTutorialListR) breadcrumb (CTutorialR tid ssh csh tutn TEditR) = return ("Bearbeiten", Just $ CTutorialR tid ssh csh tutn TUsersR) @@ -2219,6 +2220,16 @@ pageActions (CExamR tid ssh csh examn EShowR) = , menuItemAccessCallback' = return True } ] +pageActions (CExamR tid ssh csh examn EUsersR) = + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuExamAddMembers + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CExamR tid ssh csh examn EAddUserR + , menuItemModal = True + , menuItemAccessCallback' = return True + } + ] pageActions (CSheetR tid ssh csh shn SShowR) = [ MenuItem { menuItemType = PageActionPrime diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 141824f9d..3c3e40366 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -794,8 +794,8 @@ lecturerInvitationConfig = InvitationConfig{..} invitationResolveFor = do Just (CourseR tid csh ssh CLecInviteR) <- getCurrentRoute getKeyBy404 $ TermSchoolCourseShort tid csh ssh - invitationSubject Course{..} _ = return . SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand - invitationHeading Course{..} _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName + invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand + invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|] invitationTokenConfig _ _ = do itAuthority <- liftHandlerT requireAuthId @@ -805,12 +805,13 @@ lecturerInvitationConfig = InvitationConfig{..} Nothing -> areq (selectField optionsFinite) lFs Nothing Just lType -> aforced (selectField optionsFinite) lFs lType where - toJunction jLecturerType = JunctionLecturer{..} + toJunction jLecturerType = (JunctionLecturer{..}, ()) lFs = fslI MsgLecturerType & setTooltip MsgCourseLecturerRightsIdentical - invitationSuccessMsg Course{..} (Entity _ Lecturer{..}) = do + invitationInsertHook _ _ _ _ = id + invitationSuccessMsg (Entity _ Course{..}) (Entity _ Lecturer{..}) = do MsgRenderer mr <- getMsgRenderer return . SomeMessage $ MsgLecturerInvitationAccepted (mr lecturerType) courseShorthand - invitationUltDest Course{..} _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR + invitationUltDest (Entity _ Course{..}) _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR data CourseForm = CourseForm @@ -1537,8 +1538,6 @@ instance IsInvitableJunction CourseParticipant where (\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField)) (\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField) -> CourseParticipant{..}) - ephemeralInvitation = Just (iso (const InvDBDataParticipant) (const ())) - instance ToJSON (InvitableJunction CourseParticipant) where toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } @@ -1564,23 +1563,22 @@ participantInvitationConfig = InvitationConfig{..} invitationResolveFor = do Just (CourseR tid csh ssh CInviteR) <- getCurrentRoute getKeyBy404 $ TermSchoolCourseShort tid csh ssh - invitationSubject Course{..} _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand - invitationHeading Course{..} _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName + invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand + invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|] - -- Keine besonderen Einschränkungen beim Einlösen der Token - -- ACHTUNG: Mit einem Token könnten sich deshalb mehrere Benutzer anmelden! invitationTokenConfig _ _ = do itAuthority <- liftHandlerT requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized - invitationForm Course{..} _ uid = hoistAForm lift . wFormToAForm $ do + invitationForm (Entity _ Course{..}) _ uid = hoistAForm lift . wFormToAForm $ do now <- liftIO getCurrentTime studyFeatures <- wreq (studyFeaturesPrimaryFieldFor False [] $ Just uid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTooltip) Nothing - return $ JunctionParticipant <$> pure now <*> studyFeatures - invitationSuccessMsg Course{..} _ = + return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures + invitationInsertHook _ _ _ _ = id + invitationSuccessMsg (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName) - invitationUltDest Course{..} _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR + invitationUltDest (Entity _ Course{..}) _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR data AddRecipientsResult = AddRecipientsResult { aurAlreadyRegistered diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs index ee7d96bed..d9c0ab776 100644 --- a/src/Handler/Exam.hs +++ b/src/Handler/Exam.hs @@ -2,7 +2,7 @@ module Handler.Exam where -import Import +import Import hiding (Option(..)) import Handler.Utils import Handler.Utils.Exam @@ -32,8 +32,12 @@ import Text.Blaze.Html.Renderer.String (renderHtml) import qualified Data.CaseInsensitive as CI import qualified Control.Monad.State.Class as State +import Control.Monad.Trans.Writer (WriterT, execWriterT) +import Control.Monad.Error.Class (MonadError(..)) import Control.Arrow (Kleisli(..)) +import Data.Semigroup (Option(..)) + import qualified Data.Csv as Csv import qualified Data.Conduit.List as C @@ -42,6 +46,8 @@ import Numeric.Lens (integral) import Database.Persist.Sql (deleteWhereCount, updateWhereCount) +import Generics.Deriving.Monoid + -- Dedicated ExamRegistrationButton @@ -148,20 +154,21 @@ examCorrectorInvitationConfig = InvitationConfig{..} invitationResolveFor = do Just (CExamR tid csh ssh examn ECInviteR) <- getCurrentRoute fetchExamId tid csh ssh examn - invitationSubject Exam{..} _ = do + invitationSubject (Entity _ Exam{..}) _ = do Course{..} <- get404 examCourse return . SomeMessage $ MsgMailSubjectExamCorrectorInvitation courseTerm courseSchool courseShorthand examName - invitationHeading Exam{..} _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName + invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|] invitationTokenConfig _ _ = do itAuthority <- liftHandlerT requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized - invitationForm _ _ _ = pure JunctionExamCorrector - invitationSuccessMsg Exam{..} _ = return . SomeMessage $ MsgExamCorrectorInvitationAccepted examName - invitationUltDest Exam{..} _ = do + invitationForm _ _ _ = pure (JunctionExamCorrector, ()) + invitationInsertHook _ _ _ _ = id + invitationSuccessMsg (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInvitationAccepted examName + invitationUltDest (Entity _ Exam{..}) _ = do Course{..} <- get404 examCourse - return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CExamListR + return . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName EShowR getECInviteR, postECInviteR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html getECInviteR = postECInviteR @@ -1280,13 +1287,222 @@ postEUsersR tid ssh csh examn = do $(widgetFile "exam-users") +instance IsInvitableJunction ExamRegistration where + type InvitationFor ExamRegistration = Exam + data InvitableJunction ExamRegistration = JunctionExamRegistration + { jExamRegistrationOccurrence :: Maybe ExamOccurrenceId + , jExamRegistrationTime :: UTCTime + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + data InvitationDBData ExamRegistration = InvDBDataExamRegistration + { invDBExamRegistrationOccurrence :: Maybe ExamOccurrenceId + , invDBExamRegistrationDeadline :: UTCTime + , invDBExamRegistrationCourseRegister :: Bool + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + data InvitationTokenData ExamRegistration = InvTokenDataExamRegistration + deriving (Eq, Ord, Read, Show, Generic, Typeable) + + _InvitableJunction = iso + (\ExamRegistration{..} -> (examRegistrationUser, examRegistrationExam, JunctionExamRegistration examRegistrationOccurrence examRegistrationTime)) + (\(examRegistrationUser, examRegistrationExam, JunctionExamRegistration examRegistrationOccurrence examRegistrationTime) -> ExamRegistration{..}) + +instance ToJSON (InvitableJunction ExamRegistration) where + toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } +instance FromJSON (InvitableJunction ExamRegistration) where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } + +instance ToJSON (InvitationDBData ExamRegistration) where + toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } +instance FromJSON (InvitationDBData ExamRegistration) where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } + +instance ToJSON (InvitationTokenData ExamRegistration) where + toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 } + toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 } +instance FromJSON (InvitationTokenData ExamRegistration) where + parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 } + +examRegistrationInvitationConfig :: InvitationConfig ExamRegistration +examRegistrationInvitationConfig = InvitationConfig{..} + where + invitationRoute (Entity _ Exam{..}) _ = do + Course{..} <- get404 examCourse + return $ CExamR courseTerm courseSchool courseShorthand examName EInviteR + invitationResolveFor = do + Just (CExamR tid csh ssh examn EInviteR) <- getCurrentRoute + fetchExamId tid csh ssh examn + invitationSubject (Entity _ Exam{..}) _ = do + Course{..} <- get404 examCourse + return . SomeMessage $ MsgMailSubjectExamRegistrationInvitation courseTerm courseSchool courseShorthand examName + invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInviteHeading examName + invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgExamRegistrationInviteExplanation}|] + invitationTokenConfig _ (InvDBDataExamRegistration{..}, _) = do + itAuthority <- liftHandlerT requireAuthId + let itExpiresAt = Just $ Just invDBExamRegistrationDeadline + itAddAuth + | not invDBExamRegistrationCourseRegister + = Just . PredDNF . Set.singleton . impureNonNull . Set.singleton $ PLVariable AuthCourseRegistered + | otherwise + = Nothing + itStartsAt = Nothing + return $ InvitationTokenConfig{..} + invitationRestriction _ _ = return Authorized + invitationForm (Entity _ Exam{..}) (InvDBDataExamRegistration{..}, _) uid = hoistAForm liftHandlerT . wFormToAForm $ do + isRegistered <- fmap (is _Just) . liftHandlerT . runDB . getBy $ UniqueParticipant uid examCourse + now <- liftIO getCurrentTime + + case (isRegistered, invDBExamRegistrationCourseRegister) of + (False, False) -> permissionDeniedI MsgUnauthorizedParticipant + (False, True ) -> do + fieldRes <- wreq (studyFeaturesPrimaryFieldFor False [] $ Just uid) (fslI MsgCourseStudyFeature) Nothing + return $ (JunctionExamRegistration invDBExamRegistrationOccurrence now, ) . Just <$> fieldRes + (True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing) + invitationInsertHook (Entity _ Exam{..}) _ ExamRegistration{..} mField act = do + whenIsJust mField $ + insert_ . CourseParticipant examCourse examRegistrationUser examRegistrationTime + + Course{..} <- get404 examCourse + User{..} <- get404 examRegistrationUser + let doAudit = audit' $ TransactionExamRegister (unTermKey courseTerm) (unSchoolKey courseSchool) courseShorthand examName userIdent + act <* doAudit + invitationSuccessMsg (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInvitationAccepted examName + invitationUltDest (Entity _ Exam{..}) _ = do + Course{..} <- get404 examCourse + return . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName EShowR + +data AddRecipientsResult = AddRecipientsResult + { aurAlreadyRegistered + , aurNoUniquePrimaryField + , aurNoCourseRegistration + , aurSuccess :: [UserEmail] + } deriving (Read, Show, Generic, Typeable) + +instance Monoid AddRecipientsResult where + mempty = memptydefault + mappend = mappenddefault + + getEAddUserR, postEAddUserR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html getEAddUserR = postEAddUserR -postEAddUserR = error "postEAddUserR" +postEAddUserR tid ssh csh examn = do + eEnt@(Entity eid Exam{..}) <- runDB $ fetchExam tid ssh csh examn + ((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do + now <- liftIO getCurrentTime + occurrences <- liftHandlerT . runDB $ selectList [ExamOccurrenceExam ==. eid] [] + + let + localNow = utcToLocalTime now + tomorrowEndOfDay = case localTimeToUTC (LocalTime (addDays 2 $ localDay localNow) midnight) of + LTUUnique utc' _ -> utc' + _other -> UTCTime (addDays 2 $ utctDay now) 0 + earliestDate = getOption . fmap getMin $ mconcat + [ Option $ Min <$> examStart + , foldMap (Option . Just . Min . examOccurrenceStart . entityVal) occurrences + ] + modifiedEarliestDate = earliestDate <&> \earliestDate'@(utcToLocalTime -> localEarliestDate') + -> case localTimeToUTC (LocalTime (addDays (-1) $ localDay localEarliestDate') midnight) of + LTUUnique utc' _ -> utc' + _other -> UTCTime (addDays (-1) $ utctDay earliestDate') 0 + defDeadline + | Just registerTo <- examRegisterTo + , registerTo > now + = registerTo + | Just earliestDate' <- modifiedEarliestDate + = max tomorrowEndOfDay earliestDate' + | otherwise + = tomorrowEndOfDay + + deadline <- wreq utcTimeField (fslI MsgExamRegistrationInviteDeadline) (Just defDeadline) + enlist <- wpopt checkBoxField (fslI MsgExamRegistrationEnlistDirectly) (Just False) + registerCourse <- wpopt checkBoxField (fslI MsgExamRegistrationRegisterCourse & setTooltip MsgExamRegistrationRegisterCourseTip) (Just False) + occurrence <- wopt (examOccurrenceField eid) (fslI MsgExamOccurrence) Nothing + users <- wreq (multiUserField (maybe True not $ formResultToMaybe enlist) Nothing) + (fslI MsgExamRegistrationInviteField & setTooltip MsgMultiEmailFieldTip) Nothing + return $ (,,,) <$> deadline <*> registerCourse <*> occurrence <*> users + + formResultModal usersToEnlist (CExamR tid ssh csh examn EUsersR) $ processUsers eEnt + + let heading = prependCourseTitle tid ssh csh MsgExamParticipantsRegisterHeading + + siteLayoutMsg heading $ do + setTitleI heading + wrapForm formWgt def + { formEncoding + , formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAddUserR + } + where + processUsers :: Entity Exam -> (UTCTime, Bool, Maybe ExamOccurrenceId, Set (Either UserEmail UserId)) -> WriterT [Message] Handler () + processUsers (Entity eid Exam{..}) (deadline, registerCourse, occId, users) = do + let (emails,uids) = partitionEithers $ Set.toList users + AddRecipientsResult alreadyRegistered registeredNoField noCourseRegistration registeredOneField <- lift . runDBJobs $ do + -- send Invitation eMails to unkown users + sinkInvitationsF examRegistrationInvitationConfig [(mail,eid,(InvDBDataExamRegistration occId deadline registerCourse, InvTokenDataExamRegistration)) | mail <- emails] + -- register known users + execWriterT $ mapM (registerUser examCourse eid registerCourse occId) uids + + when (not $ null emails) $ + tell . pure <=< messageI Success . MsgExamParticipantsInvited $ length emails + + when (not $ null alreadyRegistered) $ + tell . pure <=< messageI Success . MsgExamRegistrationParticipantsRegistered $ length registeredOneField + + when (not $ null registeredNoField) $ do + let modalTrigger = [whamlet|_{MsgExamRegistrationRegisteredWithoutField (length registeredNoField)}|] + modalContent = $(widgetFile "messages/examRegistrationInvitationRegisteredWithoutField") + tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent) + + when (not $ null noCourseRegistration) $ do + let modalTrigger = [whamlet|_{MsgExamRegistrationNotRegisteredWithoutCourse (length noCourseRegistration)}|] + modalContent = $(widgetFile "messages/examRegistrationInvitationNotRegisteredWithoutCourse") + tell . pure <=< messageWidget Error $ msgModal modalTrigger (Right modalContent) + + when (not $ null registeredOneField) $ + tell . pure <=< messageI Success . MsgExamRegistrationAndCourseParticipantsRegistered $ length registeredOneField + + registerUser :: CourseId -> ExamId -> Bool -> Maybe ExamOccurrenceId -> UserId -> WriterT AddRecipientsResult (YesodJobDB UniWorX) () + registerUser cid eid registerCourse occId uid = exceptT tell tell $ do + User{..} <- lift . lift $ getJust uid + now <- liftIO getCurrentTime + + let + examRegister :: YesodJobDB UniWorX () + examRegister = do + insert_ $ ExamRegistration eid uid occId now + audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent + + whenM (lift . lift . existsBy $ UniqueExamRegistration eid uid) $ + throwError $ mempty { aurAlreadyRegistered = pure userEmail } + + whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $ do + lift $ lift examRegister + throwError $ mempty { aurSuccess = pure userEmail } + + unless registerCourse $ + throwError $ mempty { aurNoCourseRegistration = pure userEmail } + + features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] [] + + let courseParticipantField + | [f] <- features = Just f + | otherwise = Nothing + + lift . lift . insert_ $ CourseParticipant + { courseParticipantCourse = cid + , courseParticipantUser = uid + , courseParticipantRegistration = now + , .. + } + lift $ lift examRegister + + return $ case courseParticipantField of + Nothing -> mempty { aurNoUniquePrimaryField = pure userEmail } + Just _ -> mempty { aurSuccess = pure userEmail } + getEInviteR, postEInviteR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html getEInviteR = postEInviteR -postEInviteR = error "postEInviteR" +postEInviteR _ _ _ _ = invitationR' examRegistrationInvitationConfig postERegisterR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html postERegisterR tid ssh csh examn = do diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 9c182bb45..858a15a42 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -902,18 +902,19 @@ correctorInvitationConfig = InvitationConfig{..} invitationResolveFor = do Just (CSheetR tid csh ssh shn SCorrInviteR) <- getCurrentRoute fetchSheetId tid csh ssh shn - invitationSubject Sheet{..} _ = do + invitationSubject (Entity _ Sheet{..}) _ = do Course{..} <- get404 sheetCourse return . SomeMessage $ MsgMailSubjectCorrectorInvitation courseTerm courseSchool courseShorthand sheetName - invitationHeading Sheet{..} _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName + invitationHeading (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|] invitationTokenConfig _ _ = do itAuthority <- liftHandlerT requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized - invitationForm _ (InvDBDataSheetCorrector load state, _) _ = pure $ JunctionSheetCorrector load state - invitationSuccessMsg Sheet{..} _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName - invitationUltDest Sheet{..} _ = do + invitationForm _ (InvDBDataSheetCorrector load state, _) _ = pure $ (JunctionSheetCorrector load state, ()) + invitationInsertHook _ _ _ _ = id + invitationSuccessMsg (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName + invitationUltDest (Entity _ Sheet{..}) _ = do Course{..} <- get404 sheetCourse return . SomeRoute $ CSheetR courseTerm courseSchool courseShorthand sheetName SShowR diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index cd367b493..3d8d4c0e8 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -93,15 +93,15 @@ submissionUserInvitationConfig = InvitationConfig{..} Just (CSubmissionR _tid _ssh _csh _shn cID SInviteR) <- getCurrentRoute subId <- decrypt cID bool notFound (return subId) =<< existsKey subId - invitationSubject Submission{..} _ = do + invitationSubject (Entity _ Submission{..}) _ = do Sheet{..} <- getJust submissionSheet Course{..} <- getJust sheetCourse return . SomeMessage $ MsgMailSubjectSubmissionUserInvitation courseTerm courseSchool courseShorthand sheetName - invitationHeading Submission{..} _ = do + invitationHeading (Entity _ Submission{..}) _ = do Sheet{..} <- getJust submissionSheet return . SomeMessage $ MsgSubmissionUserInviteHeading sheetName invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgSubmissionUserInviteExplanation}|] - invitationTokenConfig Submission{..} _ = do + invitationTokenConfig (Entity _ Submission{..}) _ = do Sheet{..} <- getJust submissionSheet Course{..} <- getJust sheetCourse itAuthority <- liftHandlerT requireAuthId @@ -110,14 +110,15 @@ submissionUserInvitationConfig = InvitationConfig{..} itStartsAt = Nothing return InvitationTokenConfig{..} invitationRestriction _ _ = return Authorized - invitationForm _ _ _ = pure JunctionSubmissionUser - invitationSuccessMsg Submission{..} _ = do + invitationForm _ _ _ = pure (JunctionSubmissionUser, ()) + invitationInsertHook _ _ _ _ = id + invitationSuccessMsg (Entity _ Submission{..}) _ = do Sheet{..} <- getJust submissionSheet return . SomeMessage $ MsgSubmissionUserInvitationAccepted sheetName - invitationUltDest Submission{..} (Entity _ SubmissionUser{..}) = do + invitationUltDest (Entity subId Submission{..}) _ = do Sheet{..} <- getJust submissionSheet Course{..} <- getJust sheetCourse - cID <- encrypt submissionUserSubmission + cID <- encrypt subId return . SomeRoute $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SubShowR diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs index 2f4123a22..395f1d44b 100644 --- a/src/Handler/Tutorial.hs +++ b/src/Handler/Tutorial.hs @@ -252,18 +252,19 @@ tutorInvitationConfig = InvitationConfig{..} invitationResolveFor = do Just (CTutorialR tid csh ssh tutn TInviteR) <- getCurrentRoute fetchTutorialId tid csh ssh tutn - invitationSubject Tutorial{..} _ = do + invitationSubject (Entity _ Tutorial{..}) _ = do Course{..} <- get404 tutorialCourse return . SomeMessage $ MsgMailSubjectTutorInvitation courseTerm courseSchool courseShorthand tutorialName - invitationHeading Tutorial{..} _ = return . SomeMessage $ MsgTutorInviteHeading tutorialName + invitationHeading (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgTutorInviteHeading tutorialName invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgTutorInviteExplanation}|] invitationTokenConfig _ _ = do itAuthority <- liftHandlerT requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized - invitationForm _ _ _ = pure JunctionTutor - invitationSuccessMsg Tutorial{..} _ = return . SomeMessage $ MsgCorrectorInvitationAccepted tutorialName - invitationUltDest Tutorial{..} _ = do + invitationForm _ _ _ = pure (JunctionTutor, ()) + invitationInsertHook _ _ _ _ = id + invitationSuccessMsg (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted tutorialName + invitationUltDest (Entity _ Tutorial{..}) _ = do Course{..} <- get404 tutorialCourse return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CTutorialListR diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs index 510da890b..2a582f6e3 100644 --- a/src/Handler/Utils/Invitations.hs +++ b/src/Handler/Utils/Invitations.hs @@ -40,6 +40,7 @@ import Data.Typeable class ( PersistRecordBackend junction (YesodPersistBackend UniWorX) , ToJSON (InvitationDBData junction), ToJSON (InvitationTokenData junction) , FromJSON (InvitationDBData junction), FromJSON (InvitationTokenData junction) + , Eq (InvitationDBData junction) , PersistRecordBackend (InvitationFor junction) (YesodPersistBackend UniWorX) , Typeable junction ) => IsInvitableJunction junction where @@ -111,30 +112,32 @@ invRef = toJSON . InvRef @junction -- | Configuration needed for creating and accepting/declining `Invitation`s -- -- It is advisable to define this once per `junction` in a global constant -data InvitationConfig junction = InvitationConfig - { invitationRoute :: Entity (InvitationFor junction) -> InvitationData junction -> YesodDB UniWorX (Route UniWorX) +data InvitationConfig junction = forall formCtx. InvitationConfig + { invitationRoute :: Entity (InvitationFor junction) -> InvitationData junction -> DB (Route UniWorX) -- ^ Which route calls `invitationR` for this kind of invitation? - , invitationResolveFor :: YesodDB UniWorX (Key (InvitationFor junction)) + , invitationResolveFor :: DB (Key (InvitationFor junction)) -- ^ Monadically resolve `InvitationFor` during `inviteR` -- -- Usually from `requireBearerToken` or `getCurrentRoute` - , invitationSubject :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX (SomeMessage UniWorX) + , invitationSubject :: Entity (InvitationFor junction) -> InvitationData junction -> DB (SomeMessage UniWorX) -- ^ Subject of the e-mail which sends the token to the user - , invitationHeading :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX (SomeMessage UniWorX) + , invitationHeading :: Entity (InvitationFor junction) -> InvitationData junction -> DB (SomeMessage UniWorX) -- ^ Heading of the page which allows the invitee to accept/decline the invitation (`invitationR` - , invitationExplanation :: InvitationFor junction -> InvitationData junction -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX) + , invitationExplanation :: Entity (InvitationFor junction) -> InvitationData junction -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX) -- ^ Explanation of what kind of invitation this is (used both in the e-mail and in `invitationR`) - , invitationTokenConfig :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX InvitationTokenConfig + , invitationTokenConfig :: Entity (InvitationFor junction) -> InvitationData junction -> DB InvitationTokenConfig -- ^ Parameters for creating the invitation token (`InvitationTokenData` is handled transparently) - , invitationRestriction :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX AuthResult + , invitationRestriction :: Entity (InvitationFor junction) -> InvitationData junction -> DB AuthResult -- ^ Additional restrictions to check before allowing an user to redeem an invitation token - , invitationForm :: InvitationFor junction -> InvitationData junction -> Key User -> AForm (YesodDB UniWorX) (InvitableJunction junction) + , invitationForm :: Entity (InvitationFor junction) -> InvitationData junction -> Key User -> AForm (YesodDB UniWorX) (InvitableJunction junction, formCtx) -- ^ Assimilate the additional data entered by the redeeming user - , invitationSuccessMsg :: InvitationFor junction -> Entity junction -> YesodDB UniWorX (SomeMessage UniWorX) + , invitationInsertHook :: forall a. Entity (InvitationFor junction) -> InvitationData junction -> junction -> formCtx -> (DB a -> DB a) + -- ^ Perform additional actions before or after insertion of the junction into the database + , invitationSuccessMsg :: Entity (InvitationFor junction) -> Entity junction -> DB (SomeMessage UniWorX) -- ^ What to tell the redeeming user after accepting the invitation - , invitationUltDest :: InvitationFor junction -> Entity junction -> YesodDB UniWorX (SomeRoute UniWorX) + , invitationUltDest :: Entity (InvitationFor junction) -> Entity junction -> DB (SomeRoute UniWorX) -- ^ Where to redirect the redeeming user after accepting the invitation - } deriving (Generic, Typeable) + } -- | Additional configuration needed for an invocation of `bearerToken` data InvitationTokenConfig = InvitationTokenConfig @@ -177,36 +180,50 @@ sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lif where determineExists :: Conduit (Invitation' junction) (YesodJobDB UniWorX) - (Either (InvitationId, InvitationData junction) (Invitation' junction)) + (Invitation' junction) determineExists | is _Just (ephemeralInvitation @junction) - = C.map Right + = C.map id | otherwise - = C.mapM $ \inp@(email, fid, dat) -> - maybe (Right inp) (Left . (, dat)) <$> getKeyBy (UniqueInvitation email (invRef @junction fid)) + = awaitForever $ \inp@(email, fid, view _InvitationData -> (dat, _)) -> do + dbEntry <- lift . getBy $ UniqueInvitation email (invRef @junction fid) + case dbEntry of + Just (Entity _ Invitation{invitationData}) + | Just dbData <- decode invitationData + , dbData == dat + -> return () + Just (Entity invId _) + -> lift (delete invId) >> yield inp + Nothing + -> yield inp + where + decode invData + = case fromJSON invData of + JSON.Success dbData -> return dbData + JSON.Error str -> fail $ "Could not decode invitationData: " <> str - sinkInvitations' :: [Either (InvitationId, InvitationData junction) (Invitation' junction)] + sinkInvitations' :: [Invitation' junction] -> YesodJobDB UniWorX () - sinkInvitations' (partitionEithers -> (existing, new)) = do + sinkInvitations' new = do when (is _Nothing (ephemeralInvitation @junction)) $ do insertMany_ $ map (\(email, fid, dat) -> Invitation email (invRef @junction fid) (toJSON $ dat ^. _invitationDBData)) new - forM_ existing $ \(iid, dat) -> update iid [ InvitationData =. toJSON (dat ^. _invitationDBData) ] + -- forM_ existing $ \(iid, oldDat) -> update iid [ InvitationData =. toJSON (dat ^. _invitationDBData) ] forM_ new $ \(jInvitee, fid, dat) -> do app <- getYesod let mr = renderMessage app $ NonEmpty.toList appLanguages ur <- getUrlRenderParams - fRec <- get404 fid + fEnt <- Entity fid <$> get404 fid jInviter <- liftHandlerT requireAuthId - route <- mapReaderT liftHandlerT $ invitationRoute (Entity fid fRec) dat - InvitationTokenConfig{..} <- mapReaderT liftHandlerT $ invitationTokenConfig fRec dat + route <- mapReaderT liftHandlerT $ invitationRoute fEnt dat + InvitationTokenConfig{..} <- mapReaderT liftHandlerT $ invitationTokenConfig fEnt dat protoToken <- bearerToken itAuthority (Just . HashSet.singleton $ urlRoute route) itAddAuth itExpiresAt itStartsAt let token = protoToken & tokenRestrict (urlRoute route) (InvitationTokenRestriction jInvitee $ dat ^. _invitationTokenData) jwt <- encodeToken token jInvitationUrl <- toTextUrl (route, [(toPathPiece GetBearer, toPathPiece jwt)]) - jInvitationSubject <- fmap mr . mapReaderT liftHandlerT $ invitationSubject fRec dat - let jInvitationExplanation = invitationExplanation fRec dat (toHtml . mr) ur + jInvitationSubject <- fmap mr . mapReaderT liftHandlerT $ invitationSubject fEnt dat + let jInvitationExplanation = invitationExplanation fEnt dat (toHtml . mr) ur queueDBJob JobInvitation{..} @@ -270,7 +287,7 @@ invitationR' InvitationConfig{..} = liftHandlerT $ do Just cRoute <- getCurrentRoute (tRoute, (dataWidget, dataEnctype), heading, explanation) <- runDB $ do - Entity fid fRec <- invitationResolveFor >>= (\k -> Entity k <$> get404 k) + fEnt@(Entity fid _) <- invitationResolveFor >>= (\k -> Entity k <$> get404 k) dbData <- case ephemeralInvitation @junction of Nothing -> do Invitation{..} <- entityVal <$> getBy404 (UniqueInvitation itEmail $ invRef @junction fid) @@ -281,9 +298,9 @@ invitationR' InvitationConfig{..} = liftHandlerT $ do let iData :: InvitationData junction iData = review _InvitationData (dbData, itData) - guardAuthResult =<< invitationRestriction fRec iData + guardAuthResult =<< invitationRestriction fEnt iData ((dataRes, dataWidget), dataEnctype) <- runFormPost . formEmbedJwtPost . renderAForm FormStandard . wFormToAForm $ do - dataRes <- aFormToWForm $ invitationForm fRec iData invitee + dataRes <- aFormToWForm $ invitationForm fEnt iData invitee btnRes <- aFormToWForm . disambiguateButtons $ combinedButtonField (BtnInviteAccept : [ BtnInviteDecline | is _Nothing $ ephemeralInvitation @junction ]) (fslI MsgInvitationAction & bool id (setTooltip MsgInvitationActionTip) (is _Nothing $ ephemeralInvitation @junction)) case btnRes of FormSuccess BtnInviteDecline -> return $ FormSuccess Nothing @@ -291,22 +308,23 @@ invitationR' InvitationConfig{..} = liftHandlerT $ do MsgRenderer mr <- getMsgRenderer ur <- getUrlRenderParams - heading <- invitationHeading fRec iData - let explanation = invitationExplanation fRec iData (toHtml . mr) ur + heading <- invitationHeading fEnt iData + let explanation = invitationExplanation fEnt iData (toHtml . mr) ur fmap (, (dataWidget, dataEnctype), heading, explanation) . formResultMaybe dataRes $ \case Nothing -> do addMessageI Info MsgInvitationDeclined deleteBy . UniqueInvitation itEmail $ invRef @junction fid return . Just $ SomeRoute HomeR - Just jData -> do - mResult <- insertUniqueEntity $ review _InvitableJunction (invitee, fid, jData) + Just (jData, formCtx) -> do + let junction = review _InvitableJunction (invitee, fid, jData) + mResult <- invitationInsertHook fEnt iData junction formCtx $ insertUniqueEntity junction case mResult of Nothing -> invalidArgsI [MsgInvitationCollision] Just res -> do deleteBy . UniqueInvitation itEmail $ invRef @junction fid - addMessageI Success =<< invitationSuccessMsg fRec res - Just <$> invitationUltDest fRec res + addMessageI Success =<< invitationSuccessMsg fEnt res + Just <$> invitationUltDest fEnt res whenIsJust tRoute redirect diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index e2805fc6e..2385d2d99 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -44,7 +44,7 @@ import Data.Ix as Import (Ix) import Data.Hashable as Import import Data.List.NonEmpty as Import (NonEmpty(..), nonEmpty) import Data.Text.Encoding.Error as Import(UnicodeException(..)) -import Data.Semigroup as Import (Semigroup) +import Data.Semigroup as Import (Semigroup, Min(..), Max(..)) import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..), Endo(..)) import Data.Binary as Import (Binary) diff --git a/templates/messages/examRegistrationInvitationNotRegisteredWithoutCourse.hamlet b/templates/messages/examRegistrationInvitationNotRegisteredWithoutCourse.hamlet new file mode 100644 index 000000000..197c4e906 --- /dev/null +++ b/templates/messages/examRegistrationInvitationNotRegisteredWithoutCourse.hamlet @@ -0,0 +1,5 @@ +

+ _{MsgExamRegistrationNotRegisteredWithoutCourse (length registeredNoField)} +
    + $forall email <- noCourseRegistration +
  • #{email} diff --git a/templates/messages/examRegistrationInvitationRegisteredWithoutField.hamlet b/templates/messages/examRegistrationInvitationRegisteredWithoutField.hamlet new file mode 100644 index 000000000..55f50ea70 --- /dev/null +++ b/templates/messages/examRegistrationInvitationRegisteredWithoutField.hamlet @@ -0,0 +1,5 @@ +

    + _{MsgExamRegistrationRegisteredWithoutField (length registeredNoField)} +
      + $forall email <- registeredNoField +
    • #{email} From a3ee6f6fa6cf90f3a4e1ef4bed6ff104412318c8 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 24 Jul 2019 18:34:33 +0200 Subject: [PATCH 11/77] fix(js): fix i18n not loading --- src/Foundation.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index 44a4ad4d7..c534d6baf 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1434,7 +1434,7 @@ siteLayout' headingOverride widget = do addScript $ StaticR bundles_js_polyfills_js addScript $ StaticR bundles_js_vendor_js addScript $ StaticR bundles_js_main_js - toWidgetHead $(juliusFile "templates/i18n.julius") + toWidget $(juliusFile "templates/i18n.julius") -- widgets $(widgetFile "default-layout") withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") From ae085e63a4603086d6cdc4625bc22f352b6eb0cf Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 24 Jul 2019 18:35:25 +0200 Subject: [PATCH 12/77] chore(release): 4.4.0 --- CHANGELOG.md | 15 +++++++++++++++ package-lock.json | 2 +- package.json | 3 +-- package.yaml | 2 +- 4 files changed, 18 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index d1fb64481..3660df080 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,21 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [4.4.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.3.0...v4.4.0) (2019-07-24) + + +### Bug Fixes + +* **exam-csv:** audit registrations/deregistrations ([a278cc5](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/a278cc5)) +* **js:** fix i18n not loading ([a3ee6f6](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/a3ee6f6)) + + +### Features + +* **exams:** implement exam registration invitations ([dd90fd0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/dd90fd0)) + + + ## [4.3.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.2.0...v4.3.0) (2019-07-24) diff --git a/package-lock.json b/package-lock.json index 569bcb96b..a25132e3e 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "4.3.0", + "version": "4.4.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 16d2764cf..cedb1dd4a 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "4.3.0", + "version": "4.4.0", "description": "", "keywords": [], "author": "", @@ -20,7 +20,6 @@ "frontend:test:watch": "karma start --conf karma.conf.js --single-run false", "frontend:build": "webpack", "frontend:build:watch": "webpack --watch", - "prerelease": "npm run test", "release": "standard-version -a", "postrelease": "git push --follow-tags origin master" }, diff --git a/package.yaml b/package.yaml index 557a87837..1acd174c5 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 4.3.0 +version: 4.4.0 dependencies: # Due to a bug in GHC 8.0.1, we block its usage From 718519fe10c38bbf36f599433d709d235259db01 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 24 Jul 2019 18:35:48 +0200 Subject: [PATCH 13/77] chore: re-enable pre-release checks --- package.json | 1 + 1 file changed, 1 insertion(+) diff --git a/package.json b/package.json index cedb1dd4a..4a1187eba 100644 --- a/package.json +++ b/package.json @@ -20,6 +20,7 @@ "frontend:test:watch": "karma start --conf karma.conf.js --single-run false", "frontend:build": "webpack", "frontend:build:watch": "webpack --watch", + "prerelease": "npm run test", "release": "standard-version -a", "postrelease": "git push --follow-tags origin master" }, From d70a9585f093c0701adf724ffe84cbaf3f1a592d Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 25 Jul 2019 00:19:09 +0200 Subject: [PATCH 14/77] feat(alerticons): allow alerts to have custom icons --- frontend/src/utils/alerts/alert-icons.js | 12 ++-- src/Foundation.hs | 9 +-- src/Handler/Admin.hs | 2 +- src/Handler/Exam.hs | 13 +--- src/Import/NoModel.hs | 6 +- src/Utils.hs | 6 +- src/Utils/Form.hs | 3 +- src/Utils/Icon.hs | 29 +++++--- src/Utils/Message.hs | 88 +++++++++++++++++++++--- templates/widgets/alerts/alerts.hamlet | 18 ++--- 10 files changed, 134 insertions(+), 52 deletions(-) diff --git a/frontend/src/utils/alerts/alert-icons.js b/frontend/src/utils/alerts/alert-icons.js index 85fe1d3aa..eb497d9bd 100644 --- a/frontend/src/utils/alerts/alert-icons.js +++ b/frontend/src/utils/alerts/alert-icons.js @@ -6,11 +6,15 @@ // https://fontawesome.com/icons export const ALERT_ICONS = { - info: '"\\f05a"', + calendarcheck: '"\\f274"', + calendartimes: '"\\f273"', checkmark: '"\\f058"', - exclamation: '"\\f06a"', - warning: '"\\f071"', cross: '"\\f00d"', - registered: '"\\f274"', deregistered: '"\\f273"', + exclamation: '"\\f06a"', + info: '"\\f05a"', + registered: '"\\f274"', + userplus: '"\\f234"', + userslash: '"\\f504"', + warning: '"\\f071"', }; diff --git a/src/Foundation.hs b/src/Foundation.hs index 8103ebfda..a2df4f68c 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -5,7 +5,7 @@ module Foundation where import Import.NoFoundation hiding (embedFile) -import qualified ClassyPrelude.Yesod as Yesod (addMessage, getHttpManager) +import qualified ClassyPrelude.Yesod as Yesod (getHttpManager) import Database.Persist.Sql (ConnectionPool, runSqlPool) import Text.Hamlet (hamletFile) @@ -1216,9 +1216,10 @@ instance Yesod UniWorX where , massInputShortcircuit ] - lift . bracketOnError getMessages (mapM_ $ uncurry Yesod.addMessage) $ \msgs -> do - Just msgs' <- return . forM msgs $ \(msgState, content) -> Message <$> fromPathPiece msgState <*> return content - addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict $ JSON.encode msgs' + lift . bracketOnError getMessages (mapM_ addMessage') $ \msgs -> do + -- @gkleen: the following line is redundant, but what does this block do anyway? + -- Just msgs' <- return . forM msgs $ \(msgState, content) -> Message <$> fromPathPiece msgState <*> return content + addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict $ JSON.encode msgs -- Since we implement `errorHandler` ourselves we don't need `defaultMessageWidget` defaultMessageWidget _title _body = error "defaultMessageWidget: undefined" diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index a2f4eafa3..7d02ee2e2 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -113,7 +113,7 @@ postAdminTestR = do formResultModal emailResult AdminTestR $ \(email, ls) -> do jId <- mapWriterT runDB $ do jId <- queueJob $ JobSendTestEmail email ls - tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] + tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] Nothing return jId writeJobCtl $ JobCtlPerform jId addMessage Warning [shamlet|Inkorrekt ausgegebener Alert|] -- For testing alert handling when short circuiting; for proper (not fallback-solution) handling always use `tell` within `formResultModal` diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs index f649c0e75..dec5b8998 100644 --- a/src/Handler/Exam.hs +++ b/src/Handler/Exam.hs @@ -1048,21 +1048,14 @@ postERegisterR tid ssh csh examn = do now <- liftIO getCurrentTime insert_ $ ExamRegistration eId uid Nothing now audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent - addMessageWidget Success [whamlet| -
      #{iconExamRegister True} -
        -
      _{MsgExamRegisteredSuccess examn} - |] + addMessageIconI Success IconExamRegisterTrue (MsgExamRegisteredSuccess examn) redirect $ CExamR tid ssh csh examn EShowR BtnExamDeregister -> do runDB $ do deleteBy $ UniqueExamRegistration eId uid audit' $ TransactionExamDeregister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent - addMessageWidget Info [whamlet| -
      #{iconExamRegister False} -
        -
      _{MsgExamDeregisteredSuccess examn} - |] -- yes, it's a success message, but it should be visually different from a positive success, since most will just note the positive green color! See discussion on commit 5f4925a4 + addMessageIconI Info IconExamRegisterFalse (MsgExamDeregisteredSuccess examn) + -- yes, it's a success message, but it should be visually different from a positive success, since most will just note the positive green color! See discussion on commit 5f4925a4 redirect $ CExamR tid ssh csh examn EShowR invalidArgs ["Register/Deregister button required"] diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index cd1bd66c2..a8be4118c 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -3,7 +3,7 @@ module Import.NoModel , MForm ) where -import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm, cons, HasHttpManager(..)) +import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, getMessages, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm, cons, HasHttpManager(..)) import Model.Types.TH.JSON as Import import Model.Types.TH.Wordlist as Import @@ -53,7 +53,7 @@ import Data.Ratio as Import ((%)) import Net.IP as Import (IP) import Database.Persist.Sql as Import (SqlReadT, SqlWriteT, fromSqlKey, toSqlKey) - + import Ldap.Client.Pool as Import import System.Random as Import (Random(..)) @@ -70,7 +70,7 @@ import Data.Time.LocalTime as Import hiding (utcToLocalTime, localTimeToUTC) import Time.Types as Import (WeekDay(..)) import Network.Mime as Import - + import Data.Aeson.TH as Import import Data.Aeson.Types as Import (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), toJSONKeyText, FromJSONKeyFunction(..), ToJSONKeyFunction(..), Value) diff --git a/src/Utils.hs b/src/Utils.hs index 11db44ba0..62d957e78 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -80,7 +80,7 @@ import Algebra.Lattice (top, bottom, (/\), (\/), BoundedJoinSemiLattice, Bounded import Data.Constraint (Dict(..)) -{- # ANN choice ("HLint: ignore Use asum" :: String) # -} +{-# ANN module ("HLint: ignore Use asum" :: String) #-} $(iconShortcuts) -- declares constants for all known icons @@ -114,6 +114,10 @@ unsupportedAuthPredicate = do unauthorizedI (UnsupportedAuthPredicate (toPathPiece tag) route) |] +-- | allows conditional attributes in hamlet via *{..} syntax +maybeAttribute :: Text -> (a -> Text) -> Maybe a -> [(Text,Text)] +maybeAttribute _ _ Nothing = [] +maybeAttribute a c (Just v) = [(a,c v)] --------------------- diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index ecbf65f1a..a888efb29 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -742,13 +742,14 @@ wformMessage = void . aFormToWForm . aformMessage formMessage :: (MonadHandler m) => Message -> MForm m (FormResult (), FieldView site) formMessage Message{..} = do + let icn = maybeAttribute "data-icon" iconJS messageIcon return (FormSuccess (), FieldView { fvLabel = mempty , fvTooltip = Nothing , fvId = idFormMessageNoinput , fvErrors = Nothing , fvRequired = False - , fvInput = [whamlet|
      #{messageContent}|] + , fvInput = [whamlet|
      #{messageContent}|] }) --------------------- diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 09299e310..4d9dd168d 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -1,6 +1,6 @@ module Utils.Icon where -import ClassyPrelude.Yesod hiding (foldlM, Proxy) +import ClassyPrelude.Yesod hiding (Proxy) import Data.Universe import Data.Char @@ -12,6 +12,8 @@ import Language.Haskell.TH import Language.Haskell.TH.Instances () import Language.Haskell.TH.Lift (deriveLift) import Instances.TH.Lift () +import Data.Aeson +import Data.Aeson.TH -- | A @Widget@ for any site; no language interpolation, etc. type WidgetSiteless = forall site. forall m. (MonadIO m, MonadThrow m, MonadBaseControl IO m) @@ -23,8 +25,10 @@ type WidgetSiteless = forall site. forall m. (MonadIO m, MonadThrow m, MonadBase ----------- -- We collect all used icons here for an overview. -- For consistency, some conditional icons are also provided, having suffix True/False --- IMPORTANT: Alert-Icons must be registered in alert-icons.js as well +--------------------------------------------------------------------------- +-- IMPORTANT: Alert-Icons must be registered in alert-icons.js as well!!! +--------------------------------------------------------------------------- data Icon = IconNew | IconOK @@ -48,7 +52,7 @@ data Icon | IconSFTHint -- for SheetFileType only | IconSFTSolution -- for SheetFileType only | IconSFTMarking -- for SheetFileType only - deriving (Eq, Enum, Bounded, Show, Read) + deriving (Eq, Ord, Enum, Bounded, Show, Read) iconText :: Icon -> Text iconText = \case @@ -75,11 +79,19 @@ iconText = \case IconSFTSolution -> "exclamation-circle" -- for SheetFileType only IconSFTMarking -> "check-circle" -- for SheetFileType only +-- | like iconText, but eliminates '-' since these are problemativ in alert-icons.js +iconJS :: Icon -> Text +iconJS = filter ('-' /=) . iconText + instance Universe Icon instance Finite Icon nullaryPathPiece ''Icon $ camelToPathPiece' 1 deriveLift ''Icon +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + } ''Icon + -- Create an icon from font-awesome without additional space icon :: Icon -> Markup icon ic = let ict = iconText ic in @@ -93,11 +105,10 @@ iconShortcuts = foldMap mkIcon (universeF :: [Icon]) where mkIcon :: Icon -> Q [Dec] mkIcon ic = do - do - iname <- newName $ over (ix 0) Data.Char.toLower $ show ic - isig <- sigD iname [t|Markup|] - idef <- valD (varP iname) (normalB [|icon ic|]) [] - return $ [isig, idef] + iname <- newName $ over (ix 0) Data.Char.toLower $ show ic + isig <- sigD iname [t|Markup|] + idef <- valD (varP iname) (normalB [|icon ic|]) [] + return [isig, idef] ---------------------- @@ -140,7 +151,7 @@ iconEnrol False = icon IconEnrolFalse iconExamRegister :: Bool -> Markup iconExamRegister True = icon IconExamRegisterTrue -iconExamRegister False = icon IconExamRegisterTrue +iconExamRegister False = icon IconExamRegisterFalse ---------------- diff --git a/src/Utils/Message.hs b/src/Utils/Message.hs index c4153b17d..4302dac79 100644 --- a/src/Utils/Message.hs +++ b/src/Utils/Message.hs @@ -1,19 +1,23 @@ module Utils.Message - ( MessageStatus(..) + ( MessageStatus(..), MessageIconStatus(..) , UnknownMessageStatus(..) + , getMessages + , addMessage',addMessageIcon, addMessageIconI -- messages with special icons (needs registering in alert-icons.js) , addMessage, addMessageI, addMessageIHamlet, addMessageFile, addMessageWidget , statusToUrgencyClass , Message(..) , messageI, messageIHamlet, messageFile, messageWidget + , encodeMessageIconStatus, decodeMessageIconStatus, decodeMessageIconStatus' ) where import Data.Universe +import Utils.Icon import Utils.PathPiece import Data.Aeson import Data.Aeson.TH -import qualified ClassyPrelude.Yesod (addMessage, addMessageI) -import ClassyPrelude.Yesod hiding (addMessage, addMessageI) +import qualified ClassyPrelude.Yesod (addMessage, addMessageI, getMessages) +import ClassyPrelude.Yesod hiding (addMessage, addMessageI, getMessages) import Text.Hamlet @@ -28,8 +32,11 @@ import Text.HTML.SanitizeXSS (sanitizeBalance) data MessageStatus = Error | Warning | Info | Success deriving (Eq, Ord, Enum, Bounded, Show, Read, Lift) + instance Universe MessageStatus instance Finite MessageStatus +instance Default MessageStatus where + def = Info deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece @@ -43,11 +50,52 @@ newtype UnknownMessageStatus = UnknownMessageStatus Text instance Exception UnknownMessageStatus +-- ms2mis :: MessageStatus -> MessageIconStatus +-- ms2mis s = def { misStatus= s} + +data MessageIconStatus = MIS { misStatus :: MessageStatus, misIcon :: Maybe Icon } + deriving (Eq, Ord, Show, Read, Lift) + +instance Default MessageIconStatus where + def = MIS { misStatus=def, misIcon=Nothing } + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''MessageIconStatus + +encodeMessageStatus :: MessageStatus -> Text +encodeMessageStatus ms = encodeMessageIconStatus $ def{ misStatus=ms } + +encodeMessageIconStatus :: MessageIconStatus -> Text +encodeMessageIconStatus = decodeUtf8 . toStrict . encode + +decodeMessageIconStatus :: Text -> Maybe MessageIconStatus +decodeMessageIconStatus = decode' . fromStrict . encodeUtf8 + +decodeMessageIconStatus' :: Text -> MessageIconStatus +decodeMessageIconStatus' t + | Just mis <- decodeMessageIconStatus t = mis + | otherwise = def + +decodeMessage :: (Text, Html) -> Message +decodeMessage (mis, msgContent) + | Just MIS{ misStatus=messageStatus, misIcon=messageIcon } <- decodeMessageIconStatus mis + = let messageContent = msgContent in Message{..} + | Just messageStatus <- fromPathPiece mis + = let messageIcon = Nothing -- legacy case, should no longer occur ($logDebug ???) + messageContent = msgContent <> "!!!" + in Message{..} + | otherwise -- should not happen, if refactored correctly ($logDebug ???) + = let messageStatus = Utils.Message.Warning + messageContent = msgContent <> "!!!!" + messageIcon = Nothing + in Message{..} + data Message = Message - { messageStatus :: MessageStatus + { messageStatus :: MessageStatus , messageContent :: Html - -- , messageIcon :: Maybe Icon + , messageIcon :: Maybe Icon } instance Eq Message where @@ -60,26 +108,39 @@ instance ToJSON Message where toJSON Message{..} = object [ "status" .= messageStatus , "content" .= renderHtml messageContent + , "icon" .= messageIcon ] instance FromJSON Message where parseJSON = withObject "Message" $ \o -> do messageStatus <- o .: "status" messageContent <- preEscapedText . sanitizeBalance <$> o .: "content" + messageIcon <- o .: "icon" return Message{..} statusToUrgencyClass :: MessageStatus -> Text statusToUrgencyClass status = "urgency__" <> toPathPiece status +addMessage' :: MonadHandler m => Message -> m () +addMessage' Message{..} = ClassyPrelude.Yesod.addMessage (encodeMessageIconStatus mis) messageContent + where mis = MIS{misStatus=messageStatus, misIcon=messageIcon} + +addMessageIcon :: MonadHandler m => MessageStatus -> Icon -> Html -> m () +addMessageIcon ms mi = ClassyPrelude.Yesod.addMessage $ encodeMessageIconStatus MIS{misStatus=ms, misIcon=Just mi} + +addMessageIconI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageStatus -> Icon -> msg -> m () +addMessageIconI ms mi = ClassyPrelude.Yesod.addMessageI $ encodeMessageIconStatus MIS{misStatus=ms, misIcon=Just mi} + addMessage :: MonadHandler m => MessageStatus -> Html -> m () -addMessage mc = ClassyPrelude.Yesod.addMessage (toPathPiece mc) +addMessage mc = ClassyPrelude.Yesod.addMessage $ encodeMessageStatus mc addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageStatus -> msg -> m () -addMessageI mc = ClassyPrelude.Yesod.addMessageI (toPathPiece mc) +addMessageI mc = ClassyPrelude.Yesod.addMessageI $ encodeMessageStatus mc messageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageStatus -> msg -> m Message messageI messageStatus msg = do messageContent <- toHtml . ($ msg) <$> getMessageRender + let messageIcon = Nothing return Message{..} addMessageIHamlet :: ( MonadHandler m @@ -88,15 +149,16 @@ addMessageIHamlet :: ( MonadHandler m ) => MessageStatus -> HtmlUrlI18n msg (Route site) -> m () addMessageIHamlet mc iHamlet = do mr <- getMessageRender - ClassyPrelude.Yesod.addMessage (toPathPiece mc) =<< withUrlRenderer (iHamlet $ toHtml . mr) + ClassyPrelude.Yesod.addMessage (encodeMessageStatus mc) =<< withUrlRenderer (iHamlet $ toHtml . mr) messageIHamlet :: ( MonadHandler m , RenderMessage (HandlerSite m) msg , HandlerSite m ~ site ) => MessageStatus -> HtmlUrlI18n msg (Route site) -> m Message -messageIHamlet mc iHamlet = do +messageIHamlet ms iHamlet = do mr <- getMessageRender - Message mc <$> withUrlRenderer (iHamlet $ toHtml . mr) + let mi = Nothing + Message ms <$> withUrlRenderer (iHamlet $ toHtml . mr) <*> pure mi addMessageFile :: MessageStatus -> FilePath -> ExpQ addMessageFile mc tPath = [e|addMessageIHamlet mc $(ihamletFile tPath)|] @@ -123,3 +185,9 @@ messageWidget :: forall m site. messageWidget mc wgt = do PageContent{pageBody} <- liftHandlerT $ widgetToPageContent wgt messageIHamlet mc (const pageBody :: HtmlUrlI18n (SomeMessage site) (Route site)) + + +getMessages :: MonadHandler m => m [Message] +getMessages = fmap decodeMessage <$> ClassyPrelude.Yesod.getMessages + + diff --git a/templates/widgets/alerts/alerts.hamlet b/templates/widgets/alerts/alerts.hamlet index 8ddc0f6cd..0dd303f8a 100644 --- a/templates/widgets/alerts/alerts.hamlet +++ b/templates/widgets/alerts/alerts.hamlet @@ -1,15 +1,15 @@ $newline never
      - $forall (status, msg) <- mmsgs - $with status2 <- bool status "info" (status == "") - -
      + $forall Message{..} <- mmsgs + $with icn <- maybeAttribute "data-icon" iconJS messageIcon +
      - #{msg} + #{messageContent} + From d838d36239833d47b250550ede26126a09d22c53 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 25 Jul 2019 07:39:18 +0200 Subject: [PATCH 15/77] chore(alert messages): minor code cleaning --- src/Utils/Message.hs | 31 ++++++++++++++----------------- 1 file changed, 14 insertions(+), 17 deletions(-) diff --git a/src/Utils/Message.hs b/src/Utils/Message.hs index 4302dac79..d72d065bf 100644 --- a/src/Utils/Message.hs +++ b/src/Utils/Message.hs @@ -1,13 +1,12 @@ module Utils.Message - ( MessageStatus(..), MessageIconStatus(..) - , UnknownMessageStatus(..) + ( MessageStatus(..) + -- , UnknownMessageStatus(..) , getMessages , addMessage',addMessageIcon, addMessageIconI -- messages with special icons (needs registering in alert-icons.js) , addMessage, addMessageI, addMessageIHamlet, addMessageFile, addMessageWidget , statusToUrgencyClass , Message(..) , messageI, messageIHamlet, messageFile, messageWidget - , encodeMessageIconStatus, decodeMessageIconStatus, decodeMessageIconStatus' ) where import Data.Universe @@ -45,13 +44,11 @@ deriveJSON defaultOptions nullaryPathPiece ''MessageStatus camelToPathPiece derivePersistField "MessageStatus" -newtype UnknownMessageStatus = UnknownMessageStatus Text +newtype UnknownMessageStatus = UnknownMessageStatus Text -- kann das weg? deriving (Eq, Ord, Read, Show, Generic, Typeable) instance Exception UnknownMessageStatus --- ms2mis :: MessageStatus -> MessageIconStatus --- ms2mis s = def { misStatus= s} data MessageIconStatus = MIS { misStatus :: MessageStatus, misIcon :: Maybe Icon } deriving (Eq, Ord, Show, Read, Lift) @@ -72,23 +69,23 @@ encodeMessageIconStatus = decodeUtf8 . toStrict . encode decodeMessageIconStatus :: Text -> Maybe MessageIconStatus decodeMessageIconStatus = decode' . fromStrict . encodeUtf8 -decodeMessageIconStatus' :: Text -> MessageIconStatus -decodeMessageIconStatus' t - | Just mis <- decodeMessageIconStatus t = mis - | otherwise = def +-- decodeMessageIconStatus' :: Text -> MessageIconStatus +-- decodeMessageIconStatus' t +-- | Just mis <- decodeMessageIconStatus t = mis +-- | otherwise = def decodeMessage :: (Text, Html) -> Message decodeMessage (mis, msgContent) | Just MIS{ misStatus=messageStatus, misIcon=messageIcon } <- decodeMessageIconStatus mis = let messageContent = msgContent in Message{..} - | Just messageStatus <- fromPathPiece mis - = let messageIcon = Nothing -- legacy case, should no longer occur ($logDebug ???) - messageContent = msgContent <> "!!!" + | Just messageStatus <- fromPathPiece mis -- should not happen + = let messageIcon = Nothing + messageContent = msgContent <> "!!" -- mark legacy case, should no longer occur ($logDebug instead ???) in Message{..} - | otherwise -- should not happen, if refactored correctly ($logDebug ???) - = let messageStatus = Utils.Message.Warning - messageContent = msgContent <> "!!!!" - messageIcon = Nothing + | otherwise -- should not happen + = let messageStatus = Utils.Message.Error + messageContent = msgContent <> "!!!" -- mark legacy case, should no longer occur ($logDebug instead ???) + messageIcon = Nothing in Message{..} From 56c2fccb84ff71163ccc22291cf42c0cea88b2de Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 25 Jul 2019 07:48:12 +0200 Subject: [PATCH 16/77] feat(corrections assignment): add convenience to table header links look ugly in table headers so as a workaround we use an icon instead for a much needed link in the corrections assignment table --- src/Utils/Icon.hs | 2 ++ templates/corrections-overview.hamlet | 6 ++++-- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 4d9dd168d..a5d0c8a92 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -45,6 +45,7 @@ data Icon | IconExamRegisterFalse | IconCommentTrue | IconCommentFalse + | IconLink | IconFileDownload | IconFileZip | IconFileCSV @@ -71,6 +72,7 @@ iconText = \case IconExamRegisterFalse -> "calendar-times" IconCommentTrue -> "comment-alt" IconCommentFalse -> "comment-slash" -- comment-alt-slash is not available for free + IconLink -> "link" IconFileDownload -> "file-download" IconFileZip -> "file-archive" IconFileCSV -> "file-csv" diff --git a/templates/corrections-overview.hamlet b/templates/corrections-overview.hamlet index 64a647387..747f99d15 100644 --- a/templates/corrections-overview.hamlet +++ b/templates/corrections-overview.hamlet @@ -56,8 +56,10 @@ $# Always iterate over orderedSheetNames for consistent sorting! Newest first, except in this table $forall shn <- orderedSheetNames - #{shn} - $# ^{simpleLinkI (SomeMessage MsgMenuCorrectors) (CSheetR tid ssh csh shn SCorrR)} + + $# Links currently look ugly in table headers; used an icon as a workaround: + ^{simpleLink (toWidget iconLink) (CSheetR tid ssh csh shn SShowR)} + #{shn} _{MsgNrSubmissionsTotal} _{MsgNrSubmissionsNotCorrected} From b2b3895aa97d19580987d4b7f845798d6603c44a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 25 Jul 2019 07:57:27 +0200 Subject: [PATCH 17/77] feat(course enrolement): show proper icons in alerts --- frontend/src/utils/alerts/alert-icons.js | 2 +- src/Handler/Course.hs | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/frontend/src/utils/alerts/alert-icons.js b/frontend/src/utils/alerts/alert-icons.js index eb497d9bd..434d98568 100644 --- a/frontend/src/utils/alerts/alert-icons.js +++ b/frontend/src/utils/alerts/alert-icons.js @@ -15,6 +15,6 @@ export const ALERT_ICONS = { info: '"\\f05a"', registered: '"\\f274"', userplus: '"\\f234"', - userslash: '"\\f504"', + userslash: '"\\f506"', warning: '"\\f071"', }; diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 141824f9d..b978c75f3 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -557,11 +557,11 @@ postCRegisterR tid ssh csh = do formResult regResult $ \(mbSfId,codeOk) -> if | isRegistered -> do runDB $ deleteBy $ UniqueParticipant aid cid - addMessageI Info MsgCourseDeregisterOk + addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk | codeOk -> do actTime <- liftIO getCurrentTime regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime mbSfId - when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk + when (isJust regOk) $ addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk | otherwise -> addMessageI Warning MsgCourseSecretWrong -- addMessage Info $ toHtml $ show regResult -- For debugging only redirect $ CourseR tid ssh csh CShowR @@ -1418,7 +1418,7 @@ postCUserR tid ssh csh uCId = do | Just (Entity pId _) <- mRegistration -> do runDB $ delete pId - addMessageI Info MsgCourseDeregisterOk + addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk redirect $ CourseR tid ssh csh CUsersR | otherwise -> invalidArgs ["User not registered"] @@ -1432,7 +1432,7 @@ postCUserR tid ssh csh uCId = do pId <- runDB . insertUnique $ CourseParticipant cid uid now primaryField case pId of Just _ -> do - addMessageI Success MsgCourseRegisterOk + addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk redirect currentRoute Nothing -> invalidArgs ["User already registered"] From 864338174a24fd53b3cfd4da5e25b5475eb92f67 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 25 Jul 2019 08:38:01 +0200 Subject: [PATCH 18/77] refactor(alert messages): custom icons without js --- frontend/src/utils/alerts/alert-icons.js | 20 -------------- frontend/src/utils/alerts/alerts.js | 9 ------- frontend/src/utils/alerts/alerts.scss | 33 ++++++++++++++++-------- src/Foundation.hs | 12 ++++++--- templates/widgets/alerts/alerts.hamlet | 16 ++++-------- 5 files changed, 35 insertions(+), 55 deletions(-) delete mode 100644 frontend/src/utils/alerts/alert-icons.js diff --git a/frontend/src/utils/alerts/alert-icons.js b/frontend/src/utils/alerts/alert-icons.js deleted file mode 100644 index 434d98568..000000000 --- a/frontend/src/utils/alerts/alert-icons.js +++ /dev/null @@ -1,20 +0,0 @@ -// -// Fontawesome icons to be used on alerts. -// -// If you want to add new icons stick to the format of the existing ones. -// They are necessary due to weird unicode conversions during transpilation. -// https://fontawesome.com/icons - -export const ALERT_ICONS = { - calendarcheck: '"\\f274"', - calendartimes: '"\\f273"', - checkmark: '"\\f058"', - cross: '"\\f00d"', - deregistered: '"\\f273"', - exclamation: '"\\f06a"', - info: '"\\f05a"', - registered: '"\\f274"', - userplus: '"\\f234"', - userslash: '"\\f506"', - warning: '"\\f071"', -}; diff --git a/frontend/src/utils/alerts/alerts.js b/frontend/src/utils/alerts/alerts.js index 4d1a1cf7a..e54f898fd 100644 --- a/frontend/src/utils/alerts/alerts.js +++ b/frontend/src/utils/alerts/alerts.js @@ -1,6 +1,5 @@ import { Utility } from '../../core/utility'; import './alerts.scss'; -import { ALERT_ICONS } from './alert-icons'; const ALERTS_INITIALIZED_CLASS = 'alerts--initialized'; const ALERTS_ELEVATED_CLASS = 'alerts--elevated'; @@ -20,7 +19,6 @@ const ALERT_AUTOCLOSING_MATCHER = '.alert-info, .alert-success'; /* * Dataset-Inputs: * - decay (data-decay): Custom time (in seconds) for this alert to stay visible - * - icon (data-icon): Custom icon (from the list in alert-icons.js) to show on the alert */ @Utility({ @@ -94,13 +92,6 @@ export class Alerts { this._toggleAlert(alertElement); }); - const customIcon = alertElement.dataset.icon; - if (customIcon && ALERT_ICONS[customIcon]) { - alertElement.style.setProperty('--alert-icon', ALERT_ICONS[customIcon]); - } else if (customIcon) { - throw new Error('Alert: Custom icon "' + customIcon + '" could not be found!'); - } - if (autoHideDelay > 0 && alertElement.matches(ALERT_AUTOCLOSING_MATCHER)) { window.setTimeout(() => this._toggleAlert(alertElement), autoHideDelay * 1000); } diff --git a/frontend/src/utils/alerts/alerts.scss b/frontend/src/utils/alerts/alerts.scss index 8beff3b70..aa2f6acdc 100644 --- a/frontend/src/utils/alerts/alerts.scss +++ b/frontend/src/utils/alerts/alerts.scss @@ -32,6 +32,10 @@ font-size: 30px; transform: translateX(-50%); } + + &:hover::before { + color: var(--color-grey-medium); + } } .alerts--elevated { @@ -68,6 +72,10 @@ .alert a { color: var(--color-lightwhite); + + &:hover { + color: var(--color-grey); + } } @keyframes slide-in-alert { @@ -124,9 +132,9 @@ z-index: 40; &::before { - content: var(--alert-icon, var(--alert-icon-default, '\f05a')); + /* content: var(--alert-icon, var(--alert-icon-default, '\f05a')); */ position: absolute; - font-family: 'Font Awesome 5 Free'; + /* font-family: 'Font Awesome 5 Free'; */ font-size: 24px; top: 50%; left: 50%; @@ -188,23 +196,26 @@ .alert-success { background-color: var(--color-success); - .alert__icon::before { - --alert-icon-default: '\f058'; - } + /* .alert__icon::before { + * --alert-icon-default: '\f058'; + * } + */ } .alert-warning { background-color: var(--color-warning); - .alert__icon::before { - --alert-icon-default: '\f06a'; - } + /* .alert__icon::before { + * --alert-icon-default: '\f06a'; + * } + */ } .alert-error { background-color: var(--color-error); - .alert__icon::before { - --alert-icon-default: '\f071'; - } + /* .alert__icon::before { + * --alert-icon-default: '\f071'; + * } + */ } diff --git a/src/Foundation.hs b/src/Foundation.hs index a2df4f68c..4f345261c 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1216,10 +1216,8 @@ instance Yesod UniWorX where , massInputShortcircuit ] - lift . bracketOnError getMessages (mapM_ addMessage') $ \msgs -> do - -- @gkleen: the following line is redundant, but what does this block do anyway? - -- Just msgs' <- return . forM msgs $ \(msgState, content) -> Message <$> fromPathPiece msgState <*> return content - addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict $ JSON.encode msgs + lift . bracketOnError getMessages (mapM_ addMessage') $ + addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict . JSON.encode -- Since we implement `errorHandler` ourselves we don't need `defaultMessageWidget` defaultMessageWidget _title _body = error "defaultMessageWidget: undefined" @@ -2839,6 +2837,12 @@ instance YesodAuth UniWorX where authHttpManager = Yesod.getHttpManager + onLogin = addMessageI Success Auth.NowLoggedIn + + onErrorHtml dest msg = do + addMessage Error $ toHtml msg + redirect dest + renderAuthMessage _ _ = Auth.germanMessage -- TODO instance YesodAuthPersist UniWorX diff --git a/templates/widgets/alerts/alerts.hamlet b/templates/widgets/alerts/alerts.hamlet index 0dd303f8a..dca147265 100644 --- a/templates/widgets/alerts/alerts.hamlet +++ b/templates/widgets/alerts/alerts.hamlet @@ -2,14 +2,8 @@ $newline never
      $forall Message{..} <- mmsgs - $with icn <- maybeAttribute "data-icon" iconJS messageIcon -
      -
      -
      -
      - #{messageContent} - +
      +
      +
      +
      + #{messageContent} From bdaa9c6ecf2bccdd2722ffea6c380ec76ceb1e2f Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 25 Jul 2019 08:49:58 +0200 Subject: [PATCH 19/77] refactor(notifications): notifications don't support custom icons --- src/Utils/Form.hs | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index a888efb29..e7ae3b654 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -741,16 +741,15 @@ wformMessage :: (MonadHandler m) => Message -> WForm m () wformMessage = void . aFormToWForm . aformMessage formMessage :: (MonadHandler m) => Message -> MForm m (FormResult (), FieldView site) -formMessage Message{..} = do - let icn = maybeAttribute "data-icon" iconJS messageIcon - return (FormSuccess (), FieldView - { fvLabel = mempty - , fvTooltip = Nothing - , fvId = idFormMessageNoinput - , fvErrors = Nothing - , fvRequired = False - , fvInput = [whamlet|
      #{messageContent}|] - }) +formMessage Message{ messageIcon = _, ..} = do -- custom icons are not currently implemented for `.notification` + return (FormSuccess (), FieldView + { fvLabel = mempty + , fvTooltip = Nothing + , fvId = idFormMessageNoinput + , fvErrors = Nothing + , fvRequired = False + , fvInput = [whamlet|
      #{messageContent}|] + }) --------------------- -- Form evaluation -- From 8833cb5090738c351b8a47af558dfcb91040cf77 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 25 Jul 2019 08:57:44 +0200 Subject: [PATCH 20/77] feat(alerts js): support custom icons in Alerts HTTP-Header --- frontend/src/utils/alerts/alerts.js | 6 +++--- src/Handler/Admin.hs | 2 +- src/Utils/Icon.hs | 13 ++++++------- 3 files changed, 10 insertions(+), 11 deletions(-) diff --git a/frontend/src/utils/alerts/alerts.js b/frontend/src/utils/alerts/alerts.js index e54f898fd..3c4eba683 100644 --- a/frontend/src/utils/alerts/alerts.js +++ b/frontend/src/utils/alerts/alerts.js @@ -137,7 +137,7 @@ export class Alerts { if (alerts) { alerts.forEach((alert) => { - const alertElement = this._createAlertElement(alert.status, alert.content); + const alertElement = this._createAlertElement(alert.status, alert.content, alert.icon === null ? undefined : alert.icon); this._element.appendChild(alertElement); this._alertElements.push(alertElement); this._initAlert(alertElement); @@ -147,7 +147,7 @@ export class Alerts { } } - _createAlertElement(type, content) { + _createAlertElement(type, content, icon = 'info-circle') { const alertElement = document.createElement('div'); alertElement.classList.add(ALERT_CLASS, 'alert-' + type); @@ -155,7 +155,7 @@ export class Alerts { alertCloser.classList.add(ALERT_CLOSER_CLASS); const alertIcon = document.createElement('div'); - alertIcon.classList.add(ALERT_ICON_CLASS); + alertIcon.classList.add(ALERT_ICON_CLASS, 'fas', 'fa-fw', 'fa-' + icon); const alertContent = document.createElement('div'); alertContent.classList.add(ALERT_CONTENT_CLASS); diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 7d02ee2e2..27fc5c809 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -113,7 +113,7 @@ postAdminTestR = do formResultModal emailResult AdminTestR $ \(email, ls) -> do jId <- mapWriterT runDB $ do jId <- queueJob $ JobSendTestEmail email ls - tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] Nothing + tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] (Just IconEmail) return jId writeJobCtl $ JobCtlPerform jId addMessage Warning [shamlet|Inkorrekt ausgegebener Alert|] -- For testing alert handling when short circuiting; for proper (not fallback-solution) handling always use `tell` within `formResultModal` diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index a5d0c8a92..582f9f35c 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -53,6 +53,7 @@ data Icon | IconSFTHint -- for SheetFileType only | IconSFTSolution -- for SheetFileType only | IconSFTMarking -- for SheetFileType only + | IconEmail deriving (Eq, Ord, Enum, Bounded, Show, Read) iconText :: Icon -> Text @@ -80,10 +81,7 @@ iconText = \case IconSFTHint -> "life-ring" -- for SheetFileType only IconSFTSolution -> "exclamation-circle" -- for SheetFileType only IconSFTMarking -> "check-circle" -- for SheetFileType only - --- | like iconText, but eliminates '-' since these are problemativ in alert-icons.js -iconJS :: Icon -> Text -iconJS = filter ('-' /=) . iconText + IconEmail -> "envelope" instance Universe Icon instance Finite Icon @@ -96,9 +94,10 @@ deriveJSON defaultOptions -- Create an icon from font-awesome without additional space icon :: Icon -> Markup -icon ic = let ict = iconText ic in - [shamlet|$newline never - |] +icon ic = [shamlet| + $newline never + + |] -- declare constats for all icons for compatibility and convenience -- "IconCourse" generates "iconCourse = icon IconCourse" From 38afa901bab462b889ea036f142022afe4b32498 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 25 Jul 2019 10:00:55 +0200 Subject: [PATCH 21/77] fix: fix merge --- src/Database/Esqueleto/Utils.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 6ddf7edd3..132a11d2c 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -141,7 +141,7 @@ mkExistsFilter :: PathPiece a -> E.SqlExpr (E.Value Bool) mkExistsFilter query row criterias | Set.null criterias = true - | otherwise = any (E.exists . query row) criterias + | otherwise = any (E.exists . query row) $ Set.toList criterias -- | Combine several filters, using logical or anyFilter :: (Foldable f) From d5be5d61ee8eb5229a6a3cfac8a695a1a0cf1b0e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 25 Jul 2019 11:47:40 +0200 Subject: [PATCH 22/77] refactor(exams): split Handler.Exams & better type for pass/fail --- messages/uniworx/de.msg | 6 +- src/Handler/Exam.hs | 1551 +----------------------- src/Handler/Exam/AddUser.hs | 154 +++ src/Handler/Exam/CorrectorInvite.hs | 80 ++ src/Handler/Exam/Edit.hs | 133 ++ src/Handler/Exam/Form.hs | 361 ++++++ src/Handler/Exam/List.hs | 60 + src/Handler/Exam/New.hs | 93 ++ src/Handler/Exam/Register.hs | 59 + src/Handler/Exam/RegistrationInvite.hs | 112 ++ src/Handler/Exam/Show.hs | 106 ++ src/Handler/Exam/Users.hs | 531 ++++++++ src/Handler/Utils/Form.hs | 33 + src/Model/Types/Exam.hs | 69 +- templates/exam-show.hamlet | 2 +- 15 files changed, 1806 insertions(+), 1544 deletions(-) create mode 100644 src/Handler/Exam/AddUser.hs create mode 100644 src/Handler/Exam/CorrectorInvite.hs create mode 100644 src/Handler/Exam/Edit.hs create mode 100644 src/Handler/Exam/Form.hs create mode 100644 src/Handler/Exam/List.hs create mode 100644 src/Handler/Exam/New.hs create mode 100644 src/Handler/Exam/Register.hs create mode 100644 src/Handler/Exam/RegistrationInvite.hs create mode 100644 src/Handler/Exam/Show.hs create mode 100644 src/Handler/Exam/Users.hs diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 7ee1af4aa..62fdc716d 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1270,4 +1270,8 @@ ExamUserCsvExceptionNoMatchingOccurrence: Raum/Termin konnte nicht eindeutig ide TableHeadingFilter: Filter TableHeadingCsvImport: CSV-Import -TableHeadingCsvExport: CSV-Export \ No newline at end of file +TableHeadingCsvExport: CSV-Export + +ExamResultAttended: Teilgenommen +ExamResultNoShow: Nicht erschienen +ExamResultVoided: Entwertet \ No newline at end of file diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs index d9c0ab776..6580c90f4 100644 --- a/src/Handler/Exam.hs +++ b/src/Handler/Exam.hs @@ -1,1538 +1,13 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Handler.Exam where - -import Import hiding (Option(..)) - -import Handler.Utils -import Handler.Utils.Exam -import Handler.Utils.Invitations -import Handler.Utils.Table.Columns -import Handler.Utils.Table.Cells -import Handler.Utils.Csv -import Jobs.Queue - -import Utils.Lens hiding (parts) - -import qualified Database.Esqueleto as E -import qualified Database.Esqueleto.Utils as E -import Database.Esqueleto.Utils.TH - -import Data.Map ((!), (!?)) -import qualified Data.Map as Map -import qualified Data.Set as Set - -import qualified Data.Text as Text -import qualified Data.Text.Lens as Text - -import Data.Aeson hiding (Result(..)) -import Text.Hamlet (ihamlet) -import Text.Blaze.Html.Renderer.String (renderHtml) - -import qualified Data.CaseInsensitive as CI - -import qualified Control.Monad.State.Class as State -import Control.Monad.Trans.Writer (WriterT, execWriterT) -import Control.Monad.Error.Class (MonadError(..)) -import Control.Arrow (Kleisli(..)) - -import Data.Semigroup (Option(..)) - -import qualified Data.Csv as Csv - -import qualified Data.Conduit.List as C - -import Numeric.Lens (integral) - -import Database.Persist.Sql (deleteWhereCount, updateWhereCount) - -import Generics.Deriving.Monoid - - - --- Dedicated ExamRegistrationButton -data ButtonExamRegister = BtnExamRegister | BtnExamDeregister - deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) -instance Universe ButtonExamRegister -instance Finite ButtonExamRegister -nullaryPathPiece ''ButtonExamRegister $ camelToPathPiece' 1 -embedRenderMessage ''UniWorX ''ButtonExamRegister id -instance Button UniWorX ButtonExamRegister where - btnClasses BtnExamRegister = [BCIsButton, BCPrimary] - btnClasses BtnExamDeregister = [BCIsButton, BCDanger] - - btnLabel BtnExamRegister = [whamlet|#{iconExamRegister True} _{MsgBtnExamRegister}|] - btnLabel BtnExamDeregister = [whamlet|#{iconExamRegister False} _{MsgBtnExamDeregister}|] - - - -getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -getCExamListR tid ssh csh = do - Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh - now <- liftIO getCurrentTime - mayCreate <- hasWriteAccessTo $ CourseR tid ssh csh CExamNewR - - let - examDBTable = DBTable{..} - where - dbtSQLQuery exam = do - E.where_ $ exam E.^. ExamCourse E.==. E.val cid - return exam - dbtRowKey = (E.^. ExamId) - dbtProj x@DBRow{ dbrOutput = Entity _ Exam{..} } = do - guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR - return x - dbtColonnade = dbColonnade . mconcat $ catMaybes - [ Just . sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> anchorCell (CExamR tid ssh csh examName EShowR) examName - , (<$ guard mayCreate) . sortable (Just "visible") (i18nCell MsgExamVisibleFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty (dateTimeCellVisible now) examVisibleFrom - , Just . sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom - , Just . sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo - , Just . sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart - ] - dbtSorting = Map.fromList - [ ("name", SortColumn $ \exam -> exam E.^. ExamName ) - , ("time", SortColumn $ \exam -> exam E.^. ExamStart ) - , ("register-from", SortColumn $ \exam -> exam E.^. ExamRegisterFrom ) - , ("register-to", SortColumn $ \exam -> exam E.^. ExamRegisterTo ) - , ("visible", SortColumn $ \exam -> exam E.^. ExamVisibleFrom ) - ] - dbtFilter = Map.empty - dbtFilterUI = const mempty - dbtStyle = def - dbtParams = def - dbtIdent :: Text - dbtIdent = "exams" - dbtCsvEncode = noCsvEncode - dbtCsvDecode = Nothing - - examDBTableValidator = def - & defaultSorting [SortAscBy "time"] - ((), examTable) <- runDB $ dbTable examDBTableValidator examDBTable - - siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamsHeading) $ do - setTitleI $ prependCourseTitle tid ssh csh MsgExamsHeading - $(widgetFile "exam-list") - - -instance IsInvitableJunction ExamCorrector where - type InvitationFor ExamCorrector = Exam - data InvitableJunction ExamCorrector = JunctionExamCorrector - deriving (Eq, Ord, Read, Show, Generic, Typeable) - data InvitationDBData ExamCorrector = InvDBDataExamCorrector - deriving (Eq, Ord, Read, Show, Generic, Typeable) - data InvitationTokenData ExamCorrector = InvTokenDataExamCorrector - deriving (Eq, Ord, Read, Show, Generic, Typeable) - - _InvitableJunction = iso - (\ExamCorrector{..} -> (examCorrectorUser, examCorrectorExam, JunctionExamCorrector)) - (\(examCorrectorUser, examCorrectorExam, JunctionExamCorrector) -> ExamCorrector{..}) - -instance ToJSON (InvitableJunction ExamCorrector) where - toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } - toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } -instance FromJSON (InvitableJunction ExamCorrector) where - parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } - -instance ToJSON (InvitationDBData ExamCorrector) where - toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } - toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } -instance FromJSON (InvitationDBData ExamCorrector) where - parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } - -instance ToJSON (InvitationTokenData ExamCorrector) where - toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 } - toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 } -instance FromJSON (InvitationTokenData ExamCorrector) where - parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 } - -examCorrectorInvitationConfig :: InvitationConfig ExamCorrector -examCorrectorInvitationConfig = InvitationConfig{..} - where - invitationRoute (Entity _ Exam{..}) _ = do - Course{..} <- get404 examCourse - return $ CExamR courseTerm courseSchool courseShorthand examName ECInviteR - invitationResolveFor = do - Just (CExamR tid csh ssh examn ECInviteR) <- getCurrentRoute - fetchExamId tid csh ssh examn - invitationSubject (Entity _ Exam{..}) _ = do - Course{..} <- get404 examCourse - return . SomeMessage $ MsgMailSubjectExamCorrectorInvitation courseTerm courseSchool courseShorthand examName - invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName - invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|] - invitationTokenConfig _ _ = do - itAuthority <- liftHandlerT requireAuthId - return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing - invitationRestriction _ _ = return Authorized - invitationForm _ _ _ = pure (JunctionExamCorrector, ()) - invitationInsertHook _ _ _ _ = id - invitationSuccessMsg (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInvitationAccepted examName - invitationUltDest (Entity _ Exam{..}) _ = do - Course{..} <- get404 examCourse - return . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName EShowR - -getECInviteR, postECInviteR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html -getECInviteR = postECInviteR -postECInviteR = invitationR examCorrectorInvitationConfig - - -data ExamForm = ExamForm - { efName :: ExamName - , efDescription :: Maybe Html - , efStart :: Maybe UTCTime - , efEnd :: Maybe UTCTime - , efVisibleFrom :: Maybe UTCTime - , efRegisterFrom :: Maybe UTCTime - , efRegisterTo :: Maybe UTCTime - , efDeregisterUntil :: Maybe UTCTime - , efPublishOccurrenceAssignments :: Maybe UTCTime - , efFinished :: Maybe UTCTime - , efClosed :: Maybe UTCTime - , efOccurrences :: Set ExamOccurrenceForm - , efShowGrades :: Bool - , efPublicStatistics :: Bool - , efGradingRule :: ExamGradingRule - , efBonusRule :: ExamBonusRule - , efOccurrenceRule :: ExamOccurrenceRule - , efCorrectors :: Set (Either UserEmail UserId) - , efExamParts :: Set ExamPartForm - } - -data ExamOccurrenceForm = ExamOccurrenceForm - { eofId :: Maybe CryptoUUIDExamOccurrence - , eofName :: ExamOccurrenceName - , eofRoom :: Text - , eofCapacity :: Natural - , eofStart :: UTCTime - , eofEnd :: Maybe UTCTime - , eofDescription :: Maybe Html - } deriving (Read, Show, Eq, Ord, Generic, Typeable) - -data ExamPartForm = ExamPartForm - { epfId :: Maybe CryptoUUIDExamPart - , epfName :: ExamPartName - , epfMaxPoints :: Maybe Points - , epfWeight :: Rational - } deriving (Read, Show, Eq, Ord, Generic, Typeable) - -makeLenses_ ''ExamForm - -deriveJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 1 - } ''ExamPartForm - -deriveJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 1 - } ''ExamOccurrenceForm - - -examForm :: Maybe ExamForm -> Form ExamForm -examForm template html = do - MsgRenderer mr <- getMsgRenderer - - flip (renderAForm FormStandard) html $ ExamForm - <$> areq ciField (fslpI MsgExamName (mr MsgExamName) & setTooltip MsgExamNameTip) (efName <$> template) - <*> (assertM (not . null . renderHtml) <$> aopt htmlField (fslpI MsgExamDescription "Html") (efDescription <$> template)) - <* aformSection MsgExamFormTimes - <*> aopt utcTimeField (fslpI MsgExamStart (mr MsgDate) & setTooltip MsgExamTimeTip) (efStart <$> template) - <*> aopt utcTimeField (fslpI MsgExamEnd (mr MsgDate) & setTooltip MsgExamTimeTip) (efEnd <$> template) - <*> aopt utcTimeField (fslpI MsgExamVisibleFrom (mr MsgDate) & setTooltip MsgExamVisibleFromTip) (efVisibleFrom <$> template) - <*> aopt utcTimeField (fslpI MsgExamRegisterFrom (mr MsgDate) & setTooltip MsgExamRegisterFromTip) (efRegisterFrom <$> template) - <*> aopt utcTimeField (fslpI MsgExamRegisterTo (mr MsgDate)) (efRegisterTo <$> template) - <*> aopt utcTimeField (fslpI MsgExamDeregisterUntil (mr MsgDate)) (efDeregisterUntil <$> template) - <*> aopt utcTimeField (fslpI MsgExamPublishOccurrenceAssignments (mr MsgDate) & setTooltip MsgExamPublishOccurrenceAssignmentsTip) (efPublishOccurrenceAssignments <$> template) - <*> aopt utcTimeField (fslpI MsgExamFinished (mr MsgDate) & setTooltip MsgExamFinishedTip) (efFinished <$> template) - <*> aopt utcTimeField (fslpI MsgExamClosed (mr MsgDate) & setTooltip MsgExamClosedTip) (efClosed <$> template) - <* aformSection MsgExamFormOccurrences - <*> examOccurrenceForm (efOccurrences <$> template) - <* aformSection MsgExamFormAutomaticFunctions - <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamShowGrades & setTooltip MsgExamShowGradesTip) (Just . efShowGrades <$> template)) - <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (Just . efPublicStatistics <$> template)) - <*> examGradingRuleForm (efGradingRule <$> template) - <*> examBonusRuleForm (efBonusRule <$> template) - <*> examOccurrenceRuleForm (efOccurrenceRule <$> template) - <* aformSection MsgExamFormCorrection - <*> examCorrectorsForm (efCorrectors <$> template) - <* aformSection MsgExamFormParts - <*> examPartsForm (efExamParts <$> template) - -examCorrectorsForm :: Maybe (Set (Either UserEmail UserId)) -> AForm Handler (Set (Either UserEmail UserId)) -examCorrectorsForm mPrev = wFormToAForm $ do - MsgRenderer mr <- getMsgRenderer - Just currentRoute <- getCurrentRoute - uid <- liftHandlerT requireAuthId - - let - miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) - miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag - - miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId]) - miAdd' nudge submitView csrf = do - (addRes, addView) <- mpreq (multiUserField False $ Just corrUserSuggestions) ("" & addName (nudge "email")) Nothing - let - addRes' - | otherwise - = addRes <&> \newDat oldDat -> if - | existing <- newDat `Set.intersection` Set.fromList oldDat - , not $ Set.null existing - -> FormFailure [mr MsgExamCorrectorAlreadyAdded] - | otherwise - -> FormSuccess $ Set.toList newDat - return (addRes', $(widgetFile "widgets/massinput/examCorrectors/add")) - - corrUserSuggestions :: E.SqlQuery (E.SqlExpr (Entity User)) - corrUserSuggestions = E.from $ \(lecturer `E.InnerJoin` course `E.InnerJoin` exam `E.InnerJoin` corrector `E.InnerJoin` corrUser) -> do - E.on $ corrUser E.^. UserId E.==. corrector E.^. ExamCorrectorUser - E.on $ corrector E.^. ExamCorrectorExam E.==. exam E.^. ExamId - E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId - E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse - E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid - return corrUser - - - miCell' :: Either UserEmail UserId -> Widget - miCell' (Left email) = - $(widgetFile "widgets/massinput/examCorrectors/cellInvitation") - miCell' (Right userId) = do - User{..} <- liftHandlerT . runDB $ get404 userId - $(widgetFile "widgets/massinput/examCorrectors/cellKnown") - - miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) () - miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examCorrectors/layout") - - fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' ("correctors" :: Text) (fslI MsgExamCorrectors & setTooltip MsgMassInputTip) False (Set.toList <$> mPrev) - -examOccurrenceForm :: Maybe (Set ExamOccurrenceForm) -> AForm Handler (Set ExamOccurrenceForm) -examOccurrenceForm prev = wFormToAForm $ do - Just currentRoute <- getCurrentRoute - let - miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) - miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag - - fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamOccurrences & setTooltip MsgMassInputTip) False $ Set.toList <$> prev - where - examOccurrenceForm' nudge mPrev csrf = do - (eofIdRes, eofIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ eofId =<< mPrev) - (eofNameRes, eofNameView) <- mpreq ciField ("" & addName (nudge "name")) (eofName <$> mPrev) - (eofRoomRes, eofRoomView) <- mpreq textField ("" & addName (nudge "room")) (eofRoom <$> mPrev) - (eofCapacityRes, eofCapacityView) <- mpreq (natFieldI MsgExamRoomCapacityNegative) ("" & addName (nudge "capacity")) (eofCapacity <$> mPrev) - (eofStartRes, eofStartView) <- mpreq utcTimeField ("" & addName (nudge "start")) (eofStart <$> mPrev) - (eofEndRes, eofEndView) <- mopt utcTimeField ("" & addName (nudge "end")) (eofEnd <$> mPrev) - (eofDescRes, eofDescView) <- mopt htmlFieldSmall ("" & addName (nudge "description")) (eofDescription <$> mPrev) - - return ( ExamOccurrenceForm - <$> eofIdRes - <*> eofNameRes - <*> eofRoomRes - <*> eofCapacityRes - <*> eofStartRes - <*> eofEndRes - <*> (assertM (not . null . renderHtml) <$> eofDescRes) - , $(widgetFile "widgets/massinput/examRooms/form") - ) - - miAdd' nudge submitView csrf = do - MsgRenderer mr <- getMsgRenderer - (res, formWidget) <- examOccurrenceForm' nudge Nothing csrf - let - addRes = res <&> \newDat (Set.fromList -> oldDat) -> if - | newDat `Set.member` oldDat -> FormFailure [mr MsgExamRoomAlreadyExists] - | otherwise -> FormSuccess $ pure newDat - return (addRes, $(widgetFile "widgets/massinput/examRooms/add")) - miCell' nudge dat = examOccurrenceForm' nudge (Just dat) - miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examRooms/layout") - miIdent' :: Text - miIdent' = "exam-occurrences" - -examPartsForm :: Maybe (Set ExamPartForm) -> AForm Handler (Set ExamPartForm) -examPartsForm prev = wFormToAForm $ do - Just currentRoute <- getCurrentRoute - let - miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) - miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag - - fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamParts & setTooltip MsgMassInputTip) False $ Set.toList <$> prev - where - examPartForm' nudge mPrev csrf = do - (epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev) - (epfNameRes, epfNameView) <- mpreq ciField ("" & addName (nudge "name")) (epfName <$> mPrev) - (epfMaxPointsRes, epfMaxPointsView) <- mopt pointsField ("" & addName (nudge "max-points")) (epfMaxPoints <$> mPrev) - (epfWeightRes, epfWeightView) <- mpreq (checkBool (>= 0) MsgExamPartWeightNegative rationalField) ("" & addName (nudge "weight")) (epfWeight <$> mPrev <|> Just 1) - - return ( ExamPartForm - <$> epfIdRes - <*> epfNameRes - <*> epfMaxPointsRes - <*> epfWeightRes - , $(widgetFile "widgets/massinput/examParts/form") - ) - - miAdd' nudge submitView csrf = do - MsgRenderer mr <- getMsgRenderer - (res, formWidget) <- examPartForm' nudge Nothing csrf - let - addRes = res <&> \newDat (Set.fromList -> oldDat) -> if - | any (((==) `on` epfName) newDat) oldDat -> FormFailure [mr MsgExamPartAlreadyExists] - | otherwise -> FormSuccess $ pure newDat - return (addRes, $(widgetFile "widgets/massinput/examParts/add")) - miCell' nudge dat = examPartForm' nudge (Just dat) - miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examParts/layout") - miIdent' :: Text - miIdent' = "exam-parts" - -examFormTemplate :: Entity Exam -> DB ExamForm -examFormTemplate (Entity eId Exam{..}) = do - parts <- selectList [ ExamPartExam ==. eId ] [] - occurrences <- selectList [ ExamOccurrenceExam ==. eId ] [] - correctors <- selectList [ ExamCorrectorExam ==. eId ] [] - invitations <- map (\(email, InvDBDataExamCorrector) -> email) <$> sourceInvitationsList eId - - parts' <- forM parts $ \(Entity pid part) -> (,) <$> encrypt pid <*> pure part - occurrences' <- forM occurrences $ \(Entity oid occ) -> (,) <$> encrypt oid <*> pure occ - - return ExamForm - { efName = examName - , efGradingRule = examGradingRule - , efBonusRule = examBonusRule - , efOccurrenceRule = examOccurrenceRule - , efVisibleFrom = examVisibleFrom - , efRegisterFrom = examRegisterFrom - , efRegisterTo = examRegisterTo - , efDeregisterUntil = examDeregisterUntil - , efPublishOccurrenceAssignments = examPublishOccurrenceAssignments - , efStart = examStart - , efEnd = examEnd - , efFinished = examFinished - , efClosed = examClosed - , efShowGrades = examShowGrades - , efPublicStatistics = examPublicStatistics - , efDescription = examDescription - , efOccurrences = Set.fromList $ do - (Just -> eofId, ExamOccurrence{..}) <- occurrences' - return ExamOccurrenceForm - { eofId - , eofName = examOccurrenceName - , eofRoom = examOccurrenceRoom - , eofCapacity = examOccurrenceCapacity - , eofStart = examOccurrenceStart - , eofEnd = examOccurrenceEnd - , eofDescription = examOccurrenceDescription - } - , efExamParts = Set.fromList $ do - (Just -> epfId, ExamPart{..}) <- parts' - return ExamPartForm - { epfId - , epfName = examPartName - , epfMaxPoints = examPartMaxPoints - , epfWeight = examPartWeight - } - , efCorrectors = Set.unions - [ Set.fromList $ map Left invitations - , Set.fromList . map Right $ do - Entity _ ExamCorrector{..} <- correctors - return examCorrectorUser - ] - } - -examTemplate :: CourseId -> DB (Maybe ExamForm) -examTemplate cid = runMaybeT $ do - newCourse <- MaybeT $ get cid - - [(Entity _ oldCourse, Entity _ oldExam)] <- lift . E.select . E.from $ \(course `E.InnerJoin` exam) -> do - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.where_ $ ( course E.^. CourseShorthand E.==. E.val (courseShorthand newCourse) - E.||. course E.^. CourseName E.==. E.val (courseName newCourse) - ) - E.&&. course E.^. CourseSchool E.==. E.val (courseSchool newCourse) - E.where_ . E.not_ . E.exists . E.from $ \exam' -> do - E.where_ $ exam' E.^. ExamCourse E.==. E.val cid - E.where_ $ exam E.^. ExamName E.==. exam' E.^. ExamName - E.where_ . E.not_ . E.isNothing $ exam E.^. ExamVisibleFrom - E.limit 1 - E.orderBy [ E.desc $ course E.^. CourseTerm, E.asc $ exam E.^. ExamVisibleFrom ] - return (course, exam) - - oldTerm <- MaybeT . get $ courseTerm oldCourse - newTerm <- MaybeT . get $ courseTerm newCourse - - let - dateOffset = over _utctDay . addDays $ (diffDays `on` termLectureEnd) newTerm oldTerm - - return ExamForm - { efName = examName oldExam - , efGradingRule = examGradingRule oldExam - , efBonusRule = examBonusRule oldExam - , efOccurrenceRule = examOccurrenceRule oldExam - , efVisibleFrom = dateOffset <$> examVisibleFrom oldExam - , efRegisterFrom = dateOffset <$> examRegisterFrom oldExam - , efRegisterTo = dateOffset <$> examRegisterTo oldExam - , efDeregisterUntil = dateOffset <$> examDeregisterUntil oldExam - , efPublishOccurrenceAssignments = dateOffset <$> examPublishOccurrenceAssignments oldExam - , efStart = dateOffset <$> examStart oldExam - , efEnd = dateOffset <$> examEnd oldExam - , efFinished = dateOffset <$> examFinished oldExam - , efClosed = dateOffset <$> examClosed oldExam - , efShowGrades = examShowGrades oldExam - , efPublicStatistics = examPublicStatistics oldExam - , efDescription = examDescription oldExam - , efOccurrences = Set.empty - , efExamParts = Set.empty - , efCorrectors = Set.empty - } - - -validateExam :: (MonadHandler m, HandlerSite m ~ UniWorX) => FormValidator ExamForm m () -validateExam = do - ExamForm{..} <- State.get - - guardValidation MsgExamRegisterToMustBeAfterRegisterFrom $ NTop efRegisterTo >= NTop efRegisterFrom - guardValidation MsgExamDeregisterUntilMustBeAfterRegisterFrom $ NTop efDeregisterUntil >= NTop efRegisterFrom - guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments . fromMaybe True $ (>=) <$> efStart <*> efPublishOccurrenceAssignments - guardValidation MsgExamEndMustBeAfterStart $ NTop efEnd >= NTop efStart - guardValidation MsgExamFinishedMustBeAfterEnd . fromMaybe True $ (>=) <$> efFinished <*> efEnd - guardValidation MsgExamFinishedMustBeAfterStart $ NTop efFinished >= NTop efStart - guardValidation MsgExamClosedMustBeAfterFinished . fromMaybe True $ (>=) <$> efClosed <*> efFinished - guardValidation MsgExamClosedMustBeAfterStart $ NTop efClosed >= NTop efStart - guardValidation MsgExamClosedMustBeAfterEnd . fromMaybe True $ (>=) <$> efClosed <*> efEnd - - forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do - guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart) - guardValidation (MsgExamOccurrenceStartMustBeAfterExamStart eofName) $ NTop (Just eofStart) >= NTop efStart - guardValidation (MsgExamOccurrenceEndMustBeBeforeExamEnd eofName) $ NTop eofEnd <= NTop efEnd - - forM_ [ (a, b) | a <- Set.toAscList efOccurrences, b <- Set.toAscList efOccurrences, b > a ] $ \(a, b) -> do - eofRange' <- formatTimeRange SelFormatDateTime (eofStart a) (eofEnd a) - - guardValidation (MsgExamOccurrenceDuplicate (eofRoom a) eofRange') $ any (\f -> f a b) - [ (/=) `on` eofRoom - , (/=) `on` eofStart - , (/=) `on` eofEnd - , (/=) `on` fmap renderHtml . eofDescription - ] - - guardValidation (MsgExamOccurrenceDuplicateName $ eofName a) $ ((/=) `on` eofName) a b - - -getCExamNewR, postCExamNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -getCExamNewR = postCExamNewR -postCExamNewR tid ssh csh = do - (cid, template) <- runDB $ do - cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - template <- examTemplate cid - return (cid, template) - - ((newExamResult, newExamWidget), newExamEnctype) <- runFormPost . validateForm validateExam $ examForm template - - formResult newExamResult $ \ExamForm{..} -> do - insertRes <- runDBJobs $ do - insertRes <- insertUnique Exam - { examName = efName - , examCourse = cid - , examGradingRule = efGradingRule - , examBonusRule = efBonusRule - , examOccurrenceRule = efOccurrenceRule - , examVisibleFrom = efVisibleFrom - , examRegisterFrom = efRegisterFrom - , examRegisterTo = efRegisterTo - , examDeregisterUntil = efDeregisterUntil - , examPublishOccurrenceAssignments = efPublishOccurrenceAssignments - , examStart = efStart - , examEnd = efEnd - , examFinished = efFinished - , examClosed = efClosed - , examShowGrades = efShowGrades - , examPublicStatistics = efPublicStatistics - , examDescription = efDescription - } - whenIsJust insertRes $ \examid -> do - insertMany_ - [ ExamPart{..} - | ExamPartForm{..} <- Set.toList efExamParts - , let examPartExam = examid - examPartName = epfName - examPartMaxPoints = epfMaxPoints - examPartWeight = epfWeight - ] - - insertMany_ - [ ExamOccurrence{..} - | ExamOccurrenceForm{..} <- Set.toList efOccurrences - , let examOccurrenceExam = examid - examOccurrenceName = eofName - examOccurrenceRoom = eofRoom - examOccurrenceCapacity = eofCapacity - examOccurrenceStart = eofStart - examOccurrenceEnd = eofEnd - examOccurrenceDescription = eofDescription - ] - - let (invites, adds) = partitionEithers $ Set.toList efCorrectors - insertMany_ [ ExamCorrector{..} - | examCorrectorUser <- adds - , let examCorrectorExam = examid - ] - sinkInvitationsF examCorrectorInvitationConfig $ map (, examid, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites - return insertRes - case insertRes of - Nothing -> addMessageI Error $ MsgExamNameTaken efName - Just _ -> do - addMessageI Success $ MsgExamCreated efName - redirect $ CourseR tid ssh csh CExamListR - - let heading = prependCourseTitle tid ssh csh MsgExamNew - - siteLayoutMsg heading $ do - setTitleI heading - let - newExamForm = wrapForm newExamWidget def - { formMethod = POST - , formAction = Just . SomeRoute $ CourseR tid ssh csh CExamNewR - , formEncoding = newExamEnctype - } - $(widgetFile "exam-new") - -getEEditR, postEEditR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html -getEEditR = postEEditR -postEEditR tid ssh csh examn = do - (cid, eId, template) <- runDB $ do - (cid, exam@(Entity eId _)) <- fetchCourseIdExam tid ssh csh examn - - template <- examFormTemplate exam - - return (cid, eId, template) - - ((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm validateExam . examForm $ Just template - - formResult editExamResult $ \ExamForm{..} -> do - insertRes <- runDBJobs $ do - insertRes <- myReplaceUnique eId Exam - { examCourse = cid - , examName = efName - , examGradingRule = efGradingRule - , examBonusRule = efBonusRule - , examOccurrenceRule = efOccurrenceRule - , examVisibleFrom = efVisibleFrom - , examRegisterFrom = efRegisterFrom - , examRegisterTo = efRegisterTo - , examDeregisterUntil = efDeregisterUntil - , examPublishOccurrenceAssignments = efPublishOccurrenceAssignments - , examStart = efStart - , examEnd = efEnd - , examFinished = efFinished - , examClosed = efClosed - , examPublicStatistics = efPublicStatistics - , examShowGrades = efShowGrades - , examDescription = efDescription - } - - when (is _Nothing insertRes) $ do - occIds <- fmap catMaybes . forM (Set.toList efOccurrences) $ traverse decrypt . eofId - deleteWhere [ ExamOccurrenceExam ==. eId, ExamOccurrenceId /<-. occIds ] - forM_ (Set.toList efOccurrences) $ \case - ExamOccurrenceForm{ eofId = Nothing, .. } -> insert_ - ExamOccurrence - { examOccurrenceExam = eId - , examOccurrenceName = eofName - , examOccurrenceRoom = eofRoom - , examOccurrenceCapacity = eofCapacity - , examOccurrenceStart = eofStart - , examOccurrenceEnd = eofEnd - , examOccurrenceDescription = eofDescription - } - ExamOccurrenceForm{ .. } -> void . runMaybeT $ do - cID <- hoistMaybe eofId - eofId' <- decrypt cID - oldOcc <- MaybeT $ get eofId' - guard $ examOccurrenceExam oldOcc == eId - lift $ replace eofId' ExamOccurrence - { examOccurrenceExam = eId - , examOccurrenceName = eofName - , examOccurrenceRoom = eofRoom - , examOccurrenceCapacity = eofCapacity - , examOccurrenceStart = eofStart - , examOccurrenceEnd = eofEnd - , examOccurrenceDescription = eofDescription - } - - - pIds <- fmap catMaybes . forM (Set.toList efExamParts) $ traverse decrypt . epfId - deleteWhere [ ExamPartExam ==. eId, ExamPartId /<-. pIds ] - forM_ (Set.toList efExamParts) $ \case - ExamPartForm{ epfId = Nothing, .. } -> insert_ - ExamPart - { examPartExam = eId - , examPartName = epfName - , examPartMaxPoints = epfMaxPoints - , examPartWeight = epfWeight - } - ExamPartForm{ .. } -> void . runMaybeT $ do - cID <- hoistMaybe epfId - epfId' <- decrypt cID - oldPart <- MaybeT $ get epfId' - guard $ examPartExam oldPart == eId - lift $ replace epfId' ExamPart - { examPartExam = eId - , examPartName = epfName - , examPartMaxPoints = epfMaxPoints - , examPartWeight = epfWeight - } - - - let (invites, adds) = partitionEithers $ Set.toList efCorrectors - - deleteWhere [ ExamCorrectorExam ==. eId ] - insertMany_ $ map (ExamCorrector eId) adds - - deleteWhere [ InvitationFor ==. invRef @ExamCorrector eId, InvitationEmail /<-. invites ] - sinkInvitationsF examCorrectorInvitationConfig $ map (, eId, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites - - return insertRes - - case insertRes of - Just _ -> addMessageI Error $ MsgExamNameTaken efName - Nothing -> do - addMessageI Success $ MsgExamEdited efName - redirect $ CExamR tid ssh csh efName EShowR - - let heading = prependCourseTitle tid ssh csh . MsgExamEditHeading $ efName template - - siteLayoutMsg heading $ do - setTitleI heading - let - editExamForm = wrapForm editExamWidget def - { formMethod = POST - , formAction = Just . SomeRoute $ CExamR tid ssh csh examn EEditR - , formEncoding = editExamEnctype - } - $(widgetFile "exam-edit") - - -getEShowR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html -getEShowR tid ssh csh examn = do - cTime <- liftIO getCurrentTime - mUid <- maybeAuthId - - (Entity _ Exam{..}, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown) <- runDB $ do - exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn - - let examVisible = NTop (Just cTime) >= NTop examVisibleFrom - - let gradingVisible = NTop (Just cTime) >= NTop examFinished - gradingShown <- or2M (return gradingVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR - - let occurrenceAssignmentsVisible = NTop (Just cTime) >= NTop examPublishOccurrenceAssignments - occurrenceAssignmentsShown <- or2M (return occurrenceAssignmentsVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR - - parts <- selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ] - - resultsRaw <- for mUid $ \uid -> - E.select . E.from $ \examPartResult -> do - E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val uid - E.&&. examPartResult E.^. ExamPartResultExamPart `E.in_` E.valList (map entityKey parts) - return examPartResult - let results = maybe Map.empty (\rs -> Map.fromList [ (examPartResultExamPart, res) | res@(Entity _ ExamPartResult{..}) <- rs ]) resultsRaw - - result <- fmap join . for mUid $ getBy . UniqueExamResult eId - - occurrencesRaw <- E.select . E.from $ \examOccurrence -> do - E.where_ $ examOccurrence E.^. ExamOccurrenceExam E.==. E.val eId - let - registered - | Just uid <- mUid - = E.exists . E.from $ \examRegistration -> do - E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eId - E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val uid - E.&&. examRegistration E.^. ExamRegistrationOccurrence E.==. E.just (examOccurrence E.^. ExamOccurrenceId) - | otherwise = E.false - E.orderBy [E.desc registered, E.asc $ examOccurrence E.^. ExamOccurrenceStart, E.asc $ examOccurrence E.^. ExamOccurrenceRoom] - return (examOccurrence, registered) - - let occurrences = map (over _2 E.unValue) occurrencesRaw - - registered <- for mUid $ existsBy . UniqueExamRegistration eId - mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True - - occurrenceNamesShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR - - return (exam, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown) - - let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences - registerWidget - | Just isRegistered <- registered - , mayRegister = Just $ do - (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered - [whamlet| -

      - $if isRegistered - _{MsgExamRegistered} - $else - _{MsgExamNotRegistered} - |] - wrapForm examRegisterForm def - { formAction = Just . SomeRoute $ CExamR tid ssh csh examName ERegisterR - , formEncoding = examRegisterEnctype - , formSubmit = FormNoSubmit - } - | fromMaybe False registered = Just [whamlet|_{MsgExamRegistered}|] - | otherwise = Nothing - - let heading = prependCourseTitle tid ssh csh $ CI.original examName - - siteLayoutMsg heading $ do - setTitleI heading - let - gradingKeyW :: [Points] -> Widget - gradingKeyW bounds - = let boundWidgets :: [Widget] - boundWidgets = toWidget . (pack :: String -> Text) . showFixed True <$> 0 : bounds - grades :: [ExamGrade] - grades = universeF - in $(widgetFile "widgets/gradingKey") - - examBonusW :: ExamBonusRule -> Widget - examBonusW bonusRule = $(widgetFile "widgets/bonusRule") - $(widgetFile "exam-show") - -type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity CourseParticipant)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)))) -type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence), Maybe (Entity StudyFeatures), Maybe (Entity StudyDegree), Maybe (Entity StudyTerms)) - -instance HasEntity ExamUserTableData User where - hasEntity = _dbrOutput . _2 - -instance HasUser ExamUserTableData where - hasUser = _dbrOutput . _2 . _entityVal - -_userTableOccurrence :: Lens' ExamUserTableData (Maybe (Entity ExamOccurrence)) -_userTableOccurrence = _dbrOutput . _3 - -queryUser :: ExamUserTableExpr -> E.SqlExpr (Entity User) -queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) - -queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures)) -queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3) - -queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration) -queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) - -queryExamOccurrence :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamOccurrence)) -queryExamOccurrence = $(sqlLOJproj 3 2) - -queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree)) -queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3) - -queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms)) -queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3) - -resultExamRegistration :: Lens' ExamUserTableData (Entity ExamRegistration) -resultExamRegistration = _dbrOutput . _1 - -resultUser :: Lens' ExamUserTableData (Entity User) -resultUser = _dbrOutput . _2 - -resultStudyFeatures :: Traversal' ExamUserTableData (Entity StudyFeatures) -resultStudyFeatures = _dbrOutput . _4 . _Just - -resultStudyDegree :: Traversal' ExamUserTableData (Entity StudyDegree) -resultStudyDegree = _dbrOutput . _5 . _Just - -resultStudyField :: Traversal' ExamUserTableData (Entity StudyTerms) -resultStudyField = _dbrOutput . _6 . _Just - -resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence) -resultExamOccurrence = _dbrOutput . _3 . _Just - -data ExamUserTableCsv = ExamUserTableCsv - { csvEUserSurname :: Maybe Text - , csvEUserName :: Maybe Text - , csvEUserMatriculation :: Maybe Text - , csvEUserField :: Maybe Text - , csvEUserDegree :: Maybe Text - , csvEUserSemester :: Maybe Int - , csvEUserOccurrence :: Maybe (CI Text) - , csvEUserExercisePoints :: Maybe Points - , csvEUserExercisePasses :: Maybe Int - , csvEUserExercisePointsMax :: Maybe Points - , csvEUserExercisePassesMax :: Maybe Int - } - deriving (Generic) - -examUserTableCsvOptions :: Csv.Options -examUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3 } - -instance ToNamedRecord ExamUserTableCsv where - toNamedRecord = Csv.genericToNamedRecord examUserTableCsvOptions - -instance FromNamedRecord ExamUserTableCsv where - parseNamedRecord = Csv.genericParseNamedRecord examUserTableCsvOptions - -instance DefaultOrdered ExamUserTableCsv where - headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions - -instance CsvColumnsExplained ExamUserTableCsv where - csvColumnsExplanations = genericCsvColumnsExplanations examUserTableCsvOptions $ Map.fromList - [ ('csvEUserSurname , MsgCsvColumnExamUserSurname ) - , ('csvEUserName , MsgCsvColumnExamUserName ) - , ('csvEUserMatriculation , MsgCsvColumnExamUserMatriculation ) - , ('csvEUserField , MsgCsvColumnExamUserField ) - , ('csvEUserDegree , MsgCsvColumnExamUserDegree ) - , ('csvEUserSemester , MsgCsvColumnExamUserSemester ) - , ('csvEUserOccurrence , MsgCsvColumnExamUserOccurrence ) - , ('csvEUserExercisePoints , MsgCsvColumnExamUserExercisePoints ) - , ('csvEUserExercisePasses , MsgCsvColumnExamUserExercisePasses ) - , ('csvEUserExercisePointsMax, MsgCsvColumnExamUserExercisePointsMax ) - , ('csvEUserExercisePassesMax, MsgCsvColumnExamUserExercisePassesMax ) - ] - -data ExamUserAction = ExamUserDeregister - | ExamUserAssignOccurrence - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) - -instance Universe ExamUserAction -instance Finite ExamUserAction -nullaryPathPiece ''ExamUserAction $ camelToPathPiece' 2 -embedRenderMessage ''UniWorX ''ExamUserAction id - -data ExamUserActionData = ExamUserDeregisterData - | ExamUserAssignOccurrenceData (Maybe ExamOccurrenceId) - -data ExamUserCsvActionClass - = ExamUserCsvCourseRegister - | ExamUserCsvRegister - | ExamUserCsvAssignOccurrence - | ExamUserCsvSetCourseField - | ExamUserCsvDeregister - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) -embedRenderMessage ''UniWorX ''ExamUserCsvActionClass id - -data ExamUserCsvAction - = ExamUserCsvCourseRegisterData - { examUserCsvActUser :: UserId - , examUserCsvActCourseField :: Maybe StudyFeaturesId - , examUserCsvActOccurrence :: Maybe ExamOccurrenceId - } - | ExamUserCsvRegisterData - { examUserCsvActUser :: UserId - , examUserCsvActOccurrence :: Maybe ExamOccurrenceId - } - | ExamUserCsvAssignOccurrenceData - { examUserCsvActRegistration :: ExamRegistrationId - , examUserCsvActOccurrence :: Maybe ExamOccurrenceId - } - | ExamUserCsvSetCourseFieldData - { examUserCsvActCourseParticipant :: CourseParticipantId - , examUserCsvActCourseField :: Maybe StudyFeaturesId - } - | ExamUserCsvDeregisterData - { examUserCsvActRegistration :: ExamRegistrationId - } - deriving (Eq, Ord, Read, Show, Generic, Typeable) -deriveJSON defaultOptions - { constructorTagModifier = over Text.packed $ Text.intercalate "-" . map Text.toLower . drop 3 . dropEnd 1 . splitCamel - , fieldLabelModifier = camelToPathPiece' 3 - , sumEncoding = TaggedObject "action" "data" - } ''ExamUserCsvAction - -data ExamUserCsvException - = ExamUserCsvExceptionNoMatchingUser - | ExamUserCsvExceptionNoMatchingStudyFeatures - | ExamUserCsvExceptionNoMatchingOccurrence - deriving (Show, Generic, Typeable) - -instance Exception ExamUserCsvException - -embedRenderMessage ''UniWorX ''ExamUserCsvException id - -getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html -getEUsersR = postEUsersR -postEUsersR tid ssh csh examn = do - (registrationResult, examUsersTable) <- runDB $ do - exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn - bonus <- examBonus exam - - let - allBoni = (mappend <$> normalSummary <*> bonusSummary) $ fold bonus - showPasses = numSheetsPasses allBoni /= 0 - showPoints = getSum (numSheetsPoints allBoni) /= 0 - - let - examUsersDBTable = DBTable{..} - where - dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField))) = do - E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField - E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree - E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField) - E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse) - E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId) - E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid) - E.&&. occurrence E.?. ExamOccurrenceId E.==. examRegistration E.^. ExamRegistrationOccurrence - E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId - E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid - return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField) - dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId) - dbtProj = return - dbtColonnade = mconcat $ catMaybes - [ pure $ dbSelect (applying _2) id $ return . view (resultExamRegistration . _entityKey) - , pure $ colUserNameLink (CourseR tid ssh csh . CUserR) - , pure colUserMatriclenr - , pure $ colField resultStudyField - , pure $ colDegreeShort resultStudyDegree - , pure $ colFeaturesSemester resultStudyFeatures - , pure $ sortable (Just "occurrence") (i18nCell MsgExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence - , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do - SheetGradeSummary{achievedPasses} <- examBonusAchieved uid bonus - SheetGradeSummary{numSheetsPasses} <- examBonusPossible uid bonus - return $ propCell (getSum achievedPasses) (getSum numSheetsPasses) - , guardOn showPoints $ sortable Nothing (i18nCell MsgAchievedPoints) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do - SheetGradeSummary{achievedPoints} <- examBonusAchieved uid bonus - SheetGradeSummary{sumSheetsPoints} <- examBonusPossible uid bonus - return $ propCell (getSum achievedPoints) (getSum sumSheetsPoints) - ] - dbtSorting = Map.fromList - [ sortUserNameLink queryUser - , sortUserSurname queryUser - , sortUserDisplayName queryUser - , sortUserMatriclenr queryUser - , sortField queryStudyField - , sortDegreeShort queryStudyDegree - , sortFeaturesSemester queryStudyFeatures - , ("occurrence", SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)) - ] - dbtFilter = Map.fromList - [ fltrUserNameEmail queryUser - , fltrUserMatriclenr queryUser - , fltrField queryStudyField - , fltrDegree queryStudyDegree - , fltrFeaturesSemester queryStudyFeatures - , ("occurrence", FilterColumn . E.mkContainsFilterWith Just $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)) - ] - dbtFilterUI mPrev = mconcat - [ fltrUserNameEmailUI mPrev - , fltrUserMatriclenrUI mPrev - , fltrFieldUI mPrev - , fltrDegreeUI mPrev - , fltrFeaturesSemesterUI mPrev - , prismAForm (singletonFilter "occurrence") mPrev $ aopt textField (fslI MsgExamOccurrence) - ] - dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - dbtParams = DBParamsForm - { dbParamsFormMethod = POST - , dbParamsFormAction = Just . SomeRoute $ CExamR tid ssh csh examn EUsersR - , dbParamsFormAttrs = [] - , dbParamsFormSubmit = FormSubmit - , dbParamsFormAdditional = \csrf -> do - let - actionMap :: Map ExamUserAction (AForm Handler ExamUserActionData) - actionMap = Map.fromList - [ ( ExamUserDeregister - , pure ExamUserDeregisterData - ) - , ( ExamUserAssignOccurrence - , ExamUserAssignOccurrenceData - <$> aopt (examOccurrenceField eid) (fslI MsgExamOccurrence) (Just Nothing) - ) - ] - (res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf - let formRes = (, mempty) . First . Just <$> res - return (formRes, formWgt) - , dbParamsFormEvaluate = liftHandlerT . runFormPost - , dbParamsFormResult = id - , dbParamsFormIdent = def - } - dbtIdent :: Text - dbtIdent = "exam-users" - dbtCsvEncode :: DBTCsvEncode ExamUserTableData ExamUserTableCsv - dbtCsvEncode = DictJust . C.map $ ExamUserTableCsv - <$> view (resultUser . _entityVal . _userSurname . to Just) - <*> view (resultUser . _entityVal . _userDisplayName . to Just) - <*> view (resultUser . _entityVal . _userMatrikelnummer) - <*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just) - <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just) - <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester) - <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName) - <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPoints . _Wrapped) - <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPasses . _Wrapped . integral) - <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped) - <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral) - dbtCsvDecode = Just DBTCsvDecode - { dbtCsvRowKey = \csv -> do - uid <- lift $ view _2 <$> guessUser csv - fmap E.Value . MaybeT . getKeyBy $ UniqueExamRegistration eid uid - , dbtCsvComputeActions = \case - DBCsvDiffMissing{dbCsvOldKey} - -> yield . ExamUserCsvDeregisterData $ E.unValue dbCsvOldKey - DBCsvDiffNew{dbCsvNewKey = Just _} - -> fail "An UniqueExamRegistration could be found, but the ExamRegistrationKey is not among the existing keys" - DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do - (isPart, uid) <- lift $ guessUser dbCsvNew - if - | isPart -> do - yieldM $ ExamUserCsvRegisterData <$> pure uid <*> lookupOccurrence dbCsvNew - newFeatures <- lift $ lookupStudyFeatures dbCsvNew - Just (Entity cpId CourseParticipant{ courseParticipantField = oldFeatures }) <- lift . getBy $ UniqueParticipant uid examCourse - when (newFeatures /= oldFeatures) $ - yield $ ExamUserCsvSetCourseFieldData cpId newFeatures - | otherwise -> - yieldM $ ExamUserCsvCourseRegisterData uid <$> lookupStudyFeatures dbCsvNew <*> lookupOccurrence dbCsvNew - DBCsvDiffExisting{..} -> do - newOccurrence <- lift $ lookupOccurrence dbCsvNew - when (newOccurrence /= dbCsvOld ^? resultExamOccurrence . _entityKey) $ - yield $ ExamUserCsvAssignOccurrenceData (E.unValue dbCsvOldKey) newOccurrence - - newFeatures <- lift $ lookupStudyFeatures dbCsvNew - when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $ do - Just (Entity cpId _) <- lift . getBy . flip UniqueParticipant examCourse $ dbCsvOld ^. resultUser . _entityKey - yield $ ExamUserCsvSetCourseFieldData cpId newFeatures - , dbtCsvClassifyAction = \case - ExamUserCsvCourseRegisterData{} -> ExamUserCsvCourseRegister - ExamUserCsvRegisterData{} -> ExamUserCsvRegister - ExamUserCsvDeregisterData{} -> ExamUserCsvDeregister - ExamUserCsvAssignOccurrenceData{} -> ExamUserCsvAssignOccurrence - ExamUserCsvSetCourseFieldData{} -> ExamUserCsvSetCourseField - , dbtCsvCoarsenActionClass = \case - ExamUserCsvCourseRegister -> DBCsvActionNew - ExamUserCsvRegister -> DBCsvActionNew - ExamUserCsvDeregister -> DBCsvActionMissing - _other -> DBCsvActionExisting - , dbtCsvExecuteActions = do - C.mapM_ $ \case - ExamUserCsvCourseRegisterData{..} -> do - now <- liftIO getCurrentTime - insert_ CourseParticipant - { courseParticipantCourse = examCourse - , courseParticipantUser = examUserCsvActUser - , courseParticipantRegistration = now - , courseParticipantField = examUserCsvActCourseField - } - User{userIdent} <- getJust examUserCsvActUser - audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent - insert_ ExamRegistration - { examRegistrationExam = eid - , examRegistrationUser = examUserCsvActUser - , examRegistrationOccurrence = examUserCsvActOccurrence - , examRegistrationTime = now - } - ExamUserCsvRegisterData{..} -> do - examRegistrationTime <- liftIO getCurrentTime - insert_ ExamRegistration - { examRegistrationExam = eid - , examRegistrationUser = examUserCsvActUser - , examRegistrationOccurrence = examUserCsvActOccurrence - , .. - } - ExamUserCsvAssignOccurrenceData{..} -> - update examUserCsvActRegistration [ ExamRegistrationOccurrence =. examUserCsvActOccurrence ] - ExamUserCsvSetCourseFieldData{..} -> - update examUserCsvActCourseParticipant [ CourseParticipantField =. examUserCsvActCourseField ] - ExamUserCsvDeregisterData{..} -> do - ExamRegistration{examRegistrationUser} <- getJust examUserCsvActRegistration - User{userIdent} <- getJust examRegistrationUser - audit' $ TransactionExamDeregister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent - delete examUserCsvActRegistration - return $ CExamR tid ssh csh examn EUsersR - , dbtCsvRenderKey = \(registeredUserName -> registeredUserName') -> \case - ExamUserCsvCourseRegisterData{..} -> do - (User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust - [whamlet| - $newline never - ^{nameWidget userDisplayName userSurname} - $maybe features <- examUserCsvActCourseField - , ^{studyFeaturesWidget features} - $nothing - , _{MsgCourseStudyFeatureNone} - $maybe ExamOccurrence{examOccurrenceName} <- occ - \ (#{examOccurrenceName}) - $nothing - \ (_{MsgExamNoOccurrence}) - |] - ExamUserCsvRegisterData{..} -> do - (User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust - [whamlet| - $newline never - ^{nameWidget userDisplayName userSurname} - $maybe ExamOccurrence{examOccurrenceName} <- occ - \ (#{examOccurrenceName}) - $nothing - \ (_{MsgExamNoOccurrence}) - |] - ExamUserCsvAssignOccurrenceData{..} -> do - occ <- for examUserCsvActOccurrence $ liftHandlerT . runDB . getJust - [whamlet| - $newline never - ^{registeredUserName' examUserCsvActRegistration} - $maybe ExamOccurrence{examOccurrenceName} <- occ - \ (#{examOccurrenceName}) - $nothing - \ (_{MsgExamNoOccurrence}) - |] - ExamUserCsvSetCourseFieldData{..} -> do - User{..} <- liftHandlerT . runDB $ getJust . courseParticipantUser =<< getJust examUserCsvActCourseParticipant - [whamlet| - $newline never - ^{nameWidget userDisplayName userSurname} - $maybe features <- examUserCsvActCourseField - , ^{studyFeaturesWidget features} - $nothing - , _{MsgCourseStudyFeatureNone} - |] - ExamUserCsvDeregisterData{..} - -> registeredUserName' examUserCsvActRegistration - , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure - , dbtCsvRenderException = ap getMessageRender . pure :: ExamUserCsvException -> DB Text - } - where - studyFeaturesWidget :: StudyFeaturesId -> Widget - studyFeaturesWidget featId = do - (StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandlerT . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField) - [whamlet| - $newline never - _{StudyDegreeTerm degree terms}, _{MsgStudyFeatureAge} #{studyFeaturesSemester} - |] - - registeredUserName :: Map (E.Value ExamRegistrationId) ExamUserTableData -> ExamRegistrationId -> Widget - registeredUserName existing (E.Value -> registration) = nameWidget userDisplayName userSurname - where - Entity _ User{..} = view resultUser $ existing ! registration - - guessUser :: ExamUserTableCsv -> DB (Bool, UserId) - guessUser ExamUserTableCsv{..} = $cachedHereBinary (csvEUserMatriculation, csvEUserName, csvEUserSurname) $ do - users <- E.select . E.from $ \user -> do - E.where_ . E.and $ catMaybes - [ (user E.^. UserMatrikelnummer E.==.) . E.val . Just <$> csvEUserMatriculation - , (user E.^. UserDisplayName E.==.) . E.val <$> csvEUserName - , (user E.^. UserSurname E.==.) . E.val <$> csvEUserSurname - ] - let isCourseParticipant = E.exists . E.from $ \courseParticipant -> - E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. E.val examCourse - E.&&. courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId - E.limit 2 - return $ (isCourseParticipant, user E.^. UserId) - case users of - (filter . view $ _1 . _Value -> [(E.Value isPart, E.Value uid)]) - -> return (isPart, uid) - [(E.Value isPart, E.Value uid)] - -> return (isPart, uid) - _other - -> throwM ExamUserCsvExceptionNoMatchingUser - - lookupOccurrence :: ExamUserTableCsv -> DB (Maybe ExamOccurrenceId) - lookupOccurrence ExamUserTableCsv{..} = $cachedHereBinary (CI.foldedCase <$> csvEUserOccurrence) . for csvEUserOccurrence $ \occName -> do - occIds <- selectKeysList [ ExamOccurrenceName ==. occName, ExamOccurrenceExam ==. eid ] [] - case occIds of - [occId] -> return occId - _other -> throwM ExamUserCsvExceptionNoMatchingOccurrence - - lookupStudyFeatures :: ExamUserTableCsv -> DB (Maybe StudyFeaturesId) - lookupStudyFeatures csv@ExamUserTableCsv{..} = do - uid <- view _2 <$> guessUser csv - studyFeatures <- E.select . E.from $ \(studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyTerms) -> do - E.on $ studyTerms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField - E.on $ studyDegree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree - E.where_ . E.and $ catMaybes - [ do - field <- csvEUserField - return . E.or $ catMaybes - [ Just $ studyTerms E.^. StudyTermsName `E.ciEq` E.just (E.val field) - , Just $ studyTerms E.^. StudyTermsShorthand `E.ciEq` E.just (E.val field) - , (studyTerms E.^. StudyTermsKey E.==.) . E.val <$> readMay field - ] - , do - degree <- csvEUserDegree - return . E.or $ catMaybes - [ Just $ studyDegree E.^. StudyDegreeName `E.ciEq` E.just (E.val degree) - , Just $ studyDegree E.^. StudyDegreeShorthand `E.ciEq` E.just (E.val degree) - , (studyDegree E.^. StudyDegreeKey E.==.) . E.val <$> readMay degree - ] - , (studyFeatures E.^. StudyFeaturesSemester E.==.) . E.val <$> csvEUserSemester - ] - E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid - E.&&. studyFeatures E.^. StudyFeaturesType E.==. E.val FieldPrimary - E.&&. studyFeatures E.^. StudyFeaturesValid E.==. E.val True - E.limit 2 - return $ studyFeatures E.^. StudyFeaturesId - case studyFeatures of - [E.Value fid] -> return $ Just fid - _other - | is _Nothing csvEUserField - , is _Nothing csvEUserDegree - , is _Nothing csvEUserSemester - -> return Nothing - _other -> throwM ExamUserCsvExceptionNoMatchingStudyFeatures - - examUsersDBTableValidator = def - - postprocess :: FormResult (First ExamUserActionData, DBFormResult ExamRegistrationId Bool ExamUserTableData) -> FormResult (ExamUserActionData, Set ExamRegistrationId) - postprocess inp = do - (First (Just act), regMap) <- inp - let regSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) regMap - return (act, regSet) - over _1 postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable - - formResult registrationResult $ \case - (ExamUserDeregisterData, selectedRegistrations) -> do - nrDel <- runDB $ deleteWhereCount - [ ExamRegistrationId <-. Set.toList selectedRegistrations - ] - addMessageI Success $ MsgExamUsersDeregistered nrDel - redirect $ CExamR tid ssh csh examn EUsersR - (ExamUserAssignOccurrenceData occId, selectedRegistrations) -> do - nrUpdated <- runDB $ updateWhereCount - [ ExamRegistrationId <-. Set.toList selectedRegistrations - ] - [ ExamRegistrationOccurrence =. occId - ] - addMessageI Success $ MsgExamUsersOccurrenceUpdated nrUpdated - redirect $ CExamR tid ssh csh examn EUsersR - - siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamUsersHeading) $ do - setTitleI $ prependCourseTitle tid ssh csh MsgExamUsersHeading - $(widgetFile "exam-users") - - -instance IsInvitableJunction ExamRegistration where - type InvitationFor ExamRegistration = Exam - data InvitableJunction ExamRegistration = JunctionExamRegistration - { jExamRegistrationOccurrence :: Maybe ExamOccurrenceId - , jExamRegistrationTime :: UTCTime - } deriving (Eq, Ord, Read, Show, Generic, Typeable) - data InvitationDBData ExamRegistration = InvDBDataExamRegistration - { invDBExamRegistrationOccurrence :: Maybe ExamOccurrenceId - , invDBExamRegistrationDeadline :: UTCTime - , invDBExamRegistrationCourseRegister :: Bool - } deriving (Eq, Ord, Read, Show, Generic, Typeable) - data InvitationTokenData ExamRegistration = InvTokenDataExamRegistration - deriving (Eq, Ord, Read, Show, Generic, Typeable) - - _InvitableJunction = iso - (\ExamRegistration{..} -> (examRegistrationUser, examRegistrationExam, JunctionExamRegistration examRegistrationOccurrence examRegistrationTime)) - (\(examRegistrationUser, examRegistrationExam, JunctionExamRegistration examRegistrationOccurrence examRegistrationTime) -> ExamRegistration{..}) - -instance ToJSON (InvitableJunction ExamRegistration) where - toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } - toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } -instance FromJSON (InvitableJunction ExamRegistration) where - parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } - -instance ToJSON (InvitationDBData ExamRegistration) where - toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } - toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } -instance FromJSON (InvitationDBData ExamRegistration) where - parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } - -instance ToJSON (InvitationTokenData ExamRegistration) where - toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 } - toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 } -instance FromJSON (InvitationTokenData ExamRegistration) where - parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 } - -examRegistrationInvitationConfig :: InvitationConfig ExamRegistration -examRegistrationInvitationConfig = InvitationConfig{..} - where - invitationRoute (Entity _ Exam{..}) _ = do - Course{..} <- get404 examCourse - return $ CExamR courseTerm courseSchool courseShorthand examName EInviteR - invitationResolveFor = do - Just (CExamR tid csh ssh examn EInviteR) <- getCurrentRoute - fetchExamId tid csh ssh examn - invitationSubject (Entity _ Exam{..}) _ = do - Course{..} <- get404 examCourse - return . SomeMessage $ MsgMailSubjectExamRegistrationInvitation courseTerm courseSchool courseShorthand examName - invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInviteHeading examName - invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgExamRegistrationInviteExplanation}|] - invitationTokenConfig _ (InvDBDataExamRegistration{..}, _) = do - itAuthority <- liftHandlerT requireAuthId - let itExpiresAt = Just $ Just invDBExamRegistrationDeadline - itAddAuth - | not invDBExamRegistrationCourseRegister - = Just . PredDNF . Set.singleton . impureNonNull . Set.singleton $ PLVariable AuthCourseRegistered - | otherwise - = Nothing - itStartsAt = Nothing - return $ InvitationTokenConfig{..} - invitationRestriction _ _ = return Authorized - invitationForm (Entity _ Exam{..}) (InvDBDataExamRegistration{..}, _) uid = hoistAForm liftHandlerT . wFormToAForm $ do - isRegistered <- fmap (is _Just) . liftHandlerT . runDB . getBy $ UniqueParticipant uid examCourse - now <- liftIO getCurrentTime - - case (isRegistered, invDBExamRegistrationCourseRegister) of - (False, False) -> permissionDeniedI MsgUnauthorizedParticipant - (False, True ) -> do - fieldRes <- wreq (studyFeaturesPrimaryFieldFor False [] $ Just uid) (fslI MsgCourseStudyFeature) Nothing - return $ (JunctionExamRegistration invDBExamRegistrationOccurrence now, ) . Just <$> fieldRes - (True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing) - invitationInsertHook (Entity _ Exam{..}) _ ExamRegistration{..} mField act = do - whenIsJust mField $ - insert_ . CourseParticipant examCourse examRegistrationUser examRegistrationTime - - Course{..} <- get404 examCourse - User{..} <- get404 examRegistrationUser - let doAudit = audit' $ TransactionExamRegister (unTermKey courseTerm) (unSchoolKey courseSchool) courseShorthand examName userIdent - act <* doAudit - invitationSuccessMsg (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInvitationAccepted examName - invitationUltDest (Entity _ Exam{..}) _ = do - Course{..} <- get404 examCourse - return . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName EShowR - -data AddRecipientsResult = AddRecipientsResult - { aurAlreadyRegistered - , aurNoUniquePrimaryField - , aurNoCourseRegistration - , aurSuccess :: [UserEmail] - } deriving (Read, Show, Generic, Typeable) - -instance Monoid AddRecipientsResult where - mempty = memptydefault - mappend = mappenddefault - - -getEAddUserR, postEAddUserR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html -getEAddUserR = postEAddUserR -postEAddUserR tid ssh csh examn = do - eEnt@(Entity eid Exam{..}) <- runDB $ fetchExam tid ssh csh examn - ((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do - now <- liftIO getCurrentTime - occurrences <- liftHandlerT . runDB $ selectList [ExamOccurrenceExam ==. eid] [] - - let - localNow = utcToLocalTime now - tomorrowEndOfDay = case localTimeToUTC (LocalTime (addDays 2 $ localDay localNow) midnight) of - LTUUnique utc' _ -> utc' - _other -> UTCTime (addDays 2 $ utctDay now) 0 - earliestDate = getOption . fmap getMin $ mconcat - [ Option $ Min <$> examStart - , foldMap (Option . Just . Min . examOccurrenceStart . entityVal) occurrences - ] - modifiedEarliestDate = earliestDate <&> \earliestDate'@(utcToLocalTime -> localEarliestDate') - -> case localTimeToUTC (LocalTime (addDays (-1) $ localDay localEarliestDate') midnight) of - LTUUnique utc' _ -> utc' - _other -> UTCTime (addDays (-1) $ utctDay earliestDate') 0 - defDeadline - | Just registerTo <- examRegisterTo - , registerTo > now - = registerTo - | Just earliestDate' <- modifiedEarliestDate - = max tomorrowEndOfDay earliestDate' - | otherwise - = tomorrowEndOfDay - - deadline <- wreq utcTimeField (fslI MsgExamRegistrationInviteDeadline) (Just defDeadline) - enlist <- wpopt checkBoxField (fslI MsgExamRegistrationEnlistDirectly) (Just False) - registerCourse <- wpopt checkBoxField (fslI MsgExamRegistrationRegisterCourse & setTooltip MsgExamRegistrationRegisterCourseTip) (Just False) - occurrence <- wopt (examOccurrenceField eid) (fslI MsgExamOccurrence) Nothing - users <- wreq (multiUserField (maybe True not $ formResultToMaybe enlist) Nothing) - (fslI MsgExamRegistrationInviteField & setTooltip MsgMultiEmailFieldTip) Nothing - return $ (,,,) <$> deadline <*> registerCourse <*> occurrence <*> users - - formResultModal usersToEnlist (CExamR tid ssh csh examn EUsersR) $ processUsers eEnt - - let heading = prependCourseTitle tid ssh csh MsgExamParticipantsRegisterHeading - - siteLayoutMsg heading $ do - setTitleI heading - wrapForm formWgt def - { formEncoding - , formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAddUserR - } - where - processUsers :: Entity Exam -> (UTCTime, Bool, Maybe ExamOccurrenceId, Set (Either UserEmail UserId)) -> WriterT [Message] Handler () - processUsers (Entity eid Exam{..}) (deadline, registerCourse, occId, users) = do - let (emails,uids) = partitionEithers $ Set.toList users - AddRecipientsResult alreadyRegistered registeredNoField noCourseRegistration registeredOneField <- lift . runDBJobs $ do - -- send Invitation eMails to unkown users - sinkInvitationsF examRegistrationInvitationConfig [(mail,eid,(InvDBDataExamRegistration occId deadline registerCourse, InvTokenDataExamRegistration)) | mail <- emails] - -- register known users - execWriterT $ mapM (registerUser examCourse eid registerCourse occId) uids - - when (not $ null emails) $ - tell . pure <=< messageI Success . MsgExamParticipantsInvited $ length emails - - when (not $ null alreadyRegistered) $ - tell . pure <=< messageI Success . MsgExamRegistrationParticipantsRegistered $ length registeredOneField - - when (not $ null registeredNoField) $ do - let modalTrigger = [whamlet|_{MsgExamRegistrationRegisteredWithoutField (length registeredNoField)}|] - modalContent = $(widgetFile "messages/examRegistrationInvitationRegisteredWithoutField") - tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent) - - when (not $ null noCourseRegistration) $ do - let modalTrigger = [whamlet|_{MsgExamRegistrationNotRegisteredWithoutCourse (length noCourseRegistration)}|] - modalContent = $(widgetFile "messages/examRegistrationInvitationNotRegisteredWithoutCourse") - tell . pure <=< messageWidget Error $ msgModal modalTrigger (Right modalContent) - - when (not $ null registeredOneField) $ - tell . pure <=< messageI Success . MsgExamRegistrationAndCourseParticipantsRegistered $ length registeredOneField - - registerUser :: CourseId -> ExamId -> Bool -> Maybe ExamOccurrenceId -> UserId -> WriterT AddRecipientsResult (YesodJobDB UniWorX) () - registerUser cid eid registerCourse occId uid = exceptT tell tell $ do - User{..} <- lift . lift $ getJust uid - now <- liftIO getCurrentTime - - let - examRegister :: YesodJobDB UniWorX () - examRegister = do - insert_ $ ExamRegistration eid uid occId now - audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent - - whenM (lift . lift . existsBy $ UniqueExamRegistration eid uid) $ - throwError $ mempty { aurAlreadyRegistered = pure userEmail } - - whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $ do - lift $ lift examRegister - throwError $ mempty { aurSuccess = pure userEmail } - - unless registerCourse $ - throwError $ mempty { aurNoCourseRegistration = pure userEmail } - - features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] [] - - let courseParticipantField - | [f] <- features = Just f - | otherwise = Nothing - - lift . lift . insert_ $ CourseParticipant - { courseParticipantCourse = cid - , courseParticipantUser = uid - , courseParticipantRegistration = now - , .. - } - lift $ lift examRegister - - return $ case courseParticipantField of - Nothing -> mempty { aurNoUniquePrimaryField = pure userEmail } - Just _ -> mempty { aurSuccess = pure userEmail } - - -getEInviteR, postEInviteR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html -getEInviteR = postEInviteR -postEInviteR _ _ _ _ = invitationR' examRegistrationInvitationConfig - -postERegisterR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html -postERegisterR tid ssh csh examn = do - Entity uid User{..} <- requireAuth - - Entity eId Exam{..} <- runDB $ fetchExam tid ssh csh examn - - ((btnResult, _), _) <- runFormPost buttonForm - - formResult btnResult $ \case - BtnExamRegister -> do - runDB $ do - now <- liftIO getCurrentTime - insert_ $ ExamRegistration eId uid Nothing now - audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent - addMessageWidget Success [whamlet| -

      #{iconExamRegister True} -
        -
      _{MsgExamRegisteredSuccess examn} - |] - redirect $ CExamR tid ssh csh examn EShowR - BtnExamDeregister -> do - runDB $ do - deleteBy $ UniqueExamRegistration eId uid - audit' $ TransactionExamDeregister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent - addMessageWidget Info [whamlet| -
      #{iconExamRegister False} -
        -
      _{MsgExamDeregisteredSuccess examn} - |] -- yes, it's a success message, but it should be visually different from a positive success, since most will just note the positive green color! See discussion on commit 5f4925a4 - redirect $ CExamR tid ssh csh examn EShowR - - invalidArgs ["Register/Deregister button required"] +module Handler.Exam + ( module Handler.Exam + ) where + +import Handler.Exam.List as Handler.Exam +import Handler.Exam.Register as Handler.Exam +import Handler.Exam.CorrectorInvite as Handler.Exam +import Handler.Exam.RegistrationInvite as Handler.Exam +import Handler.Exam.New as Handler.Exam +import Handler.Exam.Edit as Handler.Exam +import Handler.Exam.Show as Handler.Exam +import Handler.Exam.Users as Handler.Exam +import Handler.Exam.AddUser as Handler.Exam diff --git a/src/Handler/Exam/AddUser.hs b/src/Handler/Exam/AddUser.hs new file mode 100644 index 000000000..22e45d557 --- /dev/null +++ b/src/Handler/Exam/AddUser.hs @@ -0,0 +1,154 @@ +module Handler.Exam.AddUser + ( getEAddUserR, postEAddUserR + ) where + +import Import hiding (Option(..)) +import Handler.Exam.RegistrationInvite + +import Handler.Utils +import Handler.Utils.Exam +import Handler.Utils.Invitations + +import Utils.Lens + +import qualified Data.Set as Set + +import Data.Semigroup (Option(..)) + +import Control.Monad.Trans.Writer (WriterT, execWriterT) +import Control.Monad.Error.Class (MonadError(..)) + +import Jobs.Queue + +import Generics.Deriving.Monoid + + +data AddRecipientsResult = AddRecipientsResult + { aurAlreadyRegistered + , aurNoUniquePrimaryField + , aurNoCourseRegistration + , aurSuccess :: [UserEmail] + } deriving (Read, Show, Generic, Typeable) + +instance Monoid AddRecipientsResult where + mempty = memptydefault + mappend = mappenddefault + + +getEAddUserR, postEAddUserR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html +getEAddUserR = postEAddUserR +postEAddUserR tid ssh csh examn = do + eEnt@(Entity eid Exam{..}) <- runDB $ fetchExam tid ssh csh examn + ((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do + now <- liftIO getCurrentTime + occurrences <- liftHandlerT . runDB $ selectList [ExamOccurrenceExam ==. eid] [] + + let + localNow = utcToLocalTime now + tomorrowEndOfDay = case localTimeToUTC (LocalTime (addDays 2 $ localDay localNow) midnight) of + LTUUnique utc' _ -> utc' + _other -> UTCTime (addDays 2 $ utctDay now) 0 + earliestDate = getOption . fmap getMin $ mconcat + [ Option $ Min <$> examStart + , foldMap (Option . Just . Min . examOccurrenceStart . entityVal) occurrences + ] + modifiedEarliestDate = earliestDate <&> \earliestDate'@(utcToLocalTime -> localEarliestDate') + -> case localTimeToUTC (LocalTime (addDays (-1) $ localDay localEarliestDate') midnight) of + LTUUnique utc' _ -> utc' + _other -> UTCTime (addDays (-1) $ utctDay earliestDate') 0 + defDeadline + | Just registerTo <- examRegisterTo + , registerTo > now + = registerTo + | Just earliestDate' <- modifiedEarliestDate + = max tomorrowEndOfDay earliestDate' + | otherwise + = tomorrowEndOfDay + + deadline <- wreq utcTimeField (fslI MsgExamRegistrationInviteDeadline) (Just defDeadline) + enlist <- wpopt checkBoxField (fslI MsgExamRegistrationEnlistDirectly) (Just False) + registerCourse <- wpopt checkBoxField (fslI MsgExamRegistrationRegisterCourse & setTooltip MsgExamRegistrationRegisterCourseTip) (Just False) + occurrence <- wopt (examOccurrenceField eid) (fslI MsgExamOccurrence) Nothing + users <- wreq (multiUserField (maybe True not $ formResultToMaybe enlist) Nothing) + (fslI MsgExamRegistrationInviteField & setTooltip MsgMultiEmailFieldTip) Nothing + return $ (,,,) <$> deadline <*> registerCourse <*> occurrence <*> users + + formResultModal usersToEnlist (CExamR tid ssh csh examn EUsersR) $ processUsers eEnt + + let heading = prependCourseTitle tid ssh csh MsgExamParticipantsRegisterHeading + + siteLayoutMsg heading $ do + setTitleI heading + wrapForm formWgt def + { formEncoding + , formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAddUserR + } + where + processUsers :: Entity Exam -> (UTCTime, Bool, Maybe ExamOccurrenceId, Set (Either UserEmail UserId)) -> WriterT [Message] Handler () + processUsers (Entity eid Exam{..}) (deadline, registerCourse, occId, users) = do + let (emails,uids) = partitionEithers $ Set.toList users + AddRecipientsResult alreadyRegistered registeredNoField noCourseRegistration registeredOneField <- lift . runDBJobs $ do + -- send Invitation eMails to unkown users + sinkInvitationsF examRegistrationInvitationConfig [(mail,eid,(InvDBDataExamRegistration occId deadline registerCourse, InvTokenDataExamRegistration)) | mail <- emails] + -- register known users + execWriterT $ mapM (registerUser examCourse eid registerCourse occId) uids + + when (not $ null emails) $ + tell . pure <=< messageI Success . MsgExamParticipantsInvited $ length emails + + when (not $ null alreadyRegistered) $ + tell . pure <=< messageI Success . MsgExamRegistrationParticipantsRegistered $ length registeredOneField + + when (not $ null registeredNoField) $ do + let modalTrigger = [whamlet|_{MsgExamRegistrationRegisteredWithoutField (length registeredNoField)}|] + modalContent = $(widgetFile "messages/examRegistrationInvitationRegisteredWithoutField") + tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent) + + when (not $ null noCourseRegistration) $ do + let modalTrigger = [whamlet|_{MsgExamRegistrationNotRegisteredWithoutCourse (length noCourseRegistration)}|] + modalContent = $(widgetFile "messages/examRegistrationInvitationNotRegisteredWithoutCourse") + tell . pure <=< messageWidget Error $ msgModal modalTrigger (Right modalContent) + + when (not $ null registeredOneField) $ + tell . pure <=< messageI Success . MsgExamRegistrationAndCourseParticipantsRegistered $ length registeredOneField + + registerUser :: CourseId -> ExamId -> Bool -> Maybe ExamOccurrenceId -> UserId -> WriterT AddRecipientsResult (YesodJobDB UniWorX) () + registerUser cid eid registerCourse occId uid = exceptT tell tell $ do + User{..} <- lift . lift $ getJust uid + now <- liftIO getCurrentTime + + let + examRegister :: YesodJobDB UniWorX () + examRegister = do + insert_ $ ExamRegistration eid uid occId now + audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent + + whenM (lift . lift . existsBy $ UniqueExamRegistration eid uid) $ + throwError $ mempty { aurAlreadyRegistered = pure userEmail } + + whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $ do + lift $ lift examRegister + throwError $ mempty { aurSuccess = pure userEmail } + + unless registerCourse $ + throwError $ mempty { aurNoCourseRegistration = pure userEmail } + + features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] [] + + let courseParticipantField + | [f] <- features = Just f + | otherwise = Nothing + + lift . lift . insert_ $ CourseParticipant + { courseParticipantCourse = cid + , courseParticipantUser = uid + , courseParticipantRegistration = now + , .. + } + lift $ lift examRegister + + return $ case courseParticipantField of + Nothing -> mempty { aurNoUniquePrimaryField = pure userEmail } + Just _ -> mempty { aurSuccess = pure userEmail } + + diff --git a/src/Handler/Exam/CorrectorInvite.hs b/src/Handler/Exam/CorrectorInvite.hs new file mode 100644 index 000000000..e25ae5810 --- /dev/null +++ b/src/Handler/Exam/CorrectorInvite.hs @@ -0,0 +1,80 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Handler.Exam.CorrectorInvite + ( InvitableJunction(..) + , InvitationDBData(..) + , InvitationTokenData(..) + , examCorrectorInvitationConfig + , getECInviteR, postECInviteR + ) where + +import Import +import Handler.Utils.Invitations +import Handler.Utils.Exam + +import Utils.Lens + +import Text.Hamlet (ihamlet) + +import Data.Aeson hiding (Result(..)) + + +instance IsInvitableJunction ExamCorrector where + type InvitationFor ExamCorrector = Exam + data InvitableJunction ExamCorrector = JunctionExamCorrector + deriving (Eq, Ord, Read, Show, Generic, Typeable) + data InvitationDBData ExamCorrector = InvDBDataExamCorrector + deriving (Eq, Ord, Read, Show, Generic, Typeable) + data InvitationTokenData ExamCorrector = InvTokenDataExamCorrector + deriving (Eq, Ord, Read, Show, Generic, Typeable) + + _InvitableJunction = iso + (\ExamCorrector{..} -> (examCorrectorUser, examCorrectorExam, JunctionExamCorrector)) + (\(examCorrectorUser, examCorrectorExam, JunctionExamCorrector) -> ExamCorrector{..}) + +instance ToJSON (InvitableJunction ExamCorrector) where + toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } +instance FromJSON (InvitableJunction ExamCorrector) where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } + +instance ToJSON (InvitationDBData ExamCorrector) where + toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } +instance FromJSON (InvitationDBData ExamCorrector) where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } + +instance ToJSON (InvitationTokenData ExamCorrector) where + toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 } + toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 } +instance FromJSON (InvitationTokenData ExamCorrector) where + parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 } + +examCorrectorInvitationConfig :: InvitationConfig ExamCorrector +examCorrectorInvitationConfig = InvitationConfig{..} + where + invitationRoute (Entity _ Exam{..}) _ = do + Course{..} <- get404 examCourse + return $ CExamR courseTerm courseSchool courseShorthand examName ECInviteR + invitationResolveFor = do + Just (CExamR tid csh ssh examn ECInviteR) <- getCurrentRoute + fetchExamId tid csh ssh examn + invitationSubject (Entity _ Exam{..}) _ = do + Course{..} <- get404 examCourse + return . SomeMessage $ MsgMailSubjectExamCorrectorInvitation courseTerm courseSchool courseShorthand examName + invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName + invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|] + invitationTokenConfig _ _ = do + itAuthority <- liftHandlerT requireAuthId + return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing + invitationRestriction _ _ = return Authorized + invitationForm _ _ _ = pure (JunctionExamCorrector, ()) + invitationInsertHook _ _ _ _ = id + invitationSuccessMsg (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInvitationAccepted examName + invitationUltDest (Entity _ Exam{..}) _ = do + Course{..} <- get404 examCourse + return . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName EShowR + +getECInviteR, postECInviteR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html +getECInviteR = postECInviteR +postECInviteR = invitationR examCorrectorInvitationConfig diff --git a/src/Handler/Exam/Edit.hs b/src/Handler/Exam/Edit.hs new file mode 100644 index 000000000..06abd7834 --- /dev/null +++ b/src/Handler/Exam/Edit.hs @@ -0,0 +1,133 @@ +module Handler.Exam.Edit + ( getEEditR, postEEditR + ) where + +import Import +import Handler.Exam.Form +import Handler.Exam.CorrectorInvite + +import Utils.Lens + +import qualified Data.Set as Set + +import Handler.Utils +import Handler.Utils.Exam +import Handler.Utils.Invitations + +import Jobs.Queue + + +getEEditR, postEEditR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html +getEEditR = postEEditR +postEEditR tid ssh csh examn = do + (cid, eId, template) <- runDB $ do + (cid, exam@(Entity eId _)) <- fetchCourseIdExam tid ssh csh examn + + template <- examFormTemplate exam + + return (cid, eId, template) + + ((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm validateExam . examForm $ Just template + + formResult editExamResult $ \ExamForm{..} -> do + insertRes <- runDBJobs $ do + insertRes <- myReplaceUnique eId Exam + { examCourse = cid + , examName = efName + , examGradingRule = efGradingRule + , examBonusRule = efBonusRule + , examOccurrenceRule = efOccurrenceRule + , examVisibleFrom = efVisibleFrom + , examRegisterFrom = efRegisterFrom + , examRegisterTo = efRegisterTo + , examDeregisterUntil = efDeregisterUntil + , examPublishOccurrenceAssignments = efPublishOccurrenceAssignments + , examStart = efStart + , examEnd = efEnd + , examFinished = efFinished + , examClosed = efClosed + , examPublicStatistics = efPublicStatistics + , examShowGrades = efShowGrades + , examDescription = efDescription + } + + when (is _Nothing insertRes) $ do + occIds <- fmap catMaybes . forM (Set.toList efOccurrences) $ traverse decrypt . eofId + deleteWhere [ ExamOccurrenceExam ==. eId, ExamOccurrenceId /<-. occIds ] + forM_ (Set.toList efOccurrences) $ \case + ExamOccurrenceForm{ eofId = Nothing, .. } -> insert_ + ExamOccurrence + { examOccurrenceExam = eId + , examOccurrenceName = eofName + , examOccurrenceRoom = eofRoom + , examOccurrenceCapacity = eofCapacity + , examOccurrenceStart = eofStart + , examOccurrenceEnd = eofEnd + , examOccurrenceDescription = eofDescription + } + ExamOccurrenceForm{ .. } -> void . runMaybeT $ do + cID <- hoistMaybe eofId + eofId' <- decrypt cID + oldOcc <- MaybeT $ get eofId' + guard $ examOccurrenceExam oldOcc == eId + lift $ replace eofId' ExamOccurrence + { examOccurrenceExam = eId + , examOccurrenceName = eofName + , examOccurrenceRoom = eofRoom + , examOccurrenceCapacity = eofCapacity + , examOccurrenceStart = eofStart + , examOccurrenceEnd = eofEnd + , examOccurrenceDescription = eofDescription + } + + + pIds <- fmap catMaybes . forM (Set.toList efExamParts) $ traverse decrypt . epfId + deleteWhere [ ExamPartExam ==. eId, ExamPartId /<-. pIds ] + forM_ (Set.toList efExamParts) $ \case + ExamPartForm{ epfId = Nothing, .. } -> insert_ + ExamPart + { examPartExam = eId + , examPartName = epfName + , examPartMaxPoints = epfMaxPoints + , examPartWeight = epfWeight + } + ExamPartForm{ .. } -> void . runMaybeT $ do + cID <- hoistMaybe epfId + epfId' <- decrypt cID + oldPart <- MaybeT $ get epfId' + guard $ examPartExam oldPart == eId + lift $ replace epfId' ExamPart + { examPartExam = eId + , examPartName = epfName + , examPartMaxPoints = epfMaxPoints + , examPartWeight = epfWeight + } + + + let (invites, adds) = partitionEithers $ Set.toList efCorrectors + + deleteWhere [ ExamCorrectorExam ==. eId ] + insertMany_ $ map (ExamCorrector eId) adds + + deleteWhere [ InvitationFor ==. invRef @ExamCorrector eId, InvitationEmail /<-. invites ] + sinkInvitationsF examCorrectorInvitationConfig $ map (, eId, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites + + return insertRes + + case insertRes of + Just _ -> addMessageI Error $ MsgExamNameTaken efName + Nothing -> do + addMessageI Success $ MsgExamEdited efName + redirect $ CExamR tid ssh csh efName EShowR + + let heading = prependCourseTitle tid ssh csh . MsgExamEditHeading $ efName template + + siteLayoutMsg heading $ do + setTitleI heading + let + editExamForm = wrapForm editExamWidget def + { formMethod = POST + , formAction = Just . SomeRoute $ CExamR tid ssh csh examn EEditR + , formEncoding = editExamEnctype + } + $(widgetFile "exam-edit") diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs new file mode 100644 index 000000000..905adc4fe --- /dev/null +++ b/src/Handler/Exam/Form.hs @@ -0,0 +1,361 @@ +module Handler.Exam.Form + ( ExamForm(..) + , ExamOccurrenceForm(..) + , ExamPartForm(..) + , examForm + , examFormTemplate, examTemplate + , validateExam + ) where + +import Import +import Utils.Lens hiding (parts) + +import Handler.Exam.CorrectorInvite + +import Handler.Utils +import Handler.Utils.Invitations + +import Data.Map ((!)) +import qualified Data.Set as Set + +import qualified Database.Esqueleto as E + +import qualified Control.Monad.State.Class as State +import Text.Blaze.Html.Renderer.String (renderHtml) + + +data ExamForm = ExamForm + { efName :: ExamName + , efDescription :: Maybe Html + , efStart :: Maybe UTCTime + , efEnd :: Maybe UTCTime + , efVisibleFrom :: Maybe UTCTime + , efRegisterFrom :: Maybe UTCTime + , efRegisterTo :: Maybe UTCTime + , efDeregisterUntil :: Maybe UTCTime + , efPublishOccurrenceAssignments :: Maybe UTCTime + , efFinished :: Maybe UTCTime + , efClosed :: Maybe UTCTime + , efOccurrences :: Set ExamOccurrenceForm + , efShowGrades :: Bool + , efPublicStatistics :: Bool + , efGradingRule :: ExamGradingRule + , efBonusRule :: ExamBonusRule + , efOccurrenceRule :: ExamOccurrenceRule + , efCorrectors :: Set (Either UserEmail UserId) + , efExamParts :: Set ExamPartForm + } + +data ExamOccurrenceForm = ExamOccurrenceForm + { eofId :: Maybe CryptoUUIDExamOccurrence + , eofName :: ExamOccurrenceName + , eofRoom :: Text + , eofCapacity :: Natural + , eofStart :: UTCTime + , eofEnd :: Maybe UTCTime + , eofDescription :: Maybe Html + } deriving (Read, Show, Eq, Ord, Generic, Typeable) + +data ExamPartForm = ExamPartForm + { epfId :: Maybe CryptoUUIDExamPart + , epfName :: ExamPartName + , epfMaxPoints :: Maybe Points + , epfWeight :: Rational + } deriving (Read, Show, Eq, Ord, Generic, Typeable) + +makeLenses_ ''ExamForm + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''ExamPartForm + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''ExamOccurrenceForm + + +examForm :: Maybe ExamForm -> Form ExamForm +examForm template html = do + MsgRenderer mr <- getMsgRenderer + + flip (renderAForm FormStandard) html $ ExamForm + <$> areq ciField (fslpI MsgExamName (mr MsgExamName) & setTooltip MsgExamNameTip) (efName <$> template) + <*> (assertM (not . null . renderHtml) <$> aopt htmlField (fslpI MsgExamDescription "Html") (efDescription <$> template)) + <* aformSection MsgExamFormTimes + <*> aopt utcTimeField (fslpI MsgExamStart (mr MsgDate) & setTooltip MsgExamTimeTip) (efStart <$> template) + <*> aopt utcTimeField (fslpI MsgExamEnd (mr MsgDate) & setTooltip MsgExamTimeTip) (efEnd <$> template) + <*> aopt utcTimeField (fslpI MsgExamVisibleFrom (mr MsgDate) & setTooltip MsgExamVisibleFromTip) (efVisibleFrom <$> template) + <*> aopt utcTimeField (fslpI MsgExamRegisterFrom (mr MsgDate) & setTooltip MsgExamRegisterFromTip) (efRegisterFrom <$> template) + <*> aopt utcTimeField (fslpI MsgExamRegisterTo (mr MsgDate)) (efRegisterTo <$> template) + <*> aopt utcTimeField (fslpI MsgExamDeregisterUntil (mr MsgDate)) (efDeregisterUntil <$> template) + <*> aopt utcTimeField (fslpI MsgExamPublishOccurrenceAssignments (mr MsgDate) & setTooltip MsgExamPublishOccurrenceAssignmentsTip) (efPublishOccurrenceAssignments <$> template) + <*> aopt utcTimeField (fslpI MsgExamFinished (mr MsgDate) & setTooltip MsgExamFinishedTip) (efFinished <$> template) + <*> aopt utcTimeField (fslpI MsgExamClosed (mr MsgDate) & setTooltip MsgExamClosedTip) (efClosed <$> template) + <* aformSection MsgExamFormOccurrences + <*> examOccurrenceForm (efOccurrences <$> template) + <* aformSection MsgExamFormAutomaticFunctions + <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamShowGrades & setTooltip MsgExamShowGradesTip) (Just . efShowGrades <$> template)) + <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (Just . efPublicStatistics <$> template)) + <*> examGradingRuleForm (efGradingRule <$> template) + <*> examBonusRuleForm (efBonusRule <$> template) + <*> examOccurrenceRuleForm (efOccurrenceRule <$> template) + <* aformSection MsgExamFormCorrection + <*> examCorrectorsForm (efCorrectors <$> template) + <* aformSection MsgExamFormParts + <*> examPartsForm (efExamParts <$> template) + +examCorrectorsForm :: Maybe (Set (Either UserEmail UserId)) -> AForm Handler (Set (Either UserEmail UserId)) +examCorrectorsForm mPrev = wFormToAForm $ do + MsgRenderer mr <- getMsgRenderer + Just currentRoute <- getCurrentRoute + uid <- liftHandlerT requireAuthId + + let + miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) + miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag + + miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId]) + miAdd' nudge submitView csrf = do + (addRes, addView) <- mpreq (multiUserField False $ Just corrUserSuggestions) ("" & addName (nudge "email")) Nothing + let + addRes' + | otherwise + = addRes <&> \newDat oldDat -> if + | existing <- newDat `Set.intersection` Set.fromList oldDat + , not $ Set.null existing + -> FormFailure [mr MsgExamCorrectorAlreadyAdded] + | otherwise + -> FormSuccess $ Set.toList newDat + return (addRes', $(widgetFile "widgets/massinput/examCorrectors/add")) + + corrUserSuggestions :: E.SqlQuery (E.SqlExpr (Entity User)) + corrUserSuggestions = E.from $ \(lecturer `E.InnerJoin` course `E.InnerJoin` exam `E.InnerJoin` corrector `E.InnerJoin` corrUser) -> do + E.on $ corrUser E.^. UserId E.==. corrector E.^. ExamCorrectorUser + E.on $ corrector E.^. ExamCorrectorExam E.==. exam E.^. ExamId + E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId + E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse + E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid + return corrUser + + + miCell' :: Either UserEmail UserId -> Widget + miCell' (Left email) = + $(widgetFile "widgets/massinput/examCorrectors/cellInvitation") + miCell' (Right userId) = do + User{..} <- liftHandlerT . runDB $ get404 userId + $(widgetFile "widgets/massinput/examCorrectors/cellKnown") + + miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) () + miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examCorrectors/layout") + + fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' ("correctors" :: Text) (fslI MsgExamCorrectors & setTooltip MsgMassInputTip) False (Set.toList <$> mPrev) + +examOccurrenceForm :: Maybe (Set ExamOccurrenceForm) -> AForm Handler (Set ExamOccurrenceForm) +examOccurrenceForm prev = wFormToAForm $ do + Just currentRoute <- getCurrentRoute + let + miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) + miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag + + fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamOccurrences & setTooltip MsgMassInputTip) False $ Set.toList <$> prev + where + examOccurrenceForm' nudge mPrev csrf = do + (eofIdRes, eofIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ eofId =<< mPrev) + (eofNameRes, eofNameView) <- mpreq ciField ("" & addName (nudge "name")) (eofName <$> mPrev) + (eofRoomRes, eofRoomView) <- mpreq textField ("" & addName (nudge "room")) (eofRoom <$> mPrev) + (eofCapacityRes, eofCapacityView) <- mpreq (natFieldI MsgExamRoomCapacityNegative) ("" & addName (nudge "capacity")) (eofCapacity <$> mPrev) + (eofStartRes, eofStartView) <- mpreq utcTimeField ("" & addName (nudge "start")) (eofStart <$> mPrev) + (eofEndRes, eofEndView) <- mopt utcTimeField ("" & addName (nudge "end")) (eofEnd <$> mPrev) + (eofDescRes, eofDescView) <- mopt htmlFieldSmall ("" & addName (nudge "description")) (eofDescription <$> mPrev) + + return ( ExamOccurrenceForm + <$> eofIdRes + <*> eofNameRes + <*> eofRoomRes + <*> eofCapacityRes + <*> eofStartRes + <*> eofEndRes + <*> (assertM (not . null . renderHtml) <$> eofDescRes) + , $(widgetFile "widgets/massinput/examRooms/form") + ) + + miAdd' nudge submitView csrf = do + MsgRenderer mr <- getMsgRenderer + (res, formWidget) <- examOccurrenceForm' nudge Nothing csrf + let + addRes = res <&> \newDat (Set.fromList -> oldDat) -> if + | newDat `Set.member` oldDat -> FormFailure [mr MsgExamRoomAlreadyExists] + | otherwise -> FormSuccess $ pure newDat + return (addRes, $(widgetFile "widgets/massinput/examRooms/add")) + miCell' nudge dat = examOccurrenceForm' nudge (Just dat) + miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examRooms/layout") + miIdent' :: Text + miIdent' = "exam-occurrences" + +examPartsForm :: Maybe (Set ExamPartForm) -> AForm Handler (Set ExamPartForm) +examPartsForm prev = wFormToAForm $ do + Just currentRoute <- getCurrentRoute + let + miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) + miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag + + fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamParts & setTooltip MsgMassInputTip) False $ Set.toList <$> prev + where + examPartForm' nudge mPrev csrf = do + (epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev) + (epfNameRes, epfNameView) <- mpreq ciField ("" & addName (nudge "name")) (epfName <$> mPrev) + (epfMaxPointsRes, epfMaxPointsView) <- mopt pointsField ("" & addName (nudge "max-points")) (epfMaxPoints <$> mPrev) + (epfWeightRes, epfWeightView) <- mpreq (checkBool (>= 0) MsgExamPartWeightNegative rationalField) ("" & addName (nudge "weight")) (epfWeight <$> mPrev <|> Just 1) + + return ( ExamPartForm + <$> epfIdRes + <*> epfNameRes + <*> epfMaxPointsRes + <*> epfWeightRes + , $(widgetFile "widgets/massinput/examParts/form") + ) + + miAdd' nudge submitView csrf = do + MsgRenderer mr <- getMsgRenderer + (res, formWidget) <- examPartForm' nudge Nothing csrf + let + addRes = res <&> \newDat (Set.fromList -> oldDat) -> if + | any (((==) `on` epfName) newDat) oldDat -> FormFailure [mr MsgExamPartAlreadyExists] + | otherwise -> FormSuccess $ pure newDat + return (addRes, $(widgetFile "widgets/massinput/examParts/add")) + miCell' nudge dat = examPartForm' nudge (Just dat) + miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examParts/layout") + miIdent' :: Text + miIdent' = "exam-parts" + +examFormTemplate :: Entity Exam -> DB ExamForm +examFormTemplate (Entity eId Exam{..}) = do + parts <- selectList [ ExamPartExam ==. eId ] [] + occurrences <- selectList [ ExamOccurrenceExam ==. eId ] [] + correctors <- selectList [ ExamCorrectorExam ==. eId ] [] + invitations <- map (\(email, InvDBDataExamCorrector) -> email) <$> sourceInvitationsList eId + + parts' <- forM parts $ \(Entity pid part) -> (,) <$> encrypt pid <*> pure part + occurrences' <- forM occurrences $ \(Entity oid occ) -> (,) <$> encrypt oid <*> pure occ + + return ExamForm + { efName = examName + , efGradingRule = examGradingRule + , efBonusRule = examBonusRule + , efOccurrenceRule = examOccurrenceRule + , efVisibleFrom = examVisibleFrom + , efRegisterFrom = examRegisterFrom + , efRegisterTo = examRegisterTo + , efDeregisterUntil = examDeregisterUntil + , efPublishOccurrenceAssignments = examPublishOccurrenceAssignments + , efStart = examStart + , efEnd = examEnd + , efFinished = examFinished + , efClosed = examClosed + , efShowGrades = examShowGrades + , efPublicStatistics = examPublicStatistics + , efDescription = examDescription + , efOccurrences = Set.fromList $ do + (Just -> eofId, ExamOccurrence{..}) <- occurrences' + return ExamOccurrenceForm + { eofId + , eofName = examOccurrenceName + , eofRoom = examOccurrenceRoom + , eofCapacity = examOccurrenceCapacity + , eofStart = examOccurrenceStart + , eofEnd = examOccurrenceEnd + , eofDescription = examOccurrenceDescription + } + , efExamParts = Set.fromList $ do + (Just -> epfId, ExamPart{..}) <- parts' + return ExamPartForm + { epfId + , epfName = examPartName + , epfMaxPoints = examPartMaxPoints + , epfWeight = examPartWeight + } + , efCorrectors = Set.unions + [ Set.fromList $ map Left invitations + , Set.fromList . map Right $ do + Entity _ ExamCorrector{..} <- correctors + return examCorrectorUser + ] + } + +examTemplate :: CourseId -> DB (Maybe ExamForm) +examTemplate cid = runMaybeT $ do + newCourse <- MaybeT $ get cid + + [(Entity _ oldCourse, Entity _ oldExam)] <- lift . E.select . E.from $ \(course `E.InnerJoin` exam) -> do + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.where_ $ ( course E.^. CourseShorthand E.==. E.val (courseShorthand newCourse) + E.||. course E.^. CourseName E.==. E.val (courseName newCourse) + ) + E.&&. course E.^. CourseSchool E.==. E.val (courseSchool newCourse) + E.where_ . E.not_ . E.exists . E.from $ \exam' -> do + E.where_ $ exam' E.^. ExamCourse E.==. E.val cid + E.where_ $ exam E.^. ExamName E.==. exam' E.^. ExamName + E.where_ . E.not_ . E.isNothing $ exam E.^. ExamVisibleFrom + E.limit 1 + E.orderBy [ E.desc $ course E.^. CourseTerm, E.asc $ exam E.^. ExamVisibleFrom ] + return (course, exam) + + oldTerm <- MaybeT . get $ courseTerm oldCourse + newTerm <- MaybeT . get $ courseTerm newCourse + + let + dateOffset = over _utctDay . addDays $ (diffDays `on` termLectureEnd) newTerm oldTerm + + return ExamForm + { efName = examName oldExam + , efGradingRule = examGradingRule oldExam + , efBonusRule = examBonusRule oldExam + , efOccurrenceRule = examOccurrenceRule oldExam + , efVisibleFrom = dateOffset <$> examVisibleFrom oldExam + , efRegisterFrom = dateOffset <$> examRegisterFrom oldExam + , efRegisterTo = dateOffset <$> examRegisterTo oldExam + , efDeregisterUntil = dateOffset <$> examDeregisterUntil oldExam + , efPublishOccurrenceAssignments = dateOffset <$> examPublishOccurrenceAssignments oldExam + , efStart = dateOffset <$> examStart oldExam + , efEnd = dateOffset <$> examEnd oldExam + , efFinished = dateOffset <$> examFinished oldExam + , efClosed = dateOffset <$> examClosed oldExam + , efShowGrades = examShowGrades oldExam + , efPublicStatistics = examPublicStatistics oldExam + , efDescription = examDescription oldExam + , efOccurrences = Set.empty + , efExamParts = Set.empty + , efCorrectors = Set.empty + } + + +validateExam :: (MonadHandler m, HandlerSite m ~ UniWorX) => FormValidator ExamForm m () +validateExam = do + ExamForm{..} <- State.get + + guardValidation MsgExamRegisterToMustBeAfterRegisterFrom $ NTop efRegisterTo >= NTop efRegisterFrom + guardValidation MsgExamDeregisterUntilMustBeAfterRegisterFrom $ NTop efDeregisterUntil >= NTop efRegisterFrom + guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments . fromMaybe True $ (>=) <$> efStart <*> efPublishOccurrenceAssignments + guardValidation MsgExamEndMustBeAfterStart $ NTop efEnd >= NTop efStart + guardValidation MsgExamFinishedMustBeAfterEnd . fromMaybe True $ (>=) <$> efFinished <*> efEnd + guardValidation MsgExamFinishedMustBeAfterStart $ NTop efFinished >= NTop efStart + guardValidation MsgExamClosedMustBeAfterFinished . fromMaybe True $ (>=) <$> efClosed <*> efFinished + guardValidation MsgExamClosedMustBeAfterStart $ NTop efClosed >= NTop efStart + guardValidation MsgExamClosedMustBeAfterEnd . fromMaybe True $ (>=) <$> efClosed <*> efEnd + + forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do + guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart) + guardValidation (MsgExamOccurrenceStartMustBeAfterExamStart eofName) $ NTop (Just eofStart) >= NTop efStart + guardValidation (MsgExamOccurrenceEndMustBeBeforeExamEnd eofName) $ NTop eofEnd <= NTop efEnd + + forM_ [ (a, b) | a <- Set.toAscList efOccurrences, b <- Set.toAscList efOccurrences, b > a ] $ \(a, b) -> do + eofRange' <- formatTimeRange SelFormatDateTime (eofStart a) (eofEnd a) + + guardValidation (MsgExamOccurrenceDuplicate (eofRoom a) eofRange') $ any (\f -> f a b) + [ (/=) `on` eofRoom + , (/=) `on` eofStart + , (/=) `on` eofEnd + , (/=) `on` fmap renderHtml . eofDescription + ] + + guardValidation (MsgExamOccurrenceDuplicateName $ eofName a) $ ((/=) `on` eofName) a b diff --git a/src/Handler/Exam/List.hs b/src/Handler/Exam/List.hs new file mode 100644 index 000000000..752d8e3c1 --- /dev/null +++ b/src/Handler/Exam/List.hs @@ -0,0 +1,60 @@ +module Handler.Exam.List + ( getCExamListR + ) where + +import Import + +import Handler.Utils +import Handler.Utils.Table.Cells + +import qualified Data.Map as Map + +import qualified Database.Esqueleto as E + + +getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCExamListR tid ssh csh = do + Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh + now <- liftIO getCurrentTime + mayCreate <- hasWriteAccessTo $ CourseR tid ssh csh CExamNewR + + let + examDBTable = DBTable{..} + where + dbtSQLQuery exam = do + E.where_ $ exam E.^. ExamCourse E.==. E.val cid + return exam + dbtRowKey = (E.^. ExamId) + dbtProj x@DBRow{ dbrOutput = Entity _ Exam{..} } = do + guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR + return x + dbtColonnade = dbColonnade . mconcat $ catMaybes + [ Just . sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> anchorCell (CExamR tid ssh csh examName EShowR) examName + , (<$ guard mayCreate) . sortable (Just "visible") (i18nCell MsgExamVisibleFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty (dateTimeCellVisible now) examVisibleFrom + , Just . sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom + , Just . sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo + , Just . sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart + ] + dbtSorting = Map.fromList + [ ("name", SortColumn $ \exam -> exam E.^. ExamName ) + , ("time", SortColumn $ \exam -> exam E.^. ExamStart ) + , ("register-from", SortColumn $ \exam -> exam E.^. ExamRegisterFrom ) + , ("register-to", SortColumn $ \exam -> exam E.^. ExamRegisterTo ) + , ("visible", SortColumn $ \exam -> exam E.^. ExamVisibleFrom ) + ] + dbtFilter = Map.empty + dbtFilterUI = const mempty + dbtStyle = def + dbtParams = def + dbtIdent :: Text + dbtIdent = "exams" + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + + examDBTableValidator = def + & defaultSorting [SortAscBy "time"] + ((), examTable) <- runDB $ dbTable examDBTableValidator examDBTable + + siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamsHeading) $ do + setTitleI $ prependCourseTitle tid ssh csh MsgExamsHeading + $(widgetFile "exam-list") diff --git a/src/Handler/Exam/New.hs b/src/Handler/Exam/New.hs new file mode 100644 index 000000000..d6bcfc828 --- /dev/null +++ b/src/Handler/Exam/New.hs @@ -0,0 +1,93 @@ +module Handler.Exam.New + ( getCExamNewR, postCExamNewR + ) where + +import Import +import Handler.Exam.Form +import Handler.Exam.CorrectorInvite + +import qualified Data.Set as Set + +import Handler.Utils +import Handler.Utils.Invitations + +import Jobs.Queue + + +getCExamNewR, postCExamNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCExamNewR = postCExamNewR +postCExamNewR tid ssh csh = do + (cid, template) <- runDB $ do + cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh + template <- examTemplate cid + return (cid, template) + + ((newExamResult, newExamWidget), newExamEnctype) <- runFormPost . validateForm validateExam $ examForm template + + formResult newExamResult $ \ExamForm{..} -> do + insertRes <- runDBJobs $ do + insertRes <- insertUnique Exam + { examName = efName + , examCourse = cid + , examGradingRule = efGradingRule + , examBonusRule = efBonusRule + , examOccurrenceRule = efOccurrenceRule + , examVisibleFrom = efVisibleFrom + , examRegisterFrom = efRegisterFrom + , examRegisterTo = efRegisterTo + , examDeregisterUntil = efDeregisterUntil + , examPublishOccurrenceAssignments = efPublishOccurrenceAssignments + , examStart = efStart + , examEnd = efEnd + , examFinished = efFinished + , examClosed = efClosed + , examShowGrades = efShowGrades + , examPublicStatistics = efPublicStatistics + , examDescription = efDescription + } + whenIsJust insertRes $ \examid -> do + insertMany_ + [ ExamPart{..} + | ExamPartForm{..} <- Set.toList efExamParts + , let examPartExam = examid + examPartName = epfName + examPartMaxPoints = epfMaxPoints + examPartWeight = epfWeight + ] + + insertMany_ + [ ExamOccurrence{..} + | ExamOccurrenceForm{..} <- Set.toList efOccurrences + , let examOccurrenceExam = examid + examOccurrenceName = eofName + examOccurrenceRoom = eofRoom + examOccurrenceCapacity = eofCapacity + examOccurrenceStart = eofStart + examOccurrenceEnd = eofEnd + examOccurrenceDescription = eofDescription + ] + + let (invites, adds) = partitionEithers $ Set.toList efCorrectors + insertMany_ [ ExamCorrector{..} + | examCorrectorUser <- adds + , let examCorrectorExam = examid + ] + sinkInvitationsF examCorrectorInvitationConfig $ map (, examid, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites + return insertRes + case insertRes of + Nothing -> addMessageI Error $ MsgExamNameTaken efName + Just _ -> do + addMessageI Success $ MsgExamCreated efName + redirect $ CourseR tid ssh csh CExamListR + + let heading = prependCourseTitle tid ssh csh MsgExamNew + + siteLayoutMsg heading $ do + setTitleI heading + let + newExamForm = wrapForm newExamWidget def + { formMethod = POST + , formAction = Just . SomeRoute $ CourseR tid ssh csh CExamNewR + , formEncoding = newExamEnctype + } + $(widgetFile "exam-new") diff --git a/src/Handler/Exam/Register.hs b/src/Handler/Exam/Register.hs new file mode 100644 index 000000000..6a7436f7e --- /dev/null +++ b/src/Handler/Exam/Register.hs @@ -0,0 +1,59 @@ +module Handler.Exam.Register + ( ButtonExamRegister(..) + , postERegisterR + ) where + +import Import + +import Handler.Utils +import Handler.Utils.Exam + + +-- Dedicated ExamRegistrationButton +data ButtonExamRegister = BtnExamRegister | BtnExamDeregister + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Universe ButtonExamRegister +instance Finite ButtonExamRegister +nullaryPathPiece ''ButtonExamRegister $ camelToPathPiece' 1 +embedRenderMessage ''UniWorX ''ButtonExamRegister id +instance Button UniWorX ButtonExamRegister where + btnClasses BtnExamRegister = [BCIsButton, BCPrimary] + btnClasses BtnExamDeregister = [BCIsButton, BCDanger] + + btnLabel BtnExamRegister = [whamlet|#{iconExamRegister True} _{MsgBtnExamRegister}|] + btnLabel BtnExamDeregister = [whamlet|#{iconExamRegister False} _{MsgBtnExamDeregister}|] + + +postERegisterR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html + +postERegisterR tid ssh csh examn = do + Entity uid User{..} <- requireAuth + + Entity eId Exam{..} <- runDB $ fetchExam tid ssh csh examn + + ((btnResult, _), _) <- runFormPost buttonForm + + formResult btnResult $ \case + BtnExamRegister -> do + runDB $ do + now <- liftIO getCurrentTime + insert_ $ ExamRegistration eId uid Nothing now + audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent + addMessageWidget Success [whamlet| +
      #{iconExamRegister True} +
        +
      _{MsgExamRegisteredSuccess examn} + |] + redirect $ CExamR tid ssh csh examn EShowR + BtnExamDeregister -> do + runDB $ do + deleteBy $ UniqueExamRegistration eId uid + audit' $ TransactionExamDeregister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent + addMessageWidget Info [whamlet| +
      #{iconExamRegister False} +
        +
      _{MsgExamDeregisteredSuccess examn} + |] -- yes, it's a success message, but it should be visually different from a positive success, since most will just note the positive green color! See discussion on commit 5f4925a4 + redirect $ CExamR tid ssh csh examn EShowR + + invalidArgs ["Register/Deregister button required"] diff --git a/src/Handler/Exam/RegistrationInvite.hs b/src/Handler/Exam/RegistrationInvite.hs new file mode 100644 index 000000000..2552bc9d4 --- /dev/null +++ b/src/Handler/Exam/RegistrationInvite.hs @@ -0,0 +1,112 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Handler.Exam.RegistrationInvite + ( InvitableJunction(..) + , InvitationDBData(..) + , InvitationTokenData(..) + , examRegistrationInvitationConfig + , getEInviteR, postEInviteR + ) where + +import Import +import Handler.Utils +import Handler.Utils.Exam +import Handler.Utils.Invitations + +import qualified Data.Set as Set + +import Text.Hamlet (ihamlet) + +import Utils.Lens + +import Data.Aeson hiding (Result(..)) + + +instance IsInvitableJunction ExamRegistration where + type InvitationFor ExamRegistration = Exam + data InvitableJunction ExamRegistration = JunctionExamRegistration + { jExamRegistrationOccurrence :: Maybe ExamOccurrenceId + , jExamRegistrationTime :: UTCTime + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + data InvitationDBData ExamRegistration = InvDBDataExamRegistration + { invDBExamRegistrationOccurrence :: Maybe ExamOccurrenceId + , invDBExamRegistrationDeadline :: UTCTime + , invDBExamRegistrationCourseRegister :: Bool + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + data InvitationTokenData ExamRegistration = InvTokenDataExamRegistration + deriving (Eq, Ord, Read, Show, Generic, Typeable) + + _InvitableJunction = iso + (\ExamRegistration{..} -> (examRegistrationUser, examRegistrationExam, JunctionExamRegistration examRegistrationOccurrence examRegistrationTime)) + (\(examRegistrationUser, examRegistrationExam, JunctionExamRegistration examRegistrationOccurrence examRegistrationTime) -> ExamRegistration{..}) + +instance ToJSON (InvitableJunction ExamRegistration) where + toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } +instance FromJSON (InvitableJunction ExamRegistration) where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } + +instance ToJSON (InvitationDBData ExamRegistration) where + toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } +instance FromJSON (InvitationDBData ExamRegistration) where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } + +instance ToJSON (InvitationTokenData ExamRegistration) where + toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 } + toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 } +instance FromJSON (InvitationTokenData ExamRegistration) where + parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 } + +examRegistrationInvitationConfig :: InvitationConfig ExamRegistration +examRegistrationInvitationConfig = InvitationConfig{..} + where + invitationRoute (Entity _ Exam{..}) _ = do + Course{..} <- get404 examCourse + return $ CExamR courseTerm courseSchool courseShorthand examName EInviteR + invitationResolveFor = do + Just (CExamR tid csh ssh examn EInviteR) <- getCurrentRoute + fetchExamId tid csh ssh examn + invitationSubject (Entity _ Exam{..}) _ = do + Course{..} <- get404 examCourse + return . SomeMessage $ MsgMailSubjectExamRegistrationInvitation courseTerm courseSchool courseShorthand examName + invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInviteHeading examName + invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgExamRegistrationInviteExplanation}|] + invitationTokenConfig _ (InvDBDataExamRegistration{..}, _) = do + itAuthority <- liftHandlerT requireAuthId + let itExpiresAt = Just $ Just invDBExamRegistrationDeadline + itAddAuth + | not invDBExamRegistrationCourseRegister + = Just . PredDNF . Set.singleton . impureNonNull . Set.singleton $ PLVariable AuthCourseRegistered + | otherwise + = Nothing + itStartsAt = Nothing + return $ InvitationTokenConfig{..} + invitationRestriction _ _ = return Authorized + invitationForm (Entity _ Exam{..}) (InvDBDataExamRegistration{..}, _) uid = hoistAForm liftHandlerT . wFormToAForm $ do + isRegistered <- fmap (is _Just) . liftHandlerT . runDB . getBy $ UniqueParticipant uid examCourse + now <- liftIO getCurrentTime + + case (isRegistered, invDBExamRegistrationCourseRegister) of + (False, False) -> permissionDeniedI MsgUnauthorizedParticipant + (False, True ) -> do + fieldRes <- wreq (studyFeaturesPrimaryFieldFor False [] $ Just uid) (fslI MsgCourseStudyFeature) Nothing + return $ (JunctionExamRegistration invDBExamRegistrationOccurrence now, ) . Just <$> fieldRes + (True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing) + invitationInsertHook (Entity _ Exam{..}) _ ExamRegistration{..} mField act = do + whenIsJust mField $ + insert_ . CourseParticipant examCourse examRegistrationUser examRegistrationTime + + Course{..} <- get404 examCourse + User{..} <- get404 examRegistrationUser + let doAudit = audit' $ TransactionExamRegister (unTermKey courseTerm) (unSchoolKey courseSchool) courseShorthand examName userIdent + act <* doAudit + invitationSuccessMsg (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInvitationAccepted examName + invitationUltDest (Entity _ Exam{..}) _ = do + Course{..} <- get404 examCourse + return . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName EShowR + + +getEInviteR, postEInviteR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html +getEInviteR = postEInviteR +postEInviteR _ _ _ _ = invitationR' examRegistrationInvitationConfig diff --git a/src/Handler/Exam/Show.hs b/src/Handler/Exam/Show.hs new file mode 100644 index 000000000..0e34f360c --- /dev/null +++ b/src/Handler/Exam/Show.hs @@ -0,0 +1,106 @@ +module Handler.Exam.Show + ( getEShowR + ) where + +import Import +import Handler.Exam.Register + +import Utils.Lens hiding (parts) + +import Data.Map ((!?)) +import qualified Data.Map as Map + +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E + +import qualified Data.CaseInsensitive as CI + +import Handler.Utils +import Handler.Utils.Exam + + +getEShowR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html +getEShowR tid ssh csh examn = do + cTime <- liftIO getCurrentTime + mUid <- maybeAuthId + + (Entity _ Exam{..}, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown) <- runDB $ do + exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn + + let examVisible = NTop (Just cTime) >= NTop examVisibleFrom + + let gradingVisible = NTop (Just cTime) >= NTop examFinished + gradingShown <- or2M (return gradingVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR + + let occurrenceAssignmentsVisible = NTop (Just cTime) >= NTop examPublishOccurrenceAssignments + occurrenceAssignmentsShown <- or2M (return occurrenceAssignmentsVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR + + parts <- selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ] + + resultsRaw <- for mUid $ \uid -> + E.select . E.from $ \examPartResult -> do + E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val uid + E.&&. examPartResult E.^. ExamPartResultExamPart `E.in_` E.valList (map entityKey parts) + return examPartResult + let results = maybe Map.empty (\rs -> Map.fromList [ (examPartResultExamPart, res) | res@(Entity _ ExamPartResult{..}) <- rs ]) resultsRaw + + result <- fmap join . for mUid $ getBy . UniqueExamResult eId + + occurrencesRaw <- E.select . E.from $ \examOccurrence -> do + E.where_ $ examOccurrence E.^. ExamOccurrenceExam E.==. E.val eId + let + registered + | Just uid <- mUid + = E.exists . E.from $ \examRegistration -> do + E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eId + E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val uid + E.&&. examRegistration E.^. ExamRegistrationOccurrence E.==. E.just (examOccurrence E.^. ExamOccurrenceId) + | otherwise = E.false + E.orderBy [E.desc registered, E.asc $ examOccurrence E.^. ExamOccurrenceStart, E.asc $ examOccurrence E.^. ExamOccurrenceRoom] + return (examOccurrence, registered) + + let occurrences = map (over _2 E.unValue) occurrencesRaw + + registered <- for mUid $ existsBy . UniqueExamRegistration eId + mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True + + occurrenceNamesShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR + + return (exam, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown) + + let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences + registerWidget + | Just isRegistered <- registered + , mayRegister = Just $ do + (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered + [whamlet| +

      + $if isRegistered + _{MsgExamRegistered} + $else + _{MsgExamNotRegistered} + |] + wrapForm examRegisterForm def + { formAction = Just . SomeRoute $ CExamR tid ssh csh examName ERegisterR + , formEncoding = examRegisterEnctype + , formSubmit = FormNoSubmit + } + | fromMaybe False registered = Just [whamlet|_{MsgExamRegistered}|] + | otherwise = Nothing + + let heading = prependCourseTitle tid ssh csh $ CI.original examName + + siteLayoutMsg heading $ do + setTitleI heading + let + gradingKeyW :: [Points] -> Widget + gradingKeyW bounds + = let boundWidgets :: [Widget] + boundWidgets = toWidget . (pack :: String -> Text) . showFixed True <$> 0 : bounds + grades :: [ExamGrade] + grades = universeF + in $(widgetFile "widgets/gradingKey") + + examBonusW :: ExamBonusRule -> Widget + examBonusW bonusRule = $(widgetFile "widgets/bonusRule") + $(widgetFile "exam-show") diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs new file mode 100644 index 000000000..65d7413d1 --- /dev/null +++ b/src/Handler/Exam/Users.hs @@ -0,0 +1,531 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Handler.Exam.Users + ( getEUsersR, postEUsersR + ) where + +import Import + +import Utils.Lens +import Handler.Utils +import Handler.Utils.Exam +import Handler.Utils.Table.Columns +import Handler.Utils.Table.Cells +import Handler.Utils.Csv + +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E +import Database.Esqueleto.Utils.TH + +import qualified Data.Csv as Csv + +import Data.Map ((!)) +import qualified Data.Map as Map +import qualified Data.Set as Set + +import qualified Data.Text as Text +import qualified Data.Text.Lens as Text + +import qualified Data.Conduit.List as C + +import qualified Data.CaseInsensitive as CI + +import Numeric.Lens (integral) +import Control.Arrow (Kleisli(..)) + +import Database.Persist.Sql (deleteWhereCount, updateWhereCount) + + +type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity CourseParticipant)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)))) +type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence), Maybe (Entity StudyFeatures), Maybe (Entity StudyDegree), Maybe (Entity StudyTerms)) + +instance HasEntity ExamUserTableData User where + hasEntity = _dbrOutput . _2 + +instance HasUser ExamUserTableData where + hasUser = _dbrOutput . _2 . _entityVal + +_userTableOccurrence :: Lens' ExamUserTableData (Maybe (Entity ExamOccurrence)) +_userTableOccurrence = _dbrOutput . _3 + +queryUser :: ExamUserTableExpr -> E.SqlExpr (Entity User) +queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) + +queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures)) +queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3) + +queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration) +queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) + +queryExamOccurrence :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamOccurrence)) +queryExamOccurrence = $(sqlLOJproj 3 2) + +queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree)) +queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3) + +queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms)) +queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3) + +resultExamRegistration :: Lens' ExamUserTableData (Entity ExamRegistration) +resultExamRegistration = _dbrOutput . _1 + +resultUser :: Lens' ExamUserTableData (Entity User) +resultUser = _dbrOutput . _2 + +resultStudyFeatures :: Traversal' ExamUserTableData (Entity StudyFeatures) +resultStudyFeatures = _dbrOutput . _4 . _Just + +resultStudyDegree :: Traversal' ExamUserTableData (Entity StudyDegree) +resultStudyDegree = _dbrOutput . _5 . _Just + +resultStudyField :: Traversal' ExamUserTableData (Entity StudyTerms) +resultStudyField = _dbrOutput . _6 . _Just + +resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence) +resultExamOccurrence = _dbrOutput . _3 . _Just + +data ExamUserTableCsv = ExamUserTableCsv + { csvEUserSurname :: Maybe Text + , csvEUserName :: Maybe Text + , csvEUserMatriculation :: Maybe Text + , csvEUserField :: Maybe Text + , csvEUserDegree :: Maybe Text + , csvEUserSemester :: Maybe Int + , csvEUserOccurrence :: Maybe (CI Text) + , csvEUserExercisePoints :: Maybe Points + , csvEUserExercisePasses :: Maybe Int + , csvEUserExercisePointsMax :: Maybe Points + , csvEUserExercisePassesMax :: Maybe Int + } + deriving (Generic) + +examUserTableCsvOptions :: Csv.Options +examUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3 } + +instance ToNamedRecord ExamUserTableCsv where + toNamedRecord = Csv.genericToNamedRecord examUserTableCsvOptions + +instance FromNamedRecord ExamUserTableCsv where + parseNamedRecord = Csv.genericParseNamedRecord examUserTableCsvOptions + +instance DefaultOrdered ExamUserTableCsv where + headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions + +instance CsvColumnsExplained ExamUserTableCsv where + csvColumnsExplanations = genericCsvColumnsExplanations examUserTableCsvOptions $ Map.fromList + [ ('csvEUserSurname , MsgCsvColumnExamUserSurname ) + , ('csvEUserName , MsgCsvColumnExamUserName ) + , ('csvEUserMatriculation , MsgCsvColumnExamUserMatriculation ) + , ('csvEUserField , MsgCsvColumnExamUserField ) + , ('csvEUserDegree , MsgCsvColumnExamUserDegree ) + , ('csvEUserSemester , MsgCsvColumnExamUserSemester ) + , ('csvEUserOccurrence , MsgCsvColumnExamUserOccurrence ) + , ('csvEUserExercisePoints , MsgCsvColumnExamUserExercisePoints ) + , ('csvEUserExercisePasses , MsgCsvColumnExamUserExercisePasses ) + , ('csvEUserExercisePointsMax, MsgCsvColumnExamUserExercisePointsMax ) + , ('csvEUserExercisePassesMax, MsgCsvColumnExamUserExercisePassesMax ) + ] + +data ExamUserAction = ExamUserDeregister + | ExamUserAssignOccurrence + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) + +instance Universe ExamUserAction +instance Finite ExamUserAction +nullaryPathPiece ''ExamUserAction $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''ExamUserAction id + +data ExamUserActionData = ExamUserDeregisterData + | ExamUserAssignOccurrenceData (Maybe ExamOccurrenceId) + +data ExamUserCsvActionClass + = ExamUserCsvCourseRegister + | ExamUserCsvRegister + | ExamUserCsvAssignOccurrence + | ExamUserCsvSetCourseField + | ExamUserCsvDeregister + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +embedRenderMessage ''UniWorX ''ExamUserCsvActionClass id + +data ExamUserCsvAction + = ExamUserCsvCourseRegisterData + { examUserCsvActUser :: UserId + , examUserCsvActCourseField :: Maybe StudyFeaturesId + , examUserCsvActOccurrence :: Maybe ExamOccurrenceId + } + | ExamUserCsvRegisterData + { examUserCsvActUser :: UserId + , examUserCsvActOccurrence :: Maybe ExamOccurrenceId + } + | ExamUserCsvAssignOccurrenceData + { examUserCsvActRegistration :: ExamRegistrationId + , examUserCsvActOccurrence :: Maybe ExamOccurrenceId + } + | ExamUserCsvSetCourseFieldData + { examUserCsvActCourseParticipant :: CourseParticipantId + , examUserCsvActCourseField :: Maybe StudyFeaturesId + } + | ExamUserCsvDeregisterData + { examUserCsvActRegistration :: ExamRegistrationId + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) +deriveJSON defaultOptions + { constructorTagModifier = over Text.packed $ Text.intercalate "-" . map Text.toLower . drop 3 . dropEnd 1 . splitCamel + , fieldLabelModifier = camelToPathPiece' 3 + , sumEncoding = TaggedObject "action" "data" + } ''ExamUserCsvAction + +data ExamUserCsvException + = ExamUserCsvExceptionNoMatchingUser + | ExamUserCsvExceptionNoMatchingStudyFeatures + | ExamUserCsvExceptionNoMatchingOccurrence + deriving (Show, Generic, Typeable) + +instance Exception ExamUserCsvException + +embedRenderMessage ''UniWorX ''ExamUserCsvException id + +getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html +getEUsersR = postEUsersR +postEUsersR tid ssh csh examn = do + (registrationResult, examUsersTable) <- runDB $ do + exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn + bonus <- examBonus exam + + let + allBoni = (mappend <$> normalSummary <*> bonusSummary) $ fold bonus + showPasses = numSheetsPasses allBoni /= 0 + showPoints = getSum (numSheetsPoints allBoni) /= 0 + + let + examUsersDBTable = DBTable{..} + where + dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField))) = do + E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField + E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree + E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField) + E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse) + E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId) + E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid) + E.&&. occurrence E.?. ExamOccurrenceId E.==. examRegistration E.^. ExamRegistrationOccurrence + E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId + E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid + return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField) + dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId) + dbtProj = return + dbtColonnade = mconcat $ catMaybes + [ pure $ dbSelect (applying _2) id $ return . view (resultExamRegistration . _entityKey) + , pure $ colUserNameLink (CourseR tid ssh csh . CUserR) + , pure colUserMatriclenr + , pure $ colField resultStudyField + , pure $ colDegreeShort resultStudyDegree + , pure $ colFeaturesSemester resultStudyFeatures + , pure $ sortable (Just "occurrence") (i18nCell MsgExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence + , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do + SheetGradeSummary{achievedPasses} <- examBonusAchieved uid bonus + SheetGradeSummary{numSheetsPasses} <- examBonusPossible uid bonus + return $ propCell (getSum achievedPasses) (getSum numSheetsPasses) + , guardOn showPoints $ sortable Nothing (i18nCell MsgAchievedPoints) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do + SheetGradeSummary{achievedPoints} <- examBonusAchieved uid bonus + SheetGradeSummary{sumSheetsPoints} <- examBonusPossible uid bonus + return $ propCell (getSum achievedPoints) (getSum sumSheetsPoints) + ] + dbtSorting = Map.fromList + [ sortUserNameLink queryUser + , sortUserSurname queryUser + , sortUserDisplayName queryUser + , sortUserMatriclenr queryUser + , sortField queryStudyField + , sortDegreeShort queryStudyDegree + , sortFeaturesSemester queryStudyFeatures + , ("occurrence", SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)) + ] + dbtFilter = Map.fromList + [ fltrUserNameEmail queryUser + , fltrUserMatriclenr queryUser + , fltrField queryStudyField + , fltrDegree queryStudyDegree + , fltrFeaturesSemester queryStudyFeatures + , ("occurrence", FilterColumn . E.mkContainsFilterWith Just $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)) + ] + dbtFilterUI mPrev = mconcat + [ fltrUserNameEmailUI mPrev + , fltrUserMatriclenrUI mPrev + , fltrFieldUI mPrev + , fltrDegreeUI mPrev + , fltrFeaturesSemesterUI mPrev + , prismAForm (singletonFilter "occurrence") mPrev $ aopt textField (fslI MsgExamOccurrence) + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + dbtParams = DBParamsForm + { dbParamsFormMethod = POST + , dbParamsFormAction = Just . SomeRoute $ CExamR tid ssh csh examn EUsersR + , dbParamsFormAttrs = [] + , dbParamsFormSubmit = FormSubmit + , dbParamsFormAdditional = \csrf -> do + let + actionMap :: Map ExamUserAction (AForm Handler ExamUserActionData) + actionMap = Map.fromList + [ ( ExamUserDeregister + , pure ExamUserDeregisterData + ) + , ( ExamUserAssignOccurrence + , ExamUserAssignOccurrenceData + <$> aopt (examOccurrenceField eid) (fslI MsgExamOccurrence) (Just Nothing) + ) + ] + (res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf + let formRes = (, mempty) . First . Just <$> res + return (formRes, formWgt) + , dbParamsFormEvaluate = liftHandlerT . runFormPost + , dbParamsFormResult = id + , dbParamsFormIdent = def + } + dbtIdent :: Text + dbtIdent = "exam-users" + dbtCsvEncode :: DBTCsvEncode ExamUserTableData ExamUserTableCsv + dbtCsvEncode = DictJust . C.map $ ExamUserTableCsv + <$> view (resultUser . _entityVal . _userSurname . to Just) + <*> view (resultUser . _entityVal . _userDisplayName . to Just) + <*> view (resultUser . _entityVal . _userMatrikelnummer) + <*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just) + <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just) + <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester) + <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName) + <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPoints . _Wrapped) + <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPasses . _Wrapped . integral) + <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped) + <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral) + dbtCsvDecode = Just DBTCsvDecode + { dbtCsvRowKey = \csv -> do + uid <- lift $ view _2 <$> guessUser csv + fmap E.Value . MaybeT . getKeyBy $ UniqueExamRegistration eid uid + , dbtCsvComputeActions = \case + DBCsvDiffMissing{dbCsvOldKey} + -> yield . ExamUserCsvDeregisterData $ E.unValue dbCsvOldKey + DBCsvDiffNew{dbCsvNewKey = Just _} + -> fail "An UniqueExamRegistration could be found, but the ExamRegistrationKey is not among the existing keys" + DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do + (isPart, uid) <- lift $ guessUser dbCsvNew + if + | isPart -> do + yieldM $ ExamUserCsvRegisterData <$> pure uid <*> lookupOccurrence dbCsvNew + newFeatures <- lift $ lookupStudyFeatures dbCsvNew + Just (Entity cpId CourseParticipant{ courseParticipantField = oldFeatures }) <- lift . getBy $ UniqueParticipant uid examCourse + when (newFeatures /= oldFeatures) $ + yield $ ExamUserCsvSetCourseFieldData cpId newFeatures + | otherwise -> + yieldM $ ExamUserCsvCourseRegisterData uid <$> lookupStudyFeatures dbCsvNew <*> lookupOccurrence dbCsvNew + DBCsvDiffExisting{..} -> do + newOccurrence <- lift $ lookupOccurrence dbCsvNew + when (newOccurrence /= dbCsvOld ^? resultExamOccurrence . _entityKey) $ + yield $ ExamUserCsvAssignOccurrenceData (E.unValue dbCsvOldKey) newOccurrence + + newFeatures <- lift $ lookupStudyFeatures dbCsvNew + when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $ do + Just (Entity cpId _) <- lift . getBy . flip UniqueParticipant examCourse $ dbCsvOld ^. resultUser . _entityKey + yield $ ExamUserCsvSetCourseFieldData cpId newFeatures + , dbtCsvClassifyAction = \case + ExamUserCsvCourseRegisterData{} -> ExamUserCsvCourseRegister + ExamUserCsvRegisterData{} -> ExamUserCsvRegister + ExamUserCsvDeregisterData{} -> ExamUserCsvDeregister + ExamUserCsvAssignOccurrenceData{} -> ExamUserCsvAssignOccurrence + ExamUserCsvSetCourseFieldData{} -> ExamUserCsvSetCourseField + , dbtCsvCoarsenActionClass = \case + ExamUserCsvCourseRegister -> DBCsvActionNew + ExamUserCsvRegister -> DBCsvActionNew + ExamUserCsvDeregister -> DBCsvActionMissing + _other -> DBCsvActionExisting + , dbtCsvExecuteActions = do + C.mapM_ $ \case + ExamUserCsvCourseRegisterData{..} -> do + now <- liftIO getCurrentTime + insert_ CourseParticipant + { courseParticipantCourse = examCourse + , courseParticipantUser = examUserCsvActUser + , courseParticipantRegistration = now + , courseParticipantField = examUserCsvActCourseField + } + User{userIdent} <- getJust examUserCsvActUser + audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent + insert_ ExamRegistration + { examRegistrationExam = eid + , examRegistrationUser = examUserCsvActUser + , examRegistrationOccurrence = examUserCsvActOccurrence + , examRegistrationTime = now + } + ExamUserCsvRegisterData{..} -> do + examRegistrationTime <- liftIO getCurrentTime + insert_ ExamRegistration + { examRegistrationExam = eid + , examRegistrationUser = examUserCsvActUser + , examRegistrationOccurrence = examUserCsvActOccurrence + , .. + } + ExamUserCsvAssignOccurrenceData{..} -> + update examUserCsvActRegistration [ ExamRegistrationOccurrence =. examUserCsvActOccurrence ] + ExamUserCsvSetCourseFieldData{..} -> + update examUserCsvActCourseParticipant [ CourseParticipantField =. examUserCsvActCourseField ] + ExamUserCsvDeregisterData{..} -> do + ExamRegistration{examRegistrationUser} <- getJust examUserCsvActRegistration + User{userIdent} <- getJust examRegistrationUser + audit' $ TransactionExamDeregister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent + delete examUserCsvActRegistration + return $ CExamR tid ssh csh examn EUsersR + , dbtCsvRenderKey = \(registeredUserName -> registeredUserName') -> \case + ExamUserCsvCourseRegisterData{..} -> do + (User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust + [whamlet| + $newline never + ^{nameWidget userDisplayName userSurname} + $maybe features <- examUserCsvActCourseField + , ^{studyFeaturesWidget features} + $nothing + , _{MsgCourseStudyFeatureNone} + $maybe ExamOccurrence{examOccurrenceName} <- occ + \ (#{examOccurrenceName}) + $nothing + \ (_{MsgExamNoOccurrence}) + |] + ExamUserCsvRegisterData{..} -> do + (User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust + [whamlet| + $newline never + ^{nameWidget userDisplayName userSurname} + $maybe ExamOccurrence{examOccurrenceName} <- occ + \ (#{examOccurrenceName}) + $nothing + \ (_{MsgExamNoOccurrence}) + |] + ExamUserCsvAssignOccurrenceData{..} -> do + occ <- for examUserCsvActOccurrence $ liftHandlerT . runDB . getJust + [whamlet| + $newline never + ^{registeredUserName' examUserCsvActRegistration} + $maybe ExamOccurrence{examOccurrenceName} <- occ + \ (#{examOccurrenceName}) + $nothing + \ (_{MsgExamNoOccurrence}) + |] + ExamUserCsvSetCourseFieldData{..} -> do + User{..} <- liftHandlerT . runDB $ getJust . courseParticipantUser =<< getJust examUserCsvActCourseParticipant + [whamlet| + $newline never + ^{nameWidget userDisplayName userSurname} + $maybe features <- examUserCsvActCourseField + , ^{studyFeaturesWidget features} + $nothing + , _{MsgCourseStudyFeatureNone} + |] + ExamUserCsvDeregisterData{..} + -> registeredUserName' examUserCsvActRegistration + , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure + , dbtCsvRenderException = ap getMessageRender . pure :: ExamUserCsvException -> DB Text + } + where + studyFeaturesWidget :: StudyFeaturesId -> Widget + studyFeaturesWidget featId = do + (StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandlerT . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField) + [whamlet| + $newline never + _{StudyDegreeTerm degree terms}, _{MsgStudyFeatureAge} #{studyFeaturesSemester} + |] + + registeredUserName :: Map (E.Value ExamRegistrationId) ExamUserTableData -> ExamRegistrationId -> Widget + registeredUserName existing (E.Value -> registration) = nameWidget userDisplayName userSurname + where + Entity _ User{..} = view resultUser $ existing ! registration + + guessUser :: ExamUserTableCsv -> DB (Bool, UserId) + guessUser ExamUserTableCsv{..} = $cachedHereBinary (csvEUserMatriculation, csvEUserName, csvEUserSurname) $ do + users <- E.select . E.from $ \user -> do + E.where_ . E.and $ catMaybes + [ (user E.^. UserMatrikelnummer E.==.) . E.val . Just <$> csvEUserMatriculation + , (user E.^. UserDisplayName E.==.) . E.val <$> csvEUserName + , (user E.^. UserSurname E.==.) . E.val <$> csvEUserSurname + ] + let isCourseParticipant = E.exists . E.from $ \courseParticipant -> + E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. E.val examCourse + E.&&. courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId + E.limit 2 + return $ (isCourseParticipant, user E.^. UserId) + case users of + (filter . view $ _1 . _Value -> [(E.Value isPart, E.Value uid)]) + -> return (isPart, uid) + [(E.Value isPart, E.Value uid)] + -> return (isPart, uid) + _other + -> throwM ExamUserCsvExceptionNoMatchingUser + + lookupOccurrence :: ExamUserTableCsv -> DB (Maybe ExamOccurrenceId) + lookupOccurrence ExamUserTableCsv{..} = $cachedHereBinary (CI.foldedCase <$> csvEUserOccurrence) . for csvEUserOccurrence $ \occName -> do + occIds <- selectKeysList [ ExamOccurrenceName ==. occName, ExamOccurrenceExam ==. eid ] [] + case occIds of + [occId] -> return occId + _other -> throwM ExamUserCsvExceptionNoMatchingOccurrence + + lookupStudyFeatures :: ExamUserTableCsv -> DB (Maybe StudyFeaturesId) + lookupStudyFeatures csv@ExamUserTableCsv{..} = do + uid <- view _2 <$> guessUser csv + studyFeatures <- E.select . E.from $ \(studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyTerms) -> do + E.on $ studyTerms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField + E.on $ studyDegree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree + E.where_ . E.and $ catMaybes + [ do + field <- csvEUserField + return . E.or $ catMaybes + [ Just $ studyTerms E.^. StudyTermsName `E.ciEq` E.just (E.val field) + , Just $ studyTerms E.^. StudyTermsShorthand `E.ciEq` E.just (E.val field) + , (studyTerms E.^. StudyTermsKey E.==.) . E.val <$> readMay field + ] + , do + degree <- csvEUserDegree + return . E.or $ catMaybes + [ Just $ studyDegree E.^. StudyDegreeName `E.ciEq` E.just (E.val degree) + , Just $ studyDegree E.^. StudyDegreeShorthand `E.ciEq` E.just (E.val degree) + , (studyDegree E.^. StudyDegreeKey E.==.) . E.val <$> readMay degree + ] + , (studyFeatures E.^. StudyFeaturesSemester E.==.) . E.val <$> csvEUserSemester + ] + E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid + E.&&. studyFeatures E.^. StudyFeaturesType E.==. E.val FieldPrimary + E.&&. studyFeatures E.^. StudyFeaturesValid E.==. E.val True + E.limit 2 + return $ studyFeatures E.^. StudyFeaturesId + case studyFeatures of + [E.Value fid] -> return $ Just fid + _other + | is _Nothing csvEUserField + , is _Nothing csvEUserDegree + , is _Nothing csvEUserSemester + -> return Nothing + _other -> throwM ExamUserCsvExceptionNoMatchingStudyFeatures + + examUsersDBTableValidator = def + + postprocess :: FormResult (First ExamUserActionData, DBFormResult ExamRegistrationId Bool ExamUserTableData) -> FormResult (ExamUserActionData, Set ExamRegistrationId) + postprocess inp = do + (First (Just act), regMap) <- inp + let regSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) regMap + return (act, regSet) + over _1 postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable + + formResult registrationResult $ \case + (ExamUserDeregisterData, selectedRegistrations) -> do + nrDel <- runDB $ deleteWhereCount + [ ExamRegistrationId <-. Set.toList selectedRegistrations + ] + addMessageI Success $ MsgExamUsersDeregistered nrDel + redirect $ CExamR tid ssh csh examn EUsersR + (ExamUserAssignOccurrenceData occId, selectedRegistrations) -> do + nrUpdated <- runDB $ updateWhereCount + [ ExamRegistrationId <-. Set.toList selectedRegistrations + ] + [ ExamRegistrationOccurrence =. occId + ] + addMessageI Success $ MsgExamUsersOccurrenceUpdated nrUpdated + redirect $ CExamR tid ssh csh examn EUsersR + + siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamUsersHeading) $ do + setTitleI $ prependCourseTitle tid ssh csh MsgExamUsersHeading + $(widgetFile "exam-users") diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index b7548543c..3f01c2eb3 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -1000,3 +1000,36 @@ multiUserField onlySuggested suggestions = Field{..} [] -> return $ Left email [E.Value uid] -> return $ Right uid _other -> fail "Ambiguous e-mail addr" + +examResultField :: forall m res. + ( MonadHandler m + , HandlerSite m ~ UniWorX + , PathPiece res + ) + => Field m res -> Field m (ExamResult' res) +examResultField innerField = Field + { fieldEnctype = UrlEncoded <> fieldEnctype innerField + , fieldParse = \ts fs -> if + | [t] <- ts + , Just res <- fromPathPiece t + , is _ExamNoShow res || is _ExamVoided res + -> return . Right $ Just res + | otherwise + -> fmap (fmap ExamAttended) <$> fieldParse innerField ts fs + , fieldView = \theId name attrs val isReq -> do + innerId <- newIdent + let + val' :: ExamResult' (Either Text res) + val' = either (ExamAttended . Left) (fmap Right) val + innerVal :: Either Text res + innerVal = val >>= maybe (Left "") return . preview _ExamAttended + [whamlet| + $newline never + -

      - ^{fieldView innerField innerId name attrs innerVal False} +
      + + $maybe optMsg' <- assertM (const $ not isReq) optMsg +