refactor(lms): send user notifications only after lms acknowleged e-learning

messages/uniworx/categories/qualification/de-de-formal.msg

@@ -23,12 +23,14 @@ TableLmsDelete: Löschen?
 TableLmsStaff: Interner Mitarbeiter?
 TableLmsStarted: Begonnen
 TableLmsReceived: Letzte Rückmeldung
+TableLmsNotified: Versand Benachrichtigung
 TableLmsEnded: Beended
 TableLmsStatus: Status E-Lernen
 TableLmsSuccess: Bestanden
 TableLmsFailed: Gesperrt
 FilterLmsValid: Aktuell gültig
 FilterLmsRenewal: Erneuerung anstehend
+FilterLmsNotified: Benachrichtigt
 CsvColumnLmsIdent: E-Lernen Identifikator, einzigartig pro Qualifikation und Teilnehmer
 CsvColumnLmsPin: PIN des E-Lernen Zugangs
 CsvColumnLmsResetPin: Wird die PIN bei der nächsten Synchronisation zurückgesetzt?

messages/uniworx/categories/qualification/en-eu.msg

@@ -23,12 +23,14 @@ TableLmsDelete: Delete?
 TableLmsStaff: Staff?
 TableLmsStarted: Started
 TableLmsReceived: Last update
+TableLmsNotified: Notification sent
 TableLmsEnded: Ended
 TableLmsStatus: Status e-learning
 TableLmsSuccess: Completed
 TableLmsFailed: Blocked
 FilterLmsValid: Currently valid
 FilterLmsRenewal: Renewal due
+FilterLmsNotified: Notified
 CsvColumnLmsIdent: E-learning identifier, unique for each qualification and user
 CsvColumnLmsPin: PIN for e-learning access
 CsvColumnLmsResetPin: Will the e-learning PIN be reset upon next synchronisation?

models/lms.model

@@ -100,6 +100,7 @@ LmsUser
   --toDelete encoded by Handler.Utils.LMS.lmsUserToDelete
   started           UTCTime       default=now()
   received          UTCTime Maybe               -- last acknowledgement by LMS 
+  notified          UTCTime Maybe               -- last notified by FRADrive
   ended             UTCTime Maybe               -- ident was deleted from LMS 
   -- Primary ident -- newtype Key LmsUserId = LmsUserKey { unLmsUser :: Text } -- change LmsIdent -> Text. Do we want this?
   UniqueLmsIdent ident                           -- idents must be unique accross all qualifications, since idents are global within LMS!

src/Handler/LMS.hs

@@ -343,6 +343,7 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
       , single ("lms-started" , SortColumn $ queryLmsUser  >>> (E.?. LmsUserStarted))
       , single ("lms-datepin" , SortColumn $ queryLmsUser  >>> (E.?. LmsUserDatePin))
       , single ("lms-received", SortColumn $ queryLmsUser  >>> (E.?. LmsUserReceived))
+      , single ("lms-notified", SortColumn $ queryLmsUser  >>> (E.?. LmsUserNotified))
       , single ("lms-ended"   , SortColumn $ queryLmsUser  >>> (E.?. LmsUserEnded))
       ]
     dbtFilter = mconcat
@@ -356,12 +357,19 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
                                           E.&&.  quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
              | otherwise -> E.true
         )
