diff --git a/models/print.model b/models/print.model index fa8475a04..e3b8aeadb 100644 --- a/models/print.model +++ b/models/print.model @@ -12,6 +12,6 @@ PrintJob sender UserId Maybe OnDeleteSetNull OnUpdateCascade -- senders and associations are optional course CourseId Maybe OnDeleteCascade OnUpdateCascade qualification QualificationId Maybe OnDeleteCascade OnUpdateCascade - lmsUser LmsUserId Maybe OnDeleteCascade OnUpdateCascade -- allows tracking if recipient has been notified; must be unique - -- UniquePrintJobLmsUser lmsUser + lmsUser LmsIdent Maybe OnDeleteCascade OnUpdateCascade -- allows tracking if recipient has been notified; must be unique + -- UniquePrintJobLmsUser lmsUser -- Note that in fact multiple print jobs per LMS user are possible! deriving Generic \ No newline at end of file diff --git a/routes b/routes index 0c9f88666..9a5ea50ad 100644 --- a/routes +++ b/routes @@ -14,7 +14,7 @@ -- Admins always have access to entities within their assigned schools. -- -- Access tags are defined in Model.Types.Security --- +-- -- Access Tags: -- !free -- free for all -- !lecturer -- lecturer for this course (or for any school, if route is not connected to a course) @@ -66,10 +66,12 @@ /admin/tokens AdminTokensR GET POST /admin/crontab AdminCrontabR GET /admin/avs AdminAvsR GET POST -/admin/ldap AdminLdapR GET POST +/admin/ldap AdminLdapR GET POST /print PrintCenterR GET POST !system-printer -/print/acknowledge/#Day/#Int/#Int PrintAcknowR GET POST !system-printer +/print/acknowledge/#Day/#Int/#Int PrintAckR GET POST !system-printer +/print/acknowledge/direct PrintAckDirectR POST !system-printer +/print/acknowledge/free/direct PrintAckFreeR POST !development /print/send PrintSendR GET POST /print/download/#CryptoUUIDPrintJob PrintDownloadR GET !system-printer diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index b783a442a..e28735137 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -118,7 +118,9 @@ breadcrumb AdminLdapR = i18nCrumb MsgMenuLdap $ Just AdminR breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR breadcrumb PrintDownloadR{} = i18nCrumb MsgMenuPrintDownload $ Just PrintCenterR -breadcrumb PrintAcknowR{} = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR +breadcrumb PrintAckR{} = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR -- never displayed +breadcrumb PrintAckDirectR{}= i18nCrumb MsgMenuPrintSend $ Just PrintCenterR -- never displayed +breadcrumb PrintAckFreeR{} = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR -- never displayed breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR breadcrumb (SchoolR ssh sRoute) = case sRoute of @@ -2536,7 +2538,7 @@ pageActions PrintCenterR = do return NavPageActionPrimary { navLink = NavLink { navLabel = SomeMessage msg - , navRoute = PrintAcknowR d n h + , navRoute = PrintAckR d n h , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = True } , navQuick' = mempty diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 93efdcdf3..659cdd345 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -195,7 +195,7 @@ data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc.. makeLenses_ ''LmsTableCsv ltcExample :: LmsTableCsv -ltcExample = LmsTableCsv +ltcExample = LmsTableCsv { ltcDisplayName = "Max Mustermann" , ltcEmail = "m.mustermann@does.not.exist" , ltcValidUntil = compDay @@ -210,10 +210,10 @@ ltcExample = LmsTableCsv , ltcLmsNotified = Nothing , ltcLmsEnded = Nothing } - where + where compTime :: UTCTime compTime = $compileTime - compDay :: Day + compDay :: Day compDay = utctDay compTime ltcOptions :: Csv.Options @@ -231,7 +231,7 @@ instance Csv.ToNamedRecord LmsTableCsv where toNamedRecord = Csv.genericToNamedRecord ltcOptions instance Csv.DefaultOrdered LmsTableCsv where - headerOrder = Csv.genericHeaderOrder ltcOptions + headerOrder = Csv.genericHeaderOrder ltcOptions instance CsvColumnsExplained LmsTableCsv where csvColumnsExplanations = genericCsvColumnsExplanations ltcOptions $ Map.fromList @@ -253,7 +253,7 @@ type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser) `E.InnerJoin` E.SqlExpr (Entity User) ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity PrintJob)) - + queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser) queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) @@ -320,11 +320,11 @@ lmsTableQuery :: QualificationId -> LmsTableExpr -> E.SqlQuery ( E.SqlExpr (Enti ) lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` printJob) = do -- E.distinctOn [E.don $ printJob E.?. PrintJobLmsUser] $ do -- types, but destroys the ability to sort interactively, since distinctOn requires sorting - E.on $ lmsUser E.?. LmsUserId E.=?. printJob E.?. PrintJobLmsUser + E.on $ lmsUser E.?. LmsUserIdent E.=?. printJob E.?. PrintJobLmsUser E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause - E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser - E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification + E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser + E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification return (qualUser, user, lmsUser, printJob) @@ -333,22 +333,22 @@ mkLmsTable :: forall h p cols act act'. , Ord act, PathPiece act, RenderMessage UniWorX act , AsCornice h p LmsTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))) cols ) - => Entity Qualification + => Entity Qualification -> Map act (AForm Handler act') -> (LmsTableExpr -> E.SqlExpr (E.Value Bool)) -> cols -> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData)) -> DB (FormResult (act', Set UserId), Widget) mkLmsTable (Entity qid quali) acts restrict cols psValidator = do - now <- liftIO getCurrentTime + now <- liftIO getCurrentTime -- currentRoute <- fromMaybe (error "mkLmsAllTable called from 404-handler") <$> liftHandler getCurrentRoute -- we know the route here - let + let currentRoute = LmsR (qualificationSchool quali) (qualificationShorthand quali) nowaday = utctDay now mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) dbtIdent :: Text - dbtIdent = "qualification" + dbtIdent = "qualification" dbtSQLQuery q = lmsTableQuery qid q <* E.where_ (restrict q) dbtRowKey = queryUser >>> (E.^. UserId) dbtProj = dbtProjFilteredPostId @@ -359,7 +359,7 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do , single ("blocked-due" , SortColumn $ queryQualUser >>> (E.^. QualificationUserBlockedDue)) , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) , single ("last-refresh", SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) - , single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) + , single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) , single ("lms-ident" , SortColumn $ queryLmsUser >>> (E.?. LmsUserIdent)) , single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus)) , single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted)) @@ -383,11 +383,11 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do ) -- , single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.?. LmsUserNotified))) , single ("lms-notified", FilterColumn $ \row criterion -> - let luser = queryLmsUser row + let luser = queryLmsUser row pjob = queryPrintJob row - in + in case getLast criterion of - Just True -> E.isJust (luser E.?. LmsUserNotified) + Just True -> E.isJust (luser E.?. LmsUserNotified) E.&&. (E.isNothing (pjob E.?. PrintJobId) E.||. E.isJust (pjob E.?. PrintJobAcknowledged)) Just False -> E.isNothing (luser E.?. LmsUserNotified) E.||. (E.isJust (pjob E.?. PrintJobId) E.&&. E.isNothing (pjob E.?. PrintJobAcknowledged)) @@ -403,7 +403,7 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do , if isNothing mbRenewal then mempty else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) ] - dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtCsvEncode = Just DBTCsvEncode { dbtCsvExportForm = pure () , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) @@ -465,7 +465,7 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html getLmsR = postLmsR postLmsR sid qsh = do - currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler + currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler ((lmsRes, lmsTable), Entity qid quali) <- runDB $ do qent <- getBy404 $ SchoolQualificationShort sid qsh let acts :: Map LmsTableAction (AForm Handler LmsTableActionData) @@ -489,8 +489,8 @@ postLmsR sid qsh = do , 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-notified") (i18nLms MsgTableLmsNotified) $ \row -> - -- 4 Cases: + , sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified) $ \row -> + -- 4 Cases: -- - No notification: LmsUserNotified == Nothing -- - Email sent : LmsUserNotified == Just _ && PrintJobId == Nothing -- - Letter printed : LmsUserNotified == Just _ && PrintJobId == Just _ @@ -498,15 +498,15 @@ postLmsR sid qsh = do let notifyDate = join $ row ^? resultLmsUser . _entityVal . _lmsUserNotified letterDate = join $ row ^? resultPrintJob . _entityVal . _printJobAcknowledged -- letterSent = isJust (row ^? resultPrintJob . _entityKey) && (isNothing letterDate || letterDate > notifyDate) -- bad idea, since a resending increase notifyDay but just reschedules a print job - letterSent = isJust (row ^? resultPrintJob . _entityKey) -- note the difference to letterDate! + letterSent = isJust (row ^? resultPrintJob . _entityKey) -- note the difference to letterDate! notNotified = isNothing notifyDate cIcon = iconFixedCell $ iconLetterOrEmail letterSent cDate = if letterSent then foldMap dateTimeCell letterDate else foldMap dateTimeCell notifyDate - in if notNotified + in if notNotified then mempty - else cIcon <> spacerCell <> cDate + else cIcon <> spacerCell <> cDate , sortable (Just "lms-ended") (i18nLms MsgTableLmsEnded) $ \(preview $ resultLmsUser . _entityVal . _lmsUserEnded -> d) -> foldMap dateTimeCell $ join d ] where diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs index 4e15da823..d6c152c91 100644 --- a/src/Handler/LMS/Result.hs +++ b/src/Handler/LMS/Result.hs @@ -277,7 +277,7 @@ postLmsResultDirectR sid qsh = do $logWarnS "LMS" $ "Result upload failed parsing: " <> tshow e return (badRequest400, "Exception: " <> tshow e) Right nr -> do - let msg = "Success. LMS Result upload file " <> fileName file <> " containing " <> tshow nr <> " rows for header " <> fhead + let msg = "Success. LMS Result upload file " <> fileName file <> " containing " <> tshow nr <> " rows for file " <> fhead $logInfoS "LMS" msg when (nr > 0) $ queueDBJob $ JobLmsResults qid return (ok200, msg) diff --git a/src/Handler/LMS/Userlist.hs b/src/Handler/LMS/Userlist.hs index e2b26b30e..3a9c83de4 100644 --- a/src/Handler/LMS/Userlist.hs +++ b/src/Handler/LMS/Userlist.hs @@ -273,7 +273,7 @@ postLmsUserlistDirectR sid qsh = do $logWarnS "LMS" $ "Userlist upload failed parsing: " <> tshow e return (badRequest400, "Exception: " <> tshow e) Right nr -> do - let msg = "Success. LMS Userlist upload file " <> fileName file <> " containing " <> tshow nr <> " rows for header " <> fhead + let msg = "Success. LMS Userlist upload file " <> fileName file <> " containing " <> tshow nr <> " rows for file " <> fhead $logInfoS "LMS" msg when (nr > 0) $ queueDBJob $ JobLmsUserlist qid return (ok200, msg) diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 5aa07eb97..cfe7fd6c4 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -3,12 +3,15 @@ -- SPDX-License-Identifier: AGPL-3.0-or-later {-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Handler.PrintCenter - ( getPrintCenterR, postPrintCenterR - , getPrintAcknowR, postPrintAcknowR + ( getPrintDownloadR + , getPrintCenterR, postPrintCenterR , getPrintSendR , postPrintSendR - , getPrintDownloadR + , getPrintAckR , postPrintAckR + , postPrintAckDirectR + , postPrintAckFreeR ) where import Import @@ -35,6 +38,8 @@ import Utils.Print -- import qualified Data.Set as Set import Handler.Utils +import Handler.Utils.Csv +import qualified Data.Csv as Csv -- avoids repetition of local definitions single :: (k,a) -> Map k a @@ -203,7 +208,7 @@ mkPJTable = do , sortable (Just "pj-sender") (i18nCell MsgPrintSender) $ \(preview resultSender -> u) -> maybeCell u $ cellHasUserLink AdminUserR , sortable (Just "pj-course") (i18nCell MsgPrintCourse) $ \(preview $ resultCourse . _entityVal -> c) -> maybeCell c courseCell , sortable (Just "pj-qualification")(i18nCell MsgPrintQualification) $ \(preview $ resultQualification . _entityVal -> q) -> maybeCell q qualificationCell - , sortable (Just "pj-lmsid") (i18nCell MsgPrintLmsUser) $ \( view $ resultPrintJob . _entityVal . _printJobLmsUser -> q) -> ifIconCell (isJust q) IconMenuLms + , sortable (Just "pj-lmsid") (i18nCell MsgPrintLmsUser) $ \( view $ resultPrintJob . _entityVal . _printJobLmsUser -> l) -> foldMap textCell (getLmsIdent <$> l) ] dbtSorting = mconcat [ single ("pj-name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName)) @@ -214,7 +219,7 @@ mkPJTable = do , single ("pj-sender" , sortUserNameBareM querySender ) , single ("pj-course" , SortColumn $ queryCourse >>> (E.?. CourseName)) , single ("pj-qualification", SortColumn $ queryQualification >>> (E.?. QualificationName)) - , single ("pj-lmsid" , SortColumn $ queryPrintJob >>> (E.isJust . (E.^. PrintJobLmsUser))) + , single ("pj-lmsid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobLmsUser)) ] dbtFilter = mconcat [ single ("pj-name" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobName)) @@ -357,12 +362,12 @@ getPrintDownloadR cupj = do -} -getPrintAcknowR, postPrintAcknowR :: Day -> Int -> Int -> Handler Html -getPrintAcknowR = postPrintAcknowR -postPrintAcknowR ackDay numAck chksm = do +getPrintAckR, postPrintAckR :: Day -> Int -> Int -> Handler Html +getPrintAckR = postPrintAckR +postPrintAckR ackDay numAck chksm = do ((ackRes, ackWgt), ackEnctype) <- runFormPost (identifyForm FIDPrintAcknowledge buttonForm :: Form ButtonConfirm) let ackForm = wrapForm ackWgt def - { formAction = Just $ SomeRoute $ PrintAcknowR ackDay numAck chksm + { formAction = Just $ SomeRoute $ PrintAckR ackDay numAck chksm , formEncoding = ackEnctype , formSubmit = FormNoSubmit } @@ -399,3 +404,50 @@ postPrintAcknowR ackDay numAck chksm = do (MsgPrintJobAcknowledgeQuestion numAck ackDayText) ackForm +-- no header csv, containing a single column of lms identifiers (logins) +instance Csv.FromRecord LmsIdent -- default suffices + +postPrintAckDirectR :: Handler Html +postPrintAckDirectR = do + (_params, files) <- runRequestBody + (status, msg) <- case files of + [(fhead,file)] -> do + runDB $ do + enr <- try $ runConduit $ fileSource file + .| decodeCsvPositional Csv.NoHeader + .| sinkList + case enr of + Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error + $logWarnS "APC" $ "Result upload failed parsing: " <> tshow e + return (badRequest400, "Exception: " <> tshow e) + Right lids -> do + now <- liftIO getCurrentTime + nr <- updateWhereCount + [PrintJobAcknowledged ==. Nothing, PrintJobLmsUser <-. (Just <$> lids)] + [PrintJobAcknowledged =. Just now] + let lenLids = length lids + if | lenLids <= 0 -> do + let msg = "Error: No print job was acknowledged as printed, but " <> tshow lenLids <> " were requested to be, for file " <> fhead + $logErrorS "APC" msg + return (badRequest400, msg) + | lenLids == fromIntegral nr -> do + let msg = "Success: " <> tshow nr <> " print jobs were acknowledged as printed, for file " <> fhead + $logInfoS "APC" msg + return (ok200, msg) + | otherwise -> do + let msg = "Warning: Only " <> tshow nr <> " print jobs out of " <> tshow lenLids <> " were acknowledged as printed, for file " <> fhead + $logWarnS "APC" msg + return (ok200, msg) + [] -> do + let msg = "Warning: No file received. A file of lms identifiers must be supplied for print job acknowledging." + $logWarnS "APC" msg + return (badRequest400, msg) + _other -> do + let msg = "Error: Only a single file may be uploaded for print job acknowlegement; all ignored." + $logErrorS "APC" msg + return (badRequest400, msg) + sendResponseStatus status msg -- must be outside of runDB; otherweise transaction is rolled back + +-- synonym, used during development to test with and without access control simultaneously +postPrintAckFreeR :: Handler Html +postPrintAckFreeR = postPrintAckDirectR \ No newline at end of file diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index abad9d9e7..9b16abc79 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -126,7 +126,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do notifyOk <- pdfRenewal pdfMeta >>= \case Right pdf | userPrefersLetter recipient -> -- userPrefersLetter is false if both userEmail and userPostAddress are null let printSender = Nothing - in runDB (sendLetter printJobName pdf (Just jRecipient, printSender) Nothing (Just nQualification) (Just luid)) >>= \case + in runDB (sendLetter printJobName pdf (Just jRecipient, printSender) Nothing (Just nQualification) (Just lmsUserIdent)) >>= \case Left err -> do let msg = "Notify " <> tshow encRecipient <> ": PDF printing to send letter failed with error " <> cropText err $logErrorS "LMS" msg diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index b39c242df..a896d8e9e 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -268,7 +268,7 @@ pdfRenewal' meta = do -- PrintJobs -- --------------- -sendLetter :: Text -> LBS.ByteString -> (Maybe UserId, Maybe UserId) -> Maybe CourseId -> Maybe QualificationId -> Maybe LmsUserId -> DB (Either Text (Text, FilePath)) +sendLetter :: Text -> LBS.ByteString -> (Maybe UserId, Maybe UserId) -> Maybe CourseId -> Maybe QualificationId -> Maybe LmsIdent -> DB (Either Text (Text, FilePath)) sendLetter printJobName pdf (printJobRecipient, printJobSender) printJobCourse printJobQualification printJobLmsUser = do recipient <- join <$> mapM get printJobRecipient sender <- join <$> mapM get printJobSender @@ -278,17 +278,17 @@ sendLetter printJobName pdf (printJobRecipient, printJobSender) printJobCourse p nameSender = abbrvName <$> sender nameCourse = CI.original . courseShorthand <$> course nameQuali = CI.original . qualificationShorthand <$> quali - let printJobAcknowledged = Nothing - jobFullName = T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient]) + let jobFullName = T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient]) printJobFilename = T.unpack $ jobFullName <> ".pdf" -- printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf -- for PrintJobFile :: FileContentReference use this code printJobFile = LBS.toStrict pdf + printJobAcknowledged = Nothing lprPDF jobFullName pdf >>= \case Left err -> do return $ Left err Right ok -> do printJobCreated <- liftIO getCurrentTime - updateWhere [PrintJobLmsUser ==. printJobLmsUser] [PrintJobLmsUser =. Nothing] -- only one printJob per LmsUser is allowed, since otherwise the qualification table contains double rows + -- updateWhere [PrintJobLmsUser ==. printJobLmsUser] [PrintJobLmsUser =. Nothing] -- only one printJob per LmsUser is allowed, since otherwise the qualification table contains double rows insert_ PrintJob {..} return $ Right (ok, printJobFilename) diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 00160a399..82c63b4e5 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -528,22 +528,22 @@ fillDb = do void . insert' $ LmsUserlist qid_f (LmsIdent "hijklmn") False now void . insert' $ LmsUserlist qid_f (LmsIdent "abcdefg") True now void . insert' $ LmsUserlist qid_f (LmsIdent "ijk" ) False now - lujost <- insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing now Nothing (Just $ n_day' (-7)) (Just $ n_day' (-5)) - luvaupel <- insert' $ LmsUser qid_f svaupel (LmsIdent "abcdefg") "abc" False now (Just $ LmsSuccess $ n_day 1) now (Just now) (Just $ n_day' 0) Nothing - void . insert' $ LmsUser qid_f gkleen (LmsIdent "hijklmn") "@#!" True now (Just $ LmsBlocked $ utctDay now) now (Just now) (Just $ n_day' (-1)) Nothing - lutina <- insert' $ LmsUser qid_f tinaTester (LmsIdent "qwvu") "45678" True now (Just $ LmsSuccess $ n_day (-2)) now (Just $ n_day' (-1)) (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)) Nothing Nothing - void . insert' $ LmsUser qid_f fhamann (LmsIdent "123") "456" False now Nothing now Nothing Nothing Nothing + void . insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing now Nothing (Just $ n_day' (-7)) (Just $ n_day' (-5)) + void . insert' $ LmsUser qid_f svaupel (LmsIdent "abcdefg") "abc" False now (Just $ LmsSuccess $ n_day 1) now (Just now) (Just $ n_day' 0) Nothing + void . insert' $ LmsUser qid_f gkleen (LmsIdent "hijklmn") "@#!" True now (Just $ LmsBlocked $ utctDay now) now (Just now) (Just $ n_day' (-1)) Nothing + void . insert' $ LmsUser qid_f tinaTester (LmsIdent "qwvu") "45678" True now (Just $ LmsSuccess $ n_day (-2)) now (Just $ n_day' (-1)) (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)) Nothing Nothing + void . insert' $ LmsUser qid_f fhamann (LmsIdent "123") "456" False now Nothing now Nothing Nothing Nothing void . insert $ PrintJob "TestJob1" "job1" "No Text herein." (n_day' (-1)) Nothing Nothing (Just svaupel) Nothing (Just qid_f) Nothing - void . insert $ PrintJob "TestJob2" "job2" "No Text herein." (n_day' (-3)) (Just $ n_day' (-1)) (Just jost) (Just svaupel) Nothing (Just qid_f) (Just lujost) + void . insert $ PrintJob "TestJob2" "job2" "No Text herein." (n_day' (-3)) (Just $ n_day' (-1)) (Just jost) (Just svaupel) Nothing (Just qid_f) (Just $ LmsIdent "ijk") void . insert $ PrintJob "TestJob3" "job3" "No Text herein." (n_day' (-2)) Nothing Nothing Nothing Nothing Nothing Nothing - void . insert $ PrintJob "TestJob4" "job4" "No Text herein." (n_day' (-2)) Nothing (Just jost) Nothing Nothing Nothing Nothing - void . insert $ PrintJob "TestJob5" "job5" "No Text herein." (n_day' (-4)) Nothing (Just jost) (Just svaupel) Nothing (Just qid_r) (Just lutina) + void . insert $ PrintJob "TestJob4" "job4" "No Text herein." (n_day' (-2)) Nothing (Just jost) Nothing Nothing Nothing (Just $ LmsIdent "qwvu") + void . insert $ PrintJob "TestJob5" "job5" "No Text herein." (n_day' (-4)) Nothing (Just jost) (Just svaupel) Nothing (Just qid_r) (Just $ LmsIdent "qwvu") void . insert $ PrintJob "TestJob6" "job6" "No Text herein." (n_day' (-4)) Nothing (Just svaupel) Nothing Nothing (Just qid_r) Nothing - void . insert $ PrintJob "TestJob7" "job7" "No Text herein." (n_day' (-4)) (Just $ n_day' (-8)) (Just svaupel) Nothing Nothing Nothing (Just luvaupel) - void . insert $ PrintJob "TestJob8" "job8" "No Text herein." (n_day' (-2)) (Just $ n_day' (-6)) (Just svaupel) Nothing Nothing Nothing (Just luvaupel) - void . insert $ PrintJob "TestJob8" "job8" "No Text herein." (n_day' (-1)) Nothing (Just svaupel) Nothing Nothing Nothing (Just luvaupel) + void . insert $ PrintJob "TestJob7" "job7" "No Text herein." (n_day' (-4)) (Just $ n_day' (-8)) (Just svaupel) Nothing Nothing Nothing (Just $ LmsIdent "abcdefg") + void . insert $ PrintJob "TestJob8" "job8" "No Text herein." (n_day' (-2)) (Just $ n_day' (-6)) (Just svaupel) Nothing Nothing Nothing (Just $ LmsIdent "abcdefg") + void . insert $ PrintJob "TestJob8" "job8" "No Text herein." (n_day' (-1)) Nothing (Just svaupel) Nothing Nothing Nothing (Just $ LmsIdent "abcdefg") let