chore(apc): adjust print acknowledging to deal with apcident in a backward compatible way

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
+            nrApcIds <- updateWhereCount
-              [PrintJobAcknowledged ==. Nothing, PrintJobLmsUser <-. (Just <$> lids)] 
+              [PrintJobAcknowledged ==. Nothing, PrintJobApcIdent <-. reqIds] 
               [PrintJobAcknowledged =.  Just now]
-            let lenLids = length lids
+            nrOk <- if nrApcIds > 0 && nrReq > 0
-            if  | lenLids <= 0 -> do 
+              then updateWhereCount -- for downwards compatibility only
-                  let msg = "Error: No print job was acknowledged as printed, but " <> tshow lenLids <> " were requested to be, for file " <> fhead
+                [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
+                | nrReq == fromIntegral nrOk -> do
-                  let msg = "Success: " <> tshow nr <> " print jobs were acknowledged as printed, for file " <> fhead
+                  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

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 :: MonadIO m => m Text -- may contain all kinds of symbols, but our users had trouble with some, like ',' '.' ':' '_'
-randomLMSpw = randomText extra lengthPassword
+randomLMSpw = randomText extra lengthPassword 
   where
     extra = "+=!?" -- you cannot distinguish ;: and ., in printed letters
 

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