From 81a30fadc4513561a6cf409fc3f79edbaa306d26 Mon Sep 17 00:00:00 2001
From: Steffen Jost <S.Jost@Fraport.de>
Date: Wed, 22 Mar 2023 12:14:10 +0000
Subject: [PATCH] chore(apc): adjust print acknowledging to deal with apcident
 in a backward compatible way

---
 src/Handler/PrintCenter.hs | 29 +++++++++++++++++++----------
 src/Handler/Utils/LMS.hs   |  6 +++---
 src/Utils.hs               |  6 ++++++
 3 files changed, 28 insertions(+), 13 deletions(-)

diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs
index 10aa628ce..91d53206c 100644
--- a/src/Handler/PrintCenter.hs
+++ b/src/Handler/PrintCenter.hs
@@ -373,7 +373,11 @@ postPrintAckR ackDay numAck chksm = do
     ackForm
 
 -- no header csv, containing a single column of lms identifiers (logins)
-instance Csv.FromRecord LmsIdent -- default suffices
+-- instance Csv.FromRecord LmsIdent -- default suffices
+instance Csv.FromRecord Text where 
+  parseRecord v 
+    | length v == 1 = v Csv..! 1
+    | otherwise     = mzero
 
 postPrintAckDirectR :: Handler Html
 postPrintAckDirectR = do 
@@ -388,22 +392,27 @@ postPrintAckDirectR = do
           Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error
             $logWarnS "APC" $ "Result upload failed parsing: " <> tshow e
             return (badRequest400, "Error: " <> tshow e)
-          Right lids -> do
+          Right reqIds -> do
+            let nrReq = length reqIds
             now <- liftIO getCurrentTime
-            nr <- updateWhereCount
-              [PrintJobAcknowledged ==. Nothing, PrintJobLmsUser <-. (Just <$> lids)] 
+            nrApcIds <- updateWhereCount
+              [PrintJobAcknowledged ==. Nothing, PrintJobApcIdent <-. reqIds] 
               [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
+            nrOk <- if nrApcIds > 0 && nrReq > 0
+              then updateWhereCount -- for downwards compatibility only
+                [PrintJobAcknowledged ==. Nothing, PrintJobLmsUser <-. (Just . LmsIdent . dropPrefixText "lms-" <$> reqIds)] 
+                [PrintJobAcknowledged =.  Just now]
+              else return nrApcIds            
+            if  | nrReq <= 0 -> do 
+                  let msg = "Error: No print job was acknowledged as printed, but " <> tshow nrReq <> " 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
+                | nrReq == fromIntegral nrOk -> do
+                  let msg = "Success: " <> tshow nrOk <> " 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
+                  let msg = "Warning: Only " <> tshow nrOk <> " print jobs out of " <> tshow nrReq <> " were acknowledged as printed, for file " <> fhead
                   $logWarnS "APC" msg
                   return (ok200, msg)
     []     -> do
diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs
index 55cbc18ca..7a9483779 100644
--- a/src/Handler/Utils/LMS.hs
+++ b/src/Handler/Utils/LMS.hs
@@ -150,7 +150,7 @@ randomText extra n = fmap pack . evalRandTIO . replicateM n $ uniform range
 --     eopt = Elo.genOptions -- { genCapitals = False, genSpecials = False, genDigitis = True }
 
 randomLMSIdent :: MonadIO m => m LmsIdent
-randomLMSIdent = LmsIdent <$> randomText [] lengthIdent
+randomLMSIdent = LmsIdent <$> randomText [] lengthIdent -- idents must not contain '_' nor '-'
 
 randomLMSIdentBut :: MonadIO m => Set LmsIdent -> m (Maybe LmsIdent)
 randomLMSIdentBut banList = untilJustMaxM maxLmsUserIdentRetries getIdentOk
@@ -159,8 +159,8 @@ randomLMSIdentBut banList = untilJustMaxM maxLmsUserIdentRetries getIdentOk
       l <- randomLMSIdent
       return $ toMaybe (Set.notMember l banList) l
 
-randomLMSpw :: MonadIO m => m Text
-randomLMSpw = randomText extra lengthPassword
+randomLMSpw :: MonadIO m => m Text -- may contain all kinds of symbols, but our users had trouble with some, like ',' '.' ':' '_'
+randomLMSpw = randomText extra lengthPassword 
   where
     extra = "+=!?" -- you cannot distinguish ;: and ., in printed letters
 
diff --git a/src/Utils.hs b/src/Utils.hs
index 107bdd282..e6c518358 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -287,6 +287,12 @@ textElem c = Text.any (c ==)
 stripAll :: Text -> Text
 stripAll = Text.filter (not . isSpace)
 
+-- | Strips an optional prefix. Like `Data.Text.stripPrefix` but returns input text if the prefix is not matched, micking the behaviour of `dropPrefix` for `Data.Text`
+dropPrefixText :: Text -> Text -> Text
+-- dropPrefixText p t = fromMaybe t $ stripPrefix p t 
+dropPrefixText p (stripPrefix p -> Just t) = t 
+dropPrefixText _ other = other 
+
 -- | take first line, only 
 cropText :: Text -> Text
 cropText (Text.take 255 -> t) = headDef t $ Text.lines t