+      , single ("lms-notified", FilterColumn $ \(view (to queryLmsUser) -> luser) criterion ->
+          case getLast criterion of
+            Just True  -> E.isJust    $ luser E.?. LmsUserNotified
+            Just False -> E.isNothing $ luser E.?. LmsUserNotified
+            Nothing    -> E.true
+        )
       ]
     dbtFilterUI mPrev = mconcat
       [ fltrUserNameEmailHdrUI MsgLmsUser mPrev
-      , prismAForm (singletonFilter "lms-ident"   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
+      , prismAForm (singletonFilter "lms-ident"    . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
       -- , prismAForm (singletonFilter "lms-status"  . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return (optionsPairs [(MsgTableLmsSuccess,"success"::Text),(MsgTableLmsFailed,"blocked")])) (fslI MsgTableLmsStatus)
-      , prismAForm (singletonFilter "validity"    . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
+      , prismAForm (singletonFilter "validity"     . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
+      , prismAForm (singletonFilter "lms-notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified)
       , if isNothing mbRenewal then mempty
         else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
       ]
@@ -446,6 +454,7 @@ postLmsR sid qsh = do
           , sortable (Just "lms-started")   (i18nLms MsgTableLmsStarted)  $ \(preview $ resultLmsUser  . _entityVal . _lmsUserStarted  -> d) -> foldMap dateTimeCell        d
           , sortable (Just "lms-datepin")   (i18nLms MsgTableLmsDatePin)  $ \(preview $ resultLmsUser  . _entityVal . _lmsUserDatePin  -> d) -> foldMap dateTimeCell        d
           , sortable (Just "lms-received")  (i18nLms MsgTableLmsReceived) $ \(preview $ resultLmsUser  . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell $ join d
+          , sortable (Just "lms-notified")  (i18nLms MsgTableLmsNotified) $ \(preview $ resultLmsUser  . _entityVal . _lmsUserNotified -> d) -> foldMap dateTimeCell $ join d
           , sortable (Just "lms-ended")     (i18nLms MsgTableLmsEnded)    $ \(preview $ resultLmsUser  . _entityVal . _lmsUserEnded    -> d) -> foldMap dateTimeCell $ join d
           ]
           where

src/Jobs/Handler/LMS.hs

@@ -1,15 +1,15 @@
 {-# LANGUAGE TypeApplications #-}
 
-module Jobs.Handler.LMS 
+module Jobs.Handler.LMS
   ( dispatchJobLmsQualificationsEnqueue
   , dispatchJobLmsQualificationsDequeue
   , dispatchJobLmsEnqueue, dispatchJobLmsEnqueueUser
   , dispatchJobLmsDequeue
   , dispatchJobLmsResults
   , dispatchJobLmsUserlist
-  ) where 
+  ) where
 
-import Import    
+import Import
 import Jobs.Queue
 
 -- import Jobs.Handler.Intervals.Utils
@@ -23,198 +23,196 @@ import Handler.Utils.LMS (randomLMSIdent, randomLMSpw, maxLmsUserIdentRetries)
 
 
 dispatchJobLmsQualificationsEnqueue :: JobHandler UniWorX
-dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic act
+dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsEnqueue
-  where
+
-    act :: YesodJobDB UniWorX ()
+dispatchJobLmsQualificationsDequeue :: JobHandler UniWorX
-    act = do 
+dispatchJobLmsQualificationsDequeue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsDequeue
-      qids <- E.select $ do 
+
-                q <- E.from $ E.table @Qualification
+-- execute given job for all qualifications that allow refreshs
-                E.where_ $  E.isJust (q E.^. QualificationRefreshWithin)
+fetchRefreshQualifications :: (QualificationId -> Job) -> YesodJobDB UniWorX ()
-                    -- E.&&. q E.^. QualificationElearningStart -- checked later, since we need to send out notifications regardless
+fetchRefreshQualifications qidJob = do
-                pure $ q E.^. QualificationId
+  qids <- E.select $ do
-      forM_ qids $ \(E.unValue -> qid) ->
+            q <- E.from $ E.table @Qualification
-        queueDBJob $ JobLmsEnqueue qid 
+            E.where_ $  E.isJust (q E.^. QualificationRefreshWithin)
+            pure $ q E.^. QualificationId
+  forM_ qids $ \(E.unValue -> qid) ->
+    queueDBJob $ qidJob qid
 
 
--- | enlist expiring qualification holders to e-learning 
+-- | enlist expiring qualification holders to e-learning
 --   NOTE: getting rid of QualificationId parameter and using a DB-join fails, since addGregorianDurationClip cannot be performed within DB
 dispatchJobLmsEnqueue :: QualificationId -> JobHandler UniWorX
 dispatchJobLmsEnqueue qid = JobHandlerAtomic act
-  where     
+  where
     -- act :: YesodJobDB UniWorX ()
     act = do
-      $logInfoS "lms" $ "Start e-learning users for qualification " <> tshow qid <> "."        
+      $logInfoS "lms" $ "Notifying about exipiring qualification " <> tshow qid <> "."
       quali <- getJust qid -- may throw an error, aborting the job
-      now <- liftIO getCurrentTime      
+      now <- liftIO getCurrentTime
-      case qualificationRefreshWithin quali of 
+      case qualificationRefreshWithin quali of
-        Nothing -> return () -- no automatic scheduling for this qid 
+        Nothing -> return () -- no automatic scheduling for this qid
         (Just renewalPeriod) -> do
           let now_day     = utctDay now
               renewalDate = addGregorianDurationClip renewalPeriod now_day
           renewalUsers <- E.select $ do
-            quser <- E.from $ E.table @QualificationUser 
+            quser <- E.from $ E.table @QualificationUser
-            E.where_ $  quser E.^. QualificationUserQualification E.==. E.val qid 
+            E.where_ $  quser E.^. QualificationUserQualification E.==. E.val qid
                   E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val now_day
                   E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate
                   E.&&. E.notExists (do
                           luser <- E.from $ E.table @LmsUser
-                          E.where_ $  luser E.^. LmsUserQualification E.==. E.val qid 
+                          E.where_ $  luser E.^. LmsUserQualification E.==. E.val qid
                                 E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
                         )
             pure quser
-          let usr_job :: Entity QualificationUser -> Job 
+          let usr_job :: Entity QualificationUser -> Job
-              usr_job quser = 
+              usr_job quser =
-                let uid = quser ^. _entityVal . _qualificationUserUser      
+                let uid = quser ^. _entityVal . _qualificationUserUser
                     uex = quser ^. _entityVal . _qualificationUserValidUntil
                 in if qualificationElearningStart quali
                     then JobLmsEnqueueUser { jQualification = qid, jUser = uid  }
-                    else JobSendNotification { jRecipient = uid, jNotification = 
+                    else JobSendNotification { jRecipient = uid, jNotification =
                               NotificationQualificationExpiry { nQualification = qid, nExpiry = uex }
                          }
           forM_ renewalUsers (queueDBJob . usr_job)
-      case qualificationAuditDuration quali of 
+      case qualificationAuditDuration quali of
         Nothing -> return () -- no automatic removal
-        (Just auditDuration) -> 
+        (Just auditDuration) ->
           let deleteDate = addMonths auditDuration now
           in  deleteWhere [LmsUserQualification ==. qid, LmsUserEnded !=. Nothing, LmsUserEnded >. Just deleteDate]
 
 dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX
-dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act 
+dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
-  where 
+  where
     act :: YesodJobDB UniWorX ()
-    act = do 
+    act = do
       now <- liftIO getCurrentTime
       let mkLmsUser lid lpin = LmsUser
             { lmsUserQualification = qid
-            , lmsUserUser          = uid 
+            , lmsUserUser          = uid
-            , lmsUserIdent         = lid 
+            , lmsUserIdent         = lid
-            , lmsUserPin           = lpin 
+            , lmsUserPin           = lpin
-            , lmsUserResetPin      = False 
+            , lmsUserResetPin      = False
             , lmsUserDatePin       = now
             , lmsUserStatus        = Nothing
-            , lmsUserStarted       = now 
+            , lmsUserStarted       = now
             , lmsUserReceived      = Nothing
-            , lmsUserEnded         = Nothing 
+            , lmsUserNotified      = Nothing
+            , lmsUserEnded         = Nothing
             }
           -- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser))
           startLmsUser = E.insertUniqueEntity =<< (mkLmsUser <$> randomLMSIdent <*> randomLMSpw)
       inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser
-      case inserted of 
+      case inserted of
         Nothing  -> $logErrorS "LMS" $ "Generating and inserting fresh LmsIdent failed for uid " <> tshow uid <> " and qid " <> tshow qid <> "!"
-        (Just _) -> queueDBJob JobSendNotification { jRecipient = uid, jNotification = 
+        (Just _) -> return () -- lmsUser started, but not yet notified
-                        NotificationQualificationRenewal { nQualification = qid }
-                      }
 
 
-dispatchJobLmsQualificationsDequeue :: JobHandler UniWorX
+-- process all received input and renew qualifications
-dispatchJobLmsQualificationsDequeue = JobHandlerAtomic act
-  where
-    act :: YesodJobDB UniWorX ()
-    act = do 
-      qids <- E.select $ do 
-                q <- E.from $ E.table @Qualification
-                E.where_ $  E.isJust (q E.^. QualificationRefreshWithin)
-                    -- E.&&. q E.^. QualificationElearningStart -- checked later, since we need to send out notifications regardless
-                pure $ q E.^. QualificationId
-      forM_ qids $ \(E.unValue -> qid) ->        
-        queueDBJob $ JobLmsEnqueue qid 
-
 dispatchJobLmsDequeue :: QualificationId -> JobHandler UniWorX
 dispatchJobLmsDequeue qid = JobHandlerAtomic act
-  -- wenn bestanden: qualification verlängern 
+  -- wenn bestanden: qualification verlängern
   -- wenn Aufbewahrungszeit abgelaufen: LmsIdent löschen (verhindert verfrühten neustart)
-  where 
+  where
     act = do
-      $logInfoS "lms" $ "Process e-learning results for qualification " <> tshow qid <> "."        
+      $logInfoS "lms" $ "Processing e-learning results for qualification " <> tshow qid <> "."
       quali <- getJust qid -- may throw an error, aborting the job
-      case qualificationRefreshWithin quali of 
+      case qualificationRefreshWithin quali of
-        Nothing -> return () -- no automatic scheduling for this qid 
+        Nothing -> return () -- no automatic scheduling for this qid (usually job is not scheduled for these qualifications, see above)
         (Just renewalPeriod) -> do
           now_day <- utctDay <$> liftIO getCurrentTime
           let renewalDate = addGregorianDurationClip renewalPeriod now_day
-          
+
-          -- CONTINUE HERE:
+          -- CONTINUE HERE: TODO
           --   select users that need renewal due to success
-          --   delete users after audit period has expired            
+          --   delete users after audit period has expired!!!
 
           renewalUsers <- E.select $ do
             (quser E.:& luser) <- E.from $ E.table @QualificationUser `E.innerJoin` E.table @LmsUser
                     `E.on` (\(quser E.:& luser) -> quser E.^. QualificationUserUser          E.==. luser E.^. LmsUserUser
                                             E.&&.  quser E.^. QualificationUserQualification E.==. luser E.^. LmsUserQualification
                             )
-            E.where_ $  E.val qid E.==. quser E.^. QualificationUserQualification 
+            E.where_ $  E.val qid E.==. quser E.^. QualificationUserQualification
-                  E.&&. E.val qid E.==. luser E.^. LmsUserQualification             
+                  E.&&. E.val qid E.==. luser E.^. LmsUserQualification
                   E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val now_day              -- still valid
                   E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate          -- due to renewal
-                  E.&&. E.isJust (luser E.^. LmsUserStatus) -- TODO: should check for success   -- result already known                                 
+                  E.&&. E.isJust (luser E.^. LmsUserStatus) -- TODO: should check for success   -- result already known
             pure (quser, luser)
-          let usr_job (quser, luser) = 
+          let usr_job (quser, luser) =
                 let vold   = quser ^. _entityVal . _qualificationUserValidUntil
-                    pmonth = fromMonths $ fromMaybe 0 $ qualificationValidDuration quali -- TODO: decide how to deal with qualification that have infinite validity?!
+                    pmonth = fromMonths $ fromMaybe 0 $ qualificationValidDuration quali -- TODO: decide how to deal with qualifications that have infinite validity?!
                     vnew   = addGregorianDurationClip pmonth vold
                     lmsstatus = luser ^. _entityVal . _lmsUserStatus
-                in case lmsstatus of 
+                in case lmsstatus of
-                  Just (LmsSuccess refreshDay) -> update (quser ^. _entityKey) [QualificationUserValidUntil =. vnew, QualificationUserLastRefresh =. refreshDay] 
+                  Just (LmsSuccess refreshDay) -> update (quser ^. _entityKey) [QualificationUserValidUntil =. vnew, QualificationUserLastRefresh =. refreshDay]
                   _ -> return ()
           forM_ renewalUsers usr_job
 
 
+-- just processes received input, but does not affect any exisitng qualifications yet
 dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX
-dispatchJobLmsResults qid = JobHandlerAtomic act 
+dispatchJobLmsResults qid = JobHandlerAtomic act
   where
     -- act :: YesodJobDB UniWorX ()
     act = hoist lift $ do
       now <- liftIO getCurrentTime
       -- result :: [(Entity LmsUser, Entity LmsResult)]
-      results <- E.select $ do 
+      results <- E.select $ do
-        (luser E.:& lresult) <- E.from $ 
+        (luser E.:& lresult) <- E.from $
-            E.table @LmsUser `E.innerJoin` E.table @LmsResult 
+            E.table @LmsUser `E.innerJoin` E.table @LmsResult
-            `E.on` (\(luser E.:& lresult) -> luser E.^. LmsUserIdent         E.==. lresult E.^. LmsResultIdent 
+            `E.on` (\(luser E.:& lresult) -> luser E.^. LmsUserIdent         E.==. lresult E.^. LmsResultIdent
                                        E.&&. luser E.^. LmsUserQualification E.==. lresult E.^. LmsResultQualification)
         E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
           E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners
         return (luser, lresult)
-      forM_ results $ \(Entity luid luser, Entity lrid lresult) -> do 
+      forM_ results $ \(Entity luid luser, Entity lrid lresult) -> do
         -- three separate DB operations per result is not so nice. All within one transaction though.
-        let lreceived = lmsResultTimestamp lresult 
+        let lreceived = lmsResultTimestamp lresult
-            newStatus = lmsResultSuccess   lresult & LmsSuccess 
+            newStatus = lmsResultSuccess   lresult & LmsSuccess
             oldStatus = lmsUserStatus luser
             saneDate  = lmsResultSuccess   lresult `inBetween` (utctDay $ lmsUserStarted luser, utctDay now)
         -- always log success, since this is only transmitted once
-        if saneDate 
+        if saneDate
-          then  
+          then
             update luid [ LmsUserStatus   =. (oldStatus <> Just newStatus)
-                        , LmsUserReceived =. Just lreceived 
+                        , LmsUserReceived =. Just lreceived
                         ]
-          else 
+          else
             $logErrorS "LmsResult" [st|LMS success with insane date #{tshow (lmsResultSuccess lresult)} received|]
         insert_ $ LmsAudit qid (lmsUserIdent luser) newStatus lreceived now
-        delete lrid                   
+        delete lrid
       $logInfoS "LmsResult" [st|Processed #{tshow (length results)} LMS results|]
 
+
+-- just processes received input, but does not affect any exisitng qualifications yet
 dispatchJobLmsUserlist :: QualificationId -> JobHandler UniWorX
-dispatchJobLmsUserlist  qid = JobHandlerAtomic act 
+dispatchJobLmsUserlist  qid = JobHandlerAtomic act
   where
-    -- act :: YesodJobDB UniWorX ()
+    act :: YesodJobDB UniWorX ()
-    act = hoist lift $ do
+    act = do
       now <- liftIO getCurrentTime
       -- result :: [(Entity LmsUser, Entity LmsUserlist)]
-      results <- E.select $ do 
+      results <- E.select $ do
-        (luser E.:& lulist) <- E.from $ 
+        (luser E.:& lulist) <- E.from $
             E.table @LmsUser `E.leftJoin` E.table @LmsUserlist
-            `E.on` (\(luser E.:& lulist) ->  luser E.^. LmsUserIdent         E.=?. lulist E.?. LmsUserlistIdent 
+            `E.on` (\(luser E.:& lulist) ->  luser E.^. LmsUserIdent         E.=?. lulist E.?. LmsUserlistIdent
                                        E.&&. luser E.^. LmsUserQualification E.=?. lulist E.?. LmsUserlistQualification)
         E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
                   E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners
         return (luser, lulist)
-      forM_ results $ \case 
+      forM_ results $ \case
-        (Entity luid luser, Nothing) 
+        (Entity luid luser, Nothing)
-          | isJust    $ lmsUserReceived luser
+          | isJust    $ lmsUserReceived luser          -- mark all unreported users as ended
-          , isNothing $ lmsUserEnded    luser ->            
+          , isNothing $ lmsUserEnded    luser ->
               update luid [LmsUserEnded =. Just now]
-          | otherwise -> return () -- likely not yet started
+          | otherwise -> return ()                     -- users likely not yet started
 
-        (Entity luid luser, Just (Entity lulid lulist)) -> do           
+        (Entity luid luser, Just (Entity lulid lulist)) -> do
+          when (isNothing $ lmsUserNotified luser) $ -- notify users that lms is available
+            queueDBJob JobSendNotification
+              { jRecipient    = lmsUserUser luser
+              , jNotification = NotificationQualificationRenewal { nQualification = qid }
+              }
           let lReceived = lmsUserlistTimestamp lulist
               isBlocked = lmsUserlistFailed lulist
               newStatus = LmsBlocked $ utctDay lReceived

src/Jobs/Handler/SendNotification/Qualification.hs

@@ -49,7 +49,7 @@ dispatchNotificationQualificationExpiry nQualification _nExpiry jRecipient = use
 -- NOTE: qualificationRenewal expects that LmsUser already exists for recipient
 dispatchNotificationQualificationRenewal :: QualificationId -> UserId -> Handler ()
 dispatchNotificationQualificationRenewal nQualification jRecipient = do
-  (recipient@User{..}, Qualification{..}, Entity _ QualificationUser{..}, Entity _ LmsUser{..}) <- runDB $ (,,,)
+  (recipient@User{..}, Qualification{..}, Entity _ QualificationUser{..}, Entity luid LmsUser{..}) <- runDB $ (,,,)
     <$> getJust jRecipient
     <*> getJust nQualification
     <*> getJustBy (UniqueQualificationUser    nQualification jRecipient)
@@ -120,5 +120,9 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
 
         editNotifications <- mkEditNotifications jRecipient
         addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet")
+  -- if we reach the end, mark the user as notified
+  -- TODO: defer this until the print job is marked as sent?
+  runDB $
+    update luid [ LmsUserNotified =. Just now]
 
     

test/Database/Fill.hs

@@ -37,13 +37,13 @@ import Data.List (foldl)
 import System.Directory (getModificationTime, doesDirectoryExist)
 import System.FilePath.Glob (glob)
 
-{- Needed for File Tests only 
+{- Needed for File Tests only
 import qualified Data.Conduit.Combinators as C
 import Paths_uniworx (getDataFileName)
 
 testdataFile :: MonadIO m => FilePath -> m FilePath
 testdataFile = liftIO . getDataFileName . ("testdata" </>)
-  
+
 insertFile :: ( HasFileReference fRef, PersistRecordBackend fRef SqlBackend ) => FileReferenceResidual fRef -> FilePath -> DB (Key fRef)
 insertFile residual fileTitle = do
   filepath <- testdataFile fileTitle
@@ -60,25 +60,25 @@ fillDb = do
   let
     insert' :: (PersistRecordBackend r (YesodPersistBackend UniWorX), AtLeastOneUniqueKey r) => r -> YesodDB UniWorX (Key r)
     insert' = fmap (either entityKey id) . insertBy
-    
+
-    addBDays = addBusinessDays Fraport -- holiday area to use 
+    addBDays = addBusinessDays Fraport -- holiday area to use
-    n_day n  = addBDays n $ utctDay now 
+    n_day n  = addBDays n $ utctDay now
     n_day' n = now { utctDay = n_day n }
     currentTerm = TermIdentifier . fst3 . toGregorian $ utctDay now
-    -- (currentYear, currentMonth, currentDay) = toGregorian $ getTermDay currentTerm    
+    -- (currentYear, currentMonth, currentDay) = toGregorian $ getTermDay currentTerm
     nextTerm n = toEnum . (+n) $ fromEnum currentTerm
 
-    termTime :: TermIdentifier     -- ^ Term 
+    termTime :: TermIdentifier     -- ^ Term
-             -> TermDay            -- ^ Relative to which day? 
+             -> TermDay            -- ^ Relative to which day?
              -> Integer            -- ^ Week offset from TermDayStart/End of Term (shuld be negative for TermDayEnd)
              -> Maybe WeekDay      -- ^ Move to weekday
              -> (Day -> UTCTime)   -- ^ Add time to day
              -> UTCTime
     termTime gTid gTD weekOffset mbWeekDay = ($ tDay)
-      where        
+      where
-        gDay = addDays (7* weekOffset) $ guessDay gTid gTD          
+        gDay = addDays (7* weekOffset) $ guessDay gTid gTD
-        tDay = maybe gDay (`firstDayOfWeekOnAfter` gDay) mbWeekDay         
+        tDay = maybe gDay (`firstDayOfWeekOnAfter` gDay) mbWeekDay
-    
+
   gkleen <- insert User
     { userIdent  = "G.Kleen@campus.lmu.de"
     , userAuthentication = AuthLDAP
@@ -107,9 +107,9 @@ fillDb = do
     , userCsvOptions = def { csvFormat = csvPreset # CsvPresetRFC }
     , userSex = Just SexMale
     , userShowSex = userDefaultShowSex
-    , userTelephone = Nothing 
+    , userTelephone = Nothing
-    , userMobile = Nothing 
+    , userMobile = Nothing
-    , userCompanyPersonalNumber = Nothing 
+    , userCompanyPersonalNumber = Nothing
     , userCompanyDepartment = Nothing
     , userPinPassword = Nothing
     , userPostAddress = Nothing
@@ -145,9 +145,9 @@ fillDb = do
     , userCsvOptions = def { csvFormat = csvPreset # CsvPresetExcel }
     , userSex = Just SexMale
     , userShowSex = userDefaultShowSex
-    , userMobile = Nothing 
+    , userMobile = Nothing
-    , userTelephone = Nothing     
+    , userTelephone = Nothing
-    , userCompanyPersonalNumber = Nothing 
+    , userCompanyPersonalNumber = Nothing
     , userCompanyDepartment = Nothing
     , userPinPassword = Nothing
     , userPostAddress = Nothing
@@ -227,9 +227,9 @@ fillDb = do
     , userCsvOptions = def
     , userSex = Just SexMale
     , userShowSex = userDefaultShowSex
-    , userTelephone = Nothing 
+    , userTelephone = Nothing
-    , userMobile = Nothing 
+    , userMobile = Nothing
-    , userCompanyPersonalNumber = Nothing 
+    , userCompanyPersonalNumber = Nothing
     , userCompanyDepartment = Nothing
     , userPinPassword = Nothing
     , userPostAddress = Nothing
@@ -265,9 +265,9 @@ fillDb = do
     , userCsvOptions = def
     , userSex = Just SexNotApplicable
     , userShowSex = userDefaultShowSex
-    , userTelephone = Nothing 
+    , userTelephone = Nothing
-    , userMobile = Nothing 
+    , userMobile = Nothing
-    , userCompanyPersonalNumber = Nothing 
+    , userCompanyPersonalNumber = Nothing
     , userCompanyDepartment = Nothing
     , userPinPassword = Nothing
     , userPostAddress = Nothing
@@ -303,9 +303,9 @@ fillDb = do
     , userCsvOptions = def
     , userSex = Just SexFemale
     , userShowSex = userDefaultShowSex
-    , userTelephone = Nothing 
+    , userTelephone = Nothing
-    , userMobile = Nothing 
+    , userMobile = Nothing
-    , userCompanyPersonalNumber = Nothing 
+    , userCompanyPersonalNumber = Nothing
     , userCompanyDepartment = Nothing
     , userPinPassword = Nothing
     , userPostAddress = Nothing
@@ -341,9 +341,9 @@ fillDb = do
     , userCsvOptions = def
     , userSex = Just SexMale
     , userShowSex = userDefaultShowSex
-    , userTelephone = Nothing 
+    , userTelephone = Nothing
-    , userMobile = Nothing 
+    , userMobile = Nothing
-    , userCompanyPersonalNumber = Nothing 
+    , userCompanyPersonalNumber = Nothing
     , userCompanyDepartment = Nothing
     , userPinPassword = Nothing
     , userPostAddress = Nothing
@@ -409,9 +409,9 @@ fillDb = do
       , userCsvOptions = def
       , userSex = Nothing
       , userShowSex = userDefaultShowSex
-      , userTelephone = Nothing 
+      , userTelephone = Nothing
-      , userMobile = Nothing 
+      , userMobile = Nothing
-      , userCompanyPersonalNumber = Nothing 
+      , userCompanyPersonalNumber = Nothing
       , userCompanyDepartment = Nothing
       , userPinPassword = Nothing
       , userPostAddress = Nothing
@@ -426,7 +426,7 @@ fillDb = do
           Nothing          -> repack [st|#{firstName}.#{userSurname}@example.invalid|]
   matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int)
   manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel
-    
+
   let tmin   = -1
       tmax   = 2
       trange = [tmin..tmax]
@@ -434,21 +434,21 @@ fillDb = do
       dmax   = guessDay (nextTerm tmax) TermDayEnd
       hdys   = foldl (<>) mempty $ [bankHolidaysAreaSet Fraport y | y <- [getYear dmin..getYear dmax]]
   terms <- forM trange $ \nr -> do
-    let tid = nextTerm nr 
+    let tid = nextTerm nr
-        tk  = TermKey tid 
+        tk  = TermKey tid
         tStart = guessDay tid TermDayStart
         tEnd   = guessDay tid TermDayEnd
-        term = Term { termName     = tid 
+        term = Term { termName     = tid
                     , termStart    = tStart
                     , termEnd      = tEnd
-                    , termHolidays = toList $ Set.filter (\d -> tStart <= d && d <= tEnd) hdys 
+                    , termHolidays = toList $ Set.filter (\d -> tStart <= d && d <= tEnd) hdys
                     , termLectureStart = guessDay tid TermDayLectureStart
                     , termLectureEnd   = guessDay tid TermDayLectureEnd
                     }
-    repsert tk term 
+    repsert tk term
     insert_ $ TermActive tk (toMidnight $ termStart term) (Just . beforeMidnight $ termEnd term) Nothing
     return tk
-  
+
   ifiAuthorshipStatement <- insertAuthorshipStatement I18n
     { i18nFallback = htmlToStoredMarkup
         [shamlet|
@@ -501,8 +501,8 @@ fillDb = do
 
   let f_descr = Just $ htmlToStoredMarkup [shamlet|<p>Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.|]
   let r_descr = Just $ htmlToStoredMarkup [shamlet|<p>Berechtigung zum Führen eines Fahrzeuges auf dem gesamten Rollfeld.|]
-  let l_descr = Just $ htmlToStoredMarkup [shamlet|<p>für unhabilitierte|]  
+  let l_descr = Just $ htmlToStoredMarkup [shamlet|<p>für unhabilitierte|]
-  qid_f  <- insert' $ Qualification avn "F" "Vorfeldführerschein"  f_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 0 60) True 
+  qid_f  <- insert' $ Qualification avn "F" "Vorfeldführerschein"  f_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 0 60) True
   qid_r  <- insert' $ Qualification avn "R" "Rollfeldführerschein" r_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 2 3)  False
   qid_l  <- insert' $ Qualification ifi "L" "Lehrbefähigung"       l_descr Nothing   (Just 6) Nothing True
   void . insert' $ QualificationUser jost       qid_f (n_day    9) (n_day $ -1) (n_day $ -22) -- TODO: better dates!
@@ -516,17 +516,17 @@ fillDb = do
   void . insert' $ QualificationUser fhamann    qid_r (n_day $ -3) (n_day $ -1) (n_day $  -2)
   void . insert' $ QualificationUser svaupel    qid_l (n_day    1) (n_day $ -1) (n_day $  -2)
   void . insert' $ QualificationUser gkleen     qid_l (n_day    9) (n_day $ -1) (n_day $  -7)
-  void . insert' $ LmsResult qid_f (LmsIdent "hijklmn") (n_day (-1)) now 
+  void . insert' $ LmsResult qid_f (LmsIdent "hijklmn") (n_day (-1)) now
-  void . insert' $ LmsResult qid_f (LmsIdent "opqgrs" ) (n_day (-2)) now 
+  void . insert' $ LmsResult qid_f (LmsIdent "opqgrs" ) (n_day (-2)) now
-  void . insert' $ LmsResult qid_f (LmsIdent "pqgrst" ) (n_day (-3)) now 
+  void . insert' $ LmsResult qid_f (LmsIdent "pqgrst" ) (n_day (-3)) now
-  void . insert' $ LmsUserlist qid_f (LmsIdent "hijklmn") False now 
+  void . insert' $ LmsUserlist qid_f (LmsIdent "hijklmn") False now
-  void . insert' $ LmsUserlist qid_f (LmsIdent "abcdefg") True  now 
+  void . insert' $ LmsUserlist qid_f (LmsIdent "abcdefg") True  now
-  void . insert' $ LmsUserlist qid_f (LmsIdent "ijk"    ) False now 
+  void . insert' $ LmsUserlist qid_f (LmsIdent "ijk"    ) False now
-  void . insert' $ LmsUser qid_f jost        (LmsIdent "ijk"    ) "123" False now Nothing now Nothing Nothing
+  void . insert' $ LmsUser qid_f jost        (LmsIdent "ijk"    ) "123" False now Nothing                           now Nothing    Nothing Nothing
-  void . insert' $ LmsUser qid_f svaupel     (LmsIdent "abcdefg") "abc" False now (Just $ LmsSuccess $ n_day 1) now (Just now) Nothing
+  void . insert' $ LmsUser qid_f svaupel     (LmsIdent "abcdefg") "abc" False now (Just $ LmsSuccess $ n_day 1)     now (Just now) Nothing Nothing
-  void . insert' $ LmsUser qid_f gkleen      (LmsIdent "hijklmn") "@#!" True  now (Just $ LmsBlocked $ utctDay now) now (Just now) Nothing
+  void . insert' $ LmsUser qid_f gkleen      (LmsIdent "hijklmn") "@#!" True  now (Just $ LmsBlocked $ utctDay now) now (Just now) Nothing Nothing
-  void . insert' $ LmsUser qid_f tinaTester  (LmsIdent "qwvu")    "45678" True now (Just $ LmsSuccess $ n_day (-2)) now Nothing Nothing
+  void . insert' $ LmsUser qid_f tinaTester  (LmsIdent "qwvu")  "45678" True  now (Just $ LmsSuccess $ n_day (-2))  now Nothing    (Just $ n_day' (-1)) Nothing
-  void . insert' $ LmsUser qid_f maxMuster   (LmsIdent "xyz")    "a1b2c3" False now (Just $ LmsBlocked $ n_day (-1)) now (Just $ n_day' (-2)) (Just $ n_day' (-1))
+  void . insert' $ LmsUser qid_f maxMuster   (LmsIdent "xyz")  "a1b2c3" False now (Just $ LmsBlocked $ n_day (-1))  now (Just $ n_day' (-2)) (Just $ n_day' (-2)) (Just $ n_day' (-1))
 
   void . insert $ PrintJob "TestJob1" "job1" "No Text herein." (n_day' (-1)) Nothing Nothing        (Just svaupel)  Nothing (Just qid_f)
   void . insert $ PrintJob "TestJob2" "job2" "No Text herein." (n_day' (-1)) Nothing (Just jost)    (Just svaupel)  Nothing (Just qid_f)
@@ -535,7 +535,7 @@ fillDb = do
   void . insert $ PrintJob "TestJob5" "job5" "No Text herein." (n_day' (-4)) Nothing (Just jost)    (Just svaupel)  Nothing (Just qid_r)
   void . insert $ PrintJob "TestJob6" "job6" "No Text herein." (n_day' (-4)) Nothing (Just svaupel) Nothing         Nothing (Just qid_r)
   void . insert $ PrintJob "TestJob7" "job7" "No Text herein." (n_day' (-4)) Nothing (Just svaupel) Nothing         Nothing Nothing
-  
+
 
   let
     examLabels = Map.fromList
@@ -718,19 +718,19 @@ fillDb = do
     now
     True
     Nothing
-  
+
-  
+
   -- Fahrschule F
   forM_ terms $ \tk -> do
-    let  tid = unTermKey tk 
+    let  tid = unTermKey tk
-         jtt = (((Just .) .) .) . termTime tid                  
+         jtt = (((Just .) .) .) . termTime tid
          firstDay  = utctDay $ termTime tid TermDayLectureStart 0 Nothing toMidnight
          secondDay = utctDay $ termTime tid TermDayLectureStart 1 Nothing toMidnight
-         weekDay = dayOfWeek firstDay 
+         weekDay = dayOfWeek firstDay
          -- thirdDay  = utctDay $ termTime tid TermDayLectureStart 2 Nothing toMidnight
          capacity = Just 8
-         mkName = CI.mk 
+         mkName = CI.mk
-    do 
+    do
         c <- insert' Course
           { courseName = mkName "Vorfeldführerschein"
           , courseDescription = Just $ htmlToStoredMarkup [shamlet|
@@ -739,7 +739,7 @@ fillDb = do
                 <section>
                   <h3>Benötigte Unterlagen
                   <ul>
-                    <li>Sehtest, 
+                    <li>Sehtest,
                       <i>bitte vorab hochladen!
                     <li>Regulärer Führerschein,
                       <i>Bitte mitbringen.
@@ -753,7 +753,7 @@ fillDb = do
           , courseVisibleTo       = jtt TermDayEnd            0  Nothing   beforeMidnight
           , courseRegisterFrom    = jtt TermDayStart          0  Nothing       toMidnight
           , courseRegisterTo      = jtt TermDayLectureStart (-1) Nothing       toMidnight
-          , courseDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight 
+          , courseDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight
           , courseRegisterSecret  = Nothing
           , courseMaterialFree    = True
           , courseApplicationsRequired = False
@@ -784,44 +784,44 @@ fillDb = do
           , sheetAuthorshipStatementMode = SheetAuthorshipStatementModeExam
           , sheetAuthorshipStatementExam = Nothing
           , sheetAuthorshipStatement = Nothing
-          }    
+          }
-        -- TODO: Maybe split into to Tutorials with 
+        -- TODO: Maybe split into to Tutorials with
         -- occurrencesSchedule = Set.fromList [ ScheduleWeekly { scheduleDayOfWeek = weekDay, scheduleStart = TimeOfDay 8 30 0, scheduleEnd = TimeOfDay 16 0 0} ]
-        tut1 <- insert Tutorial 
+        tut1 <- insert Tutorial
           { tutorialName = mkName "Theorieschulung"
           , tutorialCourse = c
           , tutorialType = "Schulung"
           , tutorialCapacity = capacity
-          , tutorialRoom = Just $ case weekDay of 
+          , tutorialRoom = Just $ case weekDay of
                 Monday -> "A380"
                 Tuesday -> "B747"
                 Wednesday -> "MD11"
                 Thursday -> "A380"
-                _ -> "B777"                               
+                _ -> "B777"
           , tutorialRoomHidden = False
           , tutorialTime = Occurrences
-            { occurrencesScheduled = Set.empty 
+            { occurrencesScheduled = Set.empty
-            , occurrencesExceptions = Set.fromList 
+            , occurrencesExceptions = Set.fromList
-                [ ExceptOccur 
+                [ ExceptOccur
                     { exceptDay   = firstDay
-                    , exceptStart = TimeOfDay  8 30  0 
+                    , exceptStart = TimeOfDay  8 30  0
-                    , exceptEnd   = TimeOfDay 16  0  0 
+                    , exceptEnd   = TimeOfDay 16  0  0
                     }
                 , ExceptOccur
                     { exceptDay   = secondDay
-                    , exceptStart = TimeOfDay  9  0  0 
+                    , exceptStart = TimeOfDay  9  0  0
-                    , exceptEnd   = TimeOfDay 16  0  0 
+                    , exceptEnd   = TimeOfDay 16  0  0
                     }
-                ]              
+                ]
             }
           , tutorialRegGroup        = Just "schulung"
           , tutorialRegisterFrom    = jtt TermDayStart          0  Nothing       toMidnight
           , tutorialRegisterTo      = jtt TermDayLectureStart (-1) Nothing       toMidnight
-          , tutorialDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight 
+          , tutorialDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight
           , tutorialLastChanged     = now
           , tutorialTutorControlled = True
           }
-        insert_ $ Tutor tut1 jost 
+        insert_ $ Tutor tut1 jost
         void . insert' $ Exam
             { examCourse = c
             , examName = mkName "Theorieprüfung"
@@ -832,9 +832,9 @@ fillDb = do
             , examVisibleFrom     = jtt TermDayStart          0  Nothing       toMidnight
             , examRegisterFrom    = jtt TermDayStart          0  Nothing       toMidnight
             , examRegisterTo      = jtt TermDayLectureStart (-1) Nothing       toMidnight
-            , examDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight 
+            , examDeregisterUntil = jtt TermDayLectureStart (-5) (Just Monday) toMidnight
             , examPublishOccurrenceAssignments = Nothing
-            , examStart = Just $ toTimeOfDay 16  0  0 secondDay 
+            , examStart = Just $ toTimeOfDay 16  0  0 secondDay
             , examEnd   = Just $ toTimeOfDay 16 30  0 secondDay
             , examFinished = Nothing
             , examPartsFrom = Nothing
@@ -851,7 +851,7 @@ fillDb = do
             , examStaff = Just "Jost"
             , examAuthorshipStatement = Nothing
             }
-  
+
   testMsg <- insert SystemMessage
     { systemMessageNewsOnly = False
     , systemMessageFrom = Just now
@@ -912,7 +912,7 @@ fillDb = do
     , systemMessageCreated = now
     , systemMessageLastChanged = now
     , systemMessageLastUnhide = now
-    }  
+    }
   void $ insert SystemMessage
     { systemMessageNewsOnly = True
     , systemMessageFrom = Just now
@@ -929,7 +929,7 @@ fillDb = do
     , systemMessageLastUnhide = now
     }
 
-  {- 
+  {-
   aSeedFunc <- liftIO $ getRandomBytes 40
   funAlloc <- insert' Allocation
     { allocationName = "Funktionale Zentralanmeldung"
@@ -940,10 +940,10 @@ fillDb = do
     , allocationDescription = Nothing
     , allocationStaffDescription = Nothing
     , allocationStaffRegisterFrom = Just now
-    , allocationStaffRegisterTo = Just $ 300 `addUTCTime` now 
+    , allocationStaffRegisterTo = Just $ 300 `addUTCTime` now
     , allocationStaffAllocationFrom = Just $ 300 `addUTCTime` now
     , allocationStaffAllocationTo = Just $ 900 `addUTCTime` now
-    , allocationRegisterFrom = Just $ 300 `addUTCTime` now 
+    , allocationRegisterFrom = Just $ 300 `addUTCTime` now
     , allocationRegisterTo = Just $ 600 `addUTCTime` now
     , allocationRegisterByStaffFrom = Nothing
     , allocationRegisterByStaffTo = Nothing
@@ -953,7 +953,7 @@ fillDb = do
     }
   insert_ $ AllocationCourse funAlloc pmo 100 Nothing Nothing
   insert_ $ AllocationCourse funAlloc ffp 2 (Just $ 2300 `addUTCTime` now) Nothing
-  
+
   void . insertMany $ map (\(u, pState) -> CourseParticipant ffp u now (Just funAlloc) pState)
     [ (svaupel, CourseParticipantInactive False)
     , (jost, CourseParticipantActive)
@@ -977,7 +977,7 @@ fillDb = do
         Just User{ userMatrikelnummer = Just matr } ->
           return . pure $ Csv.Only matr
         _other -> return mempty
-  
+
   liftIO . handle (\(_ :: IOException) -> return ()) $ do
     haveTestdata <- doesDirectoryExist "testdata"
     LBS.writeFile (bool id ("testdata" </>) haveTestdata "bigAlloc_numeric.csv") $ Csv.encode numericPriorities