chore(aps): direct route for automatic print job acknowledging

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
+  lmsUser       LmsIdent        Maybe OnDeleteCascade OnUpdateCascade   -- allows tracking if recipient has been notified; must be unique
-  -- UniquePrintJobLmsUser lmsUser
+  -- UniquePrintJobLmsUser lmsUser -- Note that in fact multiple print jobs per LMS user are possible!
   deriving Generic

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
 

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

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.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser    
-    E.where_ $    E.val qid E.==. qualUser E.^. QualificationUserQualification      
+    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 -> 
+          , sortable (Just "lms-notified")  (i18nLms MsgTableLmsNotified) $ \row ->
-              -- 4 Cases: 
+              -- 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

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)

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)

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
+  ( getPrintDownloadR
-  , getPrintAcknowR, postPrintAcknowR
+  , 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
+getPrintAckR,  postPrintAckR :: Day -> Int -> Int -> Handler Html
-getPrintAcknowR = postPrintAcknowR
+getPrintAckR = postPrintAckR
-postPrintAcknowR ackDay numAck chksm = do
+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 

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

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
+  let jobFullName          = T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient]) 
-      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)
 

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))
+  void . 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 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 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 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 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 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 "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 lutina)
+  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 "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 luvaupel)
+  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 luvaupel)
+  void . insert $ PrintJob "TestJob8" "job8" "No Text herein." (n_day' (-1)) Nothing              (Just svaupel) Nothing         Nothing Nothing      (Just $ LmsIdent "abcdefg")
 
 
   let