chore(letter): complete envelope max counting, hard coded limit yet

src/Utils.hs

@@ -965,10 +965,10 @@ forMaybeM :: ( Monad m
              ) => f a -> (Element (f a) -> MaybeT m (Element (f b))) -> m (f b)
 forMaybeM = flip mapMaybeM
 
-{-
+
---   Takes computations returnings @Maybes@; tries each one in order.
+-- | Takes computations returnings @Maybe@; tries each one in order.
---   The first one to return a @Just@ wins. Returns @Nothing@ if all computations
+--   The first one to return a @Just@ wins. 
---   return @Nothing@.
+--   Returns @Nothing@ if all computations return @Nothing@.
 --   Copied from GHC.Data.Maybe, which could not be imported somehow.
 firstJustsM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a)
 firstJustsM = foldlM go Nothing 
@@ -976,7 +976,6 @@ firstJustsM = foldlM go Nothing
     go :: Monad m => Maybe a -> m (Maybe a) -> m (Maybe a)
     go Nothing          action = action
     go result@(Just _) _action = return result
--}
 
 -- | Run the maybe computation repeatedly until the first Just is returned
 --   or the number of maximum retries is exhausted.

src/Utils/Print/Letters.hs

@@ -3,6 +3,7 @@
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
 {-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Utils.Print.Letters where
 
@@ -23,6 +24,10 @@ import qualified Text.Pandoc.Builder as P
 
 import Text.Hamlet
 
+-- import           Database.Esqueleto.Experimental ((:&)(..))
+import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
+import qualified Database.Esqueleto.Utils as E
+
 -- import System.Exit
 -- import System.Process.Typed -- for calling pdftk for pdf encryption
 
@@ -177,16 +182,29 @@ data PrintJobIdentification = PrintJobIdentification
 --   this is printed in white on white at the exact same position on the page
 --   Note: that all letters to the same UUID within 24h are collated in one envelope
 --   Example: 9ad8de3f-0a7e-ede5-bd8b-6d0ed85c1049-f___a4pin___230322-10___lms-stuvwxyz
-mkApcIdent :: CryptoUUIDUser -> Char -> LetterKind -> Text -> Text -> Text
+mkApcIdent :: CryptoUUIDUser -> (Int, Char) -> LetterKind -> Text -> Text -> Text
 mkApcIdent uuid envelope lk tnow apcAck = Text.filter apcAcceptedChars $ Text.intercalate apcIdentSeparator 
-      [ ensureLength 38 $ tshow (ciphertext uuid) <> Text.cons '-' (Text.singleton envelope)
+      [ ensureLength 38 $ tshow (ciphertext uuid) <> mkEnvelope envelope
       , ensureLength  5 $ paperKind lk
       , ensureLength  9   tnow
       , Text.take    32   apcAck -- length of last part may be arbitrary, but more than 32 symbols do not fit into the line
       ]
-  where 
+  where
     ensureLength :: Int -> Text -> Text
-    ensureLength n = Text.take n . Text.justifyLeft n 'x'
+    ensureLength n = Text.take n . Text.justifyLeft n 'x' . Text.filter apcAcceptedChars
+
+mkEnvelope :: (Int, Char) -> Text 
+mkEnvelope (i,c) = Text.cons (pfx $ i `mod` 63) $ Text.singleton sfx
+  where 
+    pfx n
+      | n <=  0   = '-'
+      | n <= 10   = chr $ ord '0' + n `mod` 10
+      | n <= 36   = chr $ ord 'a' + n - 11
+      | n <= 62   = chr $ ord 'A' + n - 37
+      | otherwise = '-'
+    sfx 
+      | i <= 62   = Char.toLower c
+      | otherwise = Char.toUpper c
 
 formatApcIdentTime :: (HasLocalTime t, MonadHandler m) => t -> m Text
 formatApcIdentTime = formatTime' "%y%m%d-%H"
@@ -208,7 +226,8 @@ apcAcceptedChars '-' = True
 apcAcceptedChars '_' = True
 apcAcceptedChars  c  = isAlphaNum c
 
-
+apcEnvelopeSize :: Int64
+apcEnvelopeSize = 6
 
 ------------------
 -- Letter Class --
@@ -241,11 +260,23 @@ class MDLetter l where
   getMailBody       :: l -> Maybe (DateTimeFormatter -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) -- Just returns cover-lettter for attaching PDF to, Nothing indicates that the letter should be sent as direct Html Email
   getMailBody = const Nothing
 
-letterApcIdent :: (MDLetter l, MonadHandler m) => l -> CryptoUUIDUser -> UTCTime -> m Text
+letterApcIdent :: (MDLetter l) => l -> CryptoUUIDUser -> UTCTime -> Handler Text
 letterApcIdent l uuid now = do
-  -- now  <- liftIO getCurrentTime
+    -- now  <- liftIO getCurrentTime
-  tnow <- formatApcIdentTime now
+    tnow <- formatApcIdentTime now
-  return $ mkApcIdent uuid (getLetterEnvelope l) (getLetterKind l) tnow (pjiApcAcknowledge $ getPJId l)
+    let mkApcIdnt i = mkApcIdent uuid (i,getLetterEnvelope l) (getLetterKind l) tnow (pjiApcAcknowledge $ getPJId l)
+        attemptId i = do
+          let apcId  = mkApcIdnt i
+              recenv = fst $ Text.breakOn apcIdentSeparator apcId
+          envCount <- runDB . E.select $ do
+            pj <- E.from $ E.table @PrintJob
+            E.where_ $ E.isNothing (pj E.^. PrintJobAcknowledged)
+                E.&&. (E.val recenv `E.isPrefixOf_` pj E.^. PrintJobApcIdent)
+            return E.countRows
+          case envCount of 
+            (E.Value nrLetters):_ -> return $ toMaybe (nrLetters < apcEnvelopeSize) apcId
+            []                    -> return $ Just apcId
+    fromMaybe (mkApcIdnt 0) <$> firstJustsM [attemptId i | i <- [0..128]]
 
 letterFileName :: (MDLetter l) => l -> FilePath
 letterFileName = Text.unpack . (<> ".pdf") . text2asciiAlphaNum . pjiFileName . getPJId