Merge branch 'master' into fradrive/api-avs

CHANGELOG.md

@@ -2,6 +2,8 @@
 
 All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
 
+## [26.6.4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.6.3...v26.6.4) (2022-12-02)
+
 ## [26.6.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.6.2...v26.6.3) (2022-11-30)
 
 

nix/docker/demo-version.json

@@ -1,3 +1,3 @@
 {
-  "version": "26.6.3"
+  "version": "26.6.4"
 }

nix/docker/version.json

@@ -1,3 +1,3 @@
 {
-  "version": "26.6.3"
+  "version": "26.6.4"
 }

package-lock.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "26.6.3",
+  "version": "26.6.4",
   "lockfileVersion": 1,
   "requires": true,
   "dependencies": {

package.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "26.6.3",
+  "version": "26.6.4",
   "description": "",
   "keywords": [],
   "author": "",

package.yaml

@@ -1,5 +1,5 @@
 name: uniworx
-version: 26.6.3
+version: 26.6.4
 dependencies:
   - base
   - yesod

src/Auth/LDAP.hs

@@ -146,7 +146,7 @@ campusUserReTest' :: (MonadMask m, MonadLogger m, MonadUnliftIO m) => Failover (
 campusUserReTest' pool doTest mode User{userIdent}
   = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUserReTest pool doTest mode (Creds apLdap (CI.original userIdent) [])
 
-campusUser :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> Creds site -> m (Ldap.AttrList [])
+campusUser :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> Creds site -> m (Ldap.AttrList [])
 campusUser pool mode creds = throwLeft =<< campusUserWith withLdapFailover pool mode creds
 
 campusUser' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList []))

src/Foundation/Yesod/Auth.hs

@@ -4,7 +4,8 @@
 
 module Foundation.Yesod.Auth
   ( authenticate
-  , upsertCampusUser, upsertCampusUserByCn 
+  , ldapLookupAndUpsert
+  , upsertCampusUser
   , decodeUserTest
   , CampusUserConversionException(..)
   , campusUserFailoverMode, updateUserLanguage
@@ -106,10 +107,10 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
           | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]
         _other -> return res
 
-  $logDebugS "auth" $ tshow Creds{..}
+  $logDebugS "auth" $ tshow Creds{..}  
-  UniWorX{..} <- getYesod
+  ldapPool' <- getsYesod $ view _appLdapPool
 
-  flip catches excHandlers $ case appLdapPool of
+  flip catches excHandlers $ case ldapPool' of
     Just ldapPool
       | Just upsertMode' <- upsertMode -> do
           ldapData <- campusUser ldapPool campusUserFailoverMode Creds{..}
@@ -152,14 +153,25 @@ _upsertCampusUserMode mMode cs@Creds{..}
 
     defaultOther = apHash
 
+ldapLookupAndUpsert :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadMask m, MonadUnliftIO m) => Text -> SqlPersistT m (Entity User)                    
+ldapLookupAndUpsert ident = 
+  getsYesod (view _appLdapPool) >>= \case 
+    Nothing -> throwM $ CampusUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation."
+    Just ldapPool ->
+      campusUser'' ldapPool campusUserFailoverMode ident >>= \case
+        Nothing -> throwM CampusUserNoResult
+        Just ldapResponse -> upsertCampusUser UpsertCampusUserGuessUser ldapResponse
+
+{- THIS FUNCION JUST DECODES, BUT IT DOES NOT QUERY LDAP!
 upsertCampusUserByCn :: forall m.
                         ( MonadHandler m, HandlerSite m ~ UniWorX
                         , MonadThrow m
                         )
                       => Text -> SqlPersistT m (Entity User)
 upsertCampusUserByCn persNo = upsertCampusUser UpsertCampusUserGuessUser [(ldapPrimaryKey,[Text.encodeUtf8 persNo])]
+-}
 
-
+-- | Upsert User DB according to given LDAP data (does not query LDAP itself)
 upsertCampusUser :: forall m.
                     ( MonadHandler m, HandlerSite m ~ UniWorX
                     , MonadThrow m
@@ -208,7 +220,7 @@ decodeUserTest mbIdent ldapData = do
 
 
 decodeUser :: (MonadThrow m) =>  UTCTime -> UserDefaultConf -> UpsertCampusUserMode -> Ldap.AttrList [] -> m (User,_)
-decodeUser now UserDefaultConf{..} upsertMode ldapData = do
+decodeUser now UserDefaultConf{..} upsertMode ldapData = do    
     let
       userTelephone             = decodeLdap ldapUserTelephone
       userMobile                = decodeLdap ldapUserMobile

src/Handler/Admin/Avs.hs

@@ -19,7 +19,7 @@ import Handler.Utils.Avs
 import Utils.Avs
 
 -- Button needed only here
-data ButtonAvsTest = BtnCheckLicences
+data ButtonAvsTest = BtnCheckLicences | BtnSynchLicences
   deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
 instance Universe ButtonAvsTest
 instance Finite ButtonAvsTest
@@ -27,8 +27,10 @@ instance Finite ButtonAvsTest
 nullaryPathPiece ''ButtonAvsTest camelToPathPiece
 
 instance Button UniWorX ButtonAvsTest where
-  btnLabel    BtnCheckLicences = "Check all licences" -- could be msg
+  btnLabel    BtnCheckLicences = "Check all licences"       -- could be msg
-  btnClasses  BtnCheckLicences = [BCIsButton, BCPrimary]
+  btnLabel    BtnSynchLicences = "Synchronize all licences" -- could be msg
+  btnClasses  BtnCheckLicences = [BCIsButton, BCPrimary]  
+  btnClasses  BtnSynchLicences = [BCIsButton, BCDanger]
 -- END Button
 
 
@@ -36,7 +38,7 @@ avsCardNoField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field
 avsCardNoField = convertField AvsCardNo avsCardNo textField
 
 avsInternalPersonalNoField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m AvsInternalPersonalNo
-avsInternalPersonalNoField = convertField (canonical . AvsInternalPersonalNo) avsInternalPersonalNo textField
+avsInternalPersonalNoField = convertField mkAvsInternalPersonalNo avsInternalPersonalNo textField
 
 makeAvsPersonForm :: Maybe AvsQueryPerson -> Form AvsQueryPerson
 makeAvsPersonForm tmpl = identifyForm FIDAvsQueryPerson . validateForm validateAvsQueryPerson $ \html ->
@@ -180,16 +182,42 @@ postAdminAvsR = do
 
 
       ((qryLicRes, qryLicWgt), qryLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicenceDiffs (buttonForm :: Form ButtonAvsTest)
-      let procFormQryLic BtnCheckLicences = do
+      let procFormQryLic btn = case btn of 
-            res <- try checkLicences
+            BtnCheckLicences -> do 
-            case res of
+              res <- try $ do                 
-              (Right True) ->
+                allLicences <- throwLeftM avsQueryGetAllLicences
-                return $ Just [whamlet|<h2>Success:</h2> Licences sychronized.|]
+                computeDifferingLicences allLicences
-              (Right False) ->
+              case res of 
-                return $ Just [whamlet|<h2>Error:</h2> Licences could not be synchronized, see error log.|]
+                (Right diffs) -> do 
-              (Left e) -> do
+                  let showLics l = Text.intercalate ", " $ fmap (tshow . avsLicencePersonID) $ Set.toList $ Set.filter ((l ==) . avsLicenceRampLicence) diffs
-                let msg = tshow (e :: SomeException)
+                      r_grant = showLics AvsLicenceRollfeld
-                return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
+                      f_set   = showLics AvsLicenceVorfeld
+                      revoke  = showLics AvsNoLicence
+                  return $ Just [whamlet|
+                      <h2>Licence check differences:
+                      <h3>Grant R:
+                      <p>
+                        #{r_grant}
+                      <h3>Set to F:
+                      <p>
+                        #{f_set}
+                      <h3>Revoke licence:                      
+                      <p>
+                        #{revoke}
+                    |]
+                (Left e) -> do
+                  let msg = tshow (e :: SomeException)
+                  return $ Just [whamlet|<h2>Licence check error:</h2> #{msg}|]
+            BtnSynchLicences -> do
+              res <- try checkLicences
+              case res of
+                (Right True) ->
+                  return $ Just [whamlet|<h2>Success:</h2> Licences sychronized.|]
+                (Right False) ->
+                  return $ Just [whamlet|<h2>Error:</h2> Licences could not be synchronized, see error log.|]
+                (Left e) -> do
+                  let msg = tshow (e :: SomeException)
+                  return $ Just [whamlet|<h2>Licence synchronisation error:</h2> #{msg}|]
       mbQryLic <- formResultMaybe qryLicRes procFormQryLic
 
       actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute

src/Handler/Admin/Ldap.hs

@@ -10,67 +10,46 @@ module Handler.Admin.Ldap
   ) where
 
 import Import
-import qualified Control.Monad.State.Class as State
+-- import qualified Control.Monad.State.Class as State
 -- import Data.Aeson (encode)
 import qualified Data.CaseInsensitive as CI
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 -- import qualified Data.Set  as Set
-import Foundation.Yesod.Auth (decodeUserTest)
+import Foundation.Yesod.Auth (decodeUserTest,ldapLookupAndUpsert,campusUserFailoverMode,CampusUserConversionException())
-
 import Handler.Utils
 
 import qualified Ldap.Client as Ldap
 import Auth.LDAP
 
-data LdapQueryPerson = LdapQueryPerson
-      { ldapQueryIdent :: Maybe Text
-      -- , ldapQueryName  :: Maybe Text
-      , ldapQueryPNum  :: Maybe Text
-      }
-  deriving (Eq, Ord, Read, Show, Generic, Typeable)
-
-makeLdapPersonForm :: Maybe LdapQueryPerson -> Form LdapQueryPerson
-makeLdapPersonForm tmpl = validateForm validateLdapQueryPerson $ \html ->
-  flip (renderAForm FormStandard) html $ LdapQueryPerson
-    <$> aopt textField (fslI MsgAdminUserIdent)           (ldapQueryIdent  <$> tmpl)
-    -- <*> aopt textField (fslI MsgAdminUserSurname)         (ldapQueryName   <$> tmpl)
-    <*> aopt textField (fslI MsgAdminUserFPersonalNumber) (ldapQueryPNum   <$> tmpl)
-
-validateLdapQueryPerson :: FormValidator LdapQueryPerson Handler ()
-validateLdapQueryPerson = do
-  LdapQueryPerson{..} <- State.get
-  guardValidation MsgAvsQueryEmpty $
-    is _Just ldapQueryIdent         ||
-    -- is _Just ldapQueryName          ||
-    is _Just ldapQueryPNum
-
-
 
 getAdminLdapR,  postAdminLdapR :: Handler Html
 getAdminLdapR = postAdminLdapR
 postAdminLdapR = do
-  ((presult, pwidget), penctype) <- runFormPost $ makeLdapPersonForm Nothing
+  ((presult, pwidget), penctype) <- runFormPost $ identifyForm ("adminLdapLookup"::Text) $ \html -> 
-
+    flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
-  let procFormPerson :: LdapQueryPerson -> Handler (Maybe (Ldap.AttrList []))
-      procFormPerson LdapQueryPerson{..} = do
-        ldapPool'       <- getsYesod $ view _appLdapPool
-
-        if isNothing ldapPool'
-          then addMessage Warning $ text2Html "LDAP Configuration missing."
-          else addMessage Info    $ text2Html "Input for LDAP test received."
-        fmap join . for ldapPool' $ \ldapPool -> do
-          ldapData <- if | Just lqi <- ldapQueryIdent -> campusUser''    ldapPool FailoverUnlimited lqi
-                         | Just lqn <- ldapQueryPNum  -> campusUserMatr' ldapPool FailoverUnlimited lqn
-                         | otherwise -> addMessageI Error MsgAvsQueryEmpty >> pure Nothing
-          decodedErr <- decodeUserTest (CI.mk <$> ldapQueryIdent) $ concat ldapData
-          whenIsLeft decodedErr $ addMessageI Error
-          return ldapData
-
 
+  let procFormPerson :: Text -> Handler (Maybe (Ldap.AttrList []))
+      procFormPerson lid = do
+        ldapPool' <- getsYesod $ view _appLdapPool
+        case ldapPool' of 
+          Nothing -> addMessage Error (text2Html "LDAP Configuration missing.") >> return Nothing
+          Just ldapPool -> do 
+            addMessage Info  $ text2Html "Input for LDAP test received."
+            ldapData <- campusUser'' ldapPool campusUserFailoverMode lid                      
+            decodedErr <- decodeUserTest (pure $ CI.mk lid) $ concat ldapData
+            whenIsLeft decodedErr $ addMessageI Error
+            return ldapData
   mbLdapData <- formResultMaybe presult procFormPerson
 
 
+  ((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminLdapUpsert"::Text) $ \html -> 
+    flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
+  let procFormUpsert :: Text -> Handler (Maybe (Either CampusUserConversionException (Entity User)))
+      procFormUpsert lid = pure <$> runDB (try $ ldapLookupAndUpsert lid)
+  mbLdapUpsert <- formResultMaybe uresult procFormUpsert
+
+
   actionUrl <- fromMaybe AdminLdapR <$> getCurrentRoute
   siteLayoutMsg MsgMenuLdap $ do
     setTitleI MsgMenuLdap
@@ -78,7 +57,10 @@ postAdminLdapR = do
                       { formAction = Just $ SomeRoute actionUrl
                       , formEncoding = penctype
                       }
-
+        upsertForm = wrapForm uwidget def 
+                      { formAction = Just $ SomeRoute actionUrl
+                      , formEncoding = uenctype
+                      }
         presentUtf8   lv = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> lv)
         presentLatin1 lv = Text.intercalate ", " (                 Text.decodeLatin1 <$> lv)
 

src/Handler/Utils/Avs.hs

@@ -8,9 +8,10 @@
 module Handler.Utils.Avs
   ( upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard
   -- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface
-  , setLicence, setLicenceAvs, setLicencesAvs
+  , setLicence, setLicenceAvs, setLicencesAvs, computeDifferingLicences
   , checkLicences
   , lookupAvsUser, lookupAvsUsers
+  , AvsException(..)
   ) where
 
 import Import
@@ -25,7 +26,7 @@ import qualified Data.Map           as Map
 
 import qualified Data.CaseInsensitive as CI
 -- import Auth.LDAP (ldapUserPrincipalName)
-import Foundation.Yesod.Auth (upsertCampusUserByCn,CampusUserConversionException())
+import Foundation.Yesod.Auth (ldapLookupAndUpsert, CampusUserConversionException())
 
 import Handler.Utils.Company
 import Handler.Users.Add
@@ -111,24 +112,35 @@ setLicenceAvs apid lic = do
   let req = Set.singleton $ AvsPersonLicence { avsLicenceRampLicence = lic, avsLicencePersonID = apid }
   setLicencesAvs req
 
+
 --setLicencesAvs :: Set AvsPersonLicence -> Handler Bool
 setLicencesAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) =>
                   Set AvsPersonLicence -> m Bool
-setLicencesAvs pls = do
+setLicencesAvs persLics = do
-  AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
+    AvsQuery{avsQuerySetLicences=aqsl} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
-  response <- throwLeftM $ avsQuerySetLicences $ AvsQuerySetLicences pls
+    aux aqsl True persLics 
-  case response of
+  where 
-    AvsResponseSetLicencesError{..} -> do
+    aux aqsl batch0_ok pls
-      let msg = "Set AVS licences failed utterly: " <> avsResponseSetLicencesStatus <> ". Details: " <> cropText avsResponseSetLicencesMessage
+      | Set.null pls = return batch0_ok
-      $logErrorS "AVS" msg
+      | otherwise = do 
-      throwM $ AvsSetLicencesFailed avsResponseSetLicencesStatus
+        let (batch1, batch2) = Set.splitAt avsMaxSetLicenceAtOnce pls   
+        response <- throwLeftM $ aqsl $ AvsQuerySetLicences batch1
+        case response of
+          AvsResponseSetLicencesError{..} -> do
+            let msg = "Set AVS licences failed utterly: " <> avsResponseSetLicencesStatus <> ". Details: " <> cropText avsResponseSetLicencesMessage
+            $logErrorS "AVS" msg
+            throwM $ AvsSetLicencesFailed avsResponseSetLicencesStatus
+
+          AvsResponseSetLicences msgs -> do
+            let (ok,bad') = Set.partition (sloppyBool . avsResponseSuccess) msgs
+                ok_ids = Set.map avsResponsePersonID ok 
+                bad = Map.withoutKeys (setToMap avsResponsePersonID bad') ok_ids -- it is possible to receive an id multiple times, with only one success, but this is sufficient
+                batch1_ok = length ok == length batch1
+            forM_ bad $ \AvsLicenceResponse { avsResponsePersonID=api, avsResponseMessage=msg} ->
+              $logErrorS "AVS" $ "Set AVS Licence failed for " <> tshow api <> " due to " <> cropText msg
+              -- TODO: Admin Error page
+            aux aqsl (batch0_ok && batch1_ok) batch2 -- yay for tail recursion (TODO: maybe refactor?)
 
-    AvsResponseSetLicences msgs -> do
-      let (ok,bad) = Set.partition (sloppyBool . avsResponseSuccess) msgs
-      forM_ bad $ \AvsLicenceResponse { avsResponsePersonID=api, avsResponseMessage=msg} ->
-        $logErrorS "AVS" $ "Set AVS Licence failed for " <> tshow api <> " due to " <> cropText msg
-        -- TODO: Admin Error page
-      return $ length ok == length pls
 
 -- | Retrieve all currently valid driving licences and check against our database
 --   Only react to changes as compared to last seen status in avs.model
@@ -216,20 +228,17 @@ computeDifferingLicences (AvsResponseGetLicences licences) = do
         <> Set.map (AvsPersonLicence AvsLicenceVorfeld)  setTo1 
         <> Set.map (AvsPersonLicence AvsLicenceRollfeld) setTo2
 
-
+-- | Always update AVS Data
-upsertAvsUser :: Text -> Handler (Maybe UserId)
+upsertAvsUser :: Text -> Handler (Maybe UserId) -- TODO: change to Entity
 upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = upsertAvsUserByCard someid    -- Note: Right case is a number, it could be AvsCardNumber or AvsInternalPersonalNumber; we cannot know, but the latter is much more likely and useful to users!
-upsertAvsUser _other = return Nothing -- TODO: attempt LDAP lookup to find by eMail; merely for convenience, not necessary right now
+upsertAvsUser otherId = -- attempt LDAP lookup to find by eMail
-  {- maybe this code helps?
+  try (runDB $ ldapLookupAndUpsert otherId) >>= \case
-  upsRes :: Either CampusUserConversionException (Entity User)
+    Right Entity{entityVal=User{userCompanyPersonalNumber=Just persNo}} -> upsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo)
-    <- try $ upsertCampusUserByOther persNo
+    Left (_err::SomeException) -> return Nothing -- TODO: ; merely for convenience, not necessary right now  
-  case upsRes of
+    _ -> return Nothing
-    Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid
-    _other -> return mbuid -- ==Nothing -- user could not be created somehow
-  -}
 
 
--- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible.
+-- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible. Always update.
 --   Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB.
 upsertAvsUserByCard :: Either AvsFullCardNo AvsInternalPersonalNo -> Handler (Maybe UserId) -- Idee: Eingabe ohne Punkt is AvsInternalPersonalNo mit Punkt is Ausweisnummer?!
 upsertAvsUserByCard persNo = do
@@ -241,11 +250,12 @@ upsertAvsUserByCard persNo = do
   case Set.elems adps of
     []      -> throwM AvsPersonSearchEmpty
     (_:_:_) -> throwM AvsPersonSearchAmbiguous
-    [AvsDataPerson{avsPersonPersonID=appi}] -> do
+    [AvsDataPerson{avsPersonPersonID=api}] -> upsertAvsUserById api -- always trigger an update 
-      mbuid <- runDB $ getBy $ UniqueUserAvsId appi
+      -- do
-      case mbuid of
+        -- mbuid <- runDB $ getBy $ UniqueUserAvsId api
-        (Just (Entity _ UserAvs{userAvsUser=uau})) -> return $ Just uau
+        -- case mbuid of
-        Nothing -> upsertAvsUserById appi
+          -- (Just (Entity _ UserAvs{userAvsUser=uau})) -> return $ Just uau
+          -- Nothing -> upsertAvsUserById api
 
 
 
@@ -259,13 +269,15 @@ upsertAvsUserById api = do
     case (mbuid, mbapd) of
       (Nothing, Just AvsDataPerson{..})                         -- FRADriver User does not exist yet, but found in AVS and has Internal Personal Number
         | Just (avsInternalPersonalNo -> persNo) <- canonical avsPersonInternalPersonalNo -> do
+            $logInfoS "AVS" $ "Creating new user with avsInternalPersonalNo " <> tshow persNo
             candidates <- selectKeysList [UserCompanyPersonalNumber ==. Just persNo] []
             case candidates of
-              [uid] -> insertUniqueEntity $ UserAvs api uid
+              [uid] -> $logInfoS "AVS" "Matching user found, linking." >> insertUniqueEntity (UserAvs api uid)
               (_:_) -> throwM AvsUserAmbiguous
               [] -> do
                 upsRes :: Either CampusUserConversionException (Entity User)
-                  <- try $ upsertCampusUserByCn persNo
+                  <- try $ ldapLookupAndUpsert persNo
+                $logInfoS "AVS" $ "No matching user found. attempted LDAP upsert returned: " <> tshow upsRes
                 case upsRes of
                   Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid -- pin/addr are updated in next step anyway
                   _other -> return mbuid -- ==Nothing -- user could not be created somehow

src/Model/Types/Avs.hs

@@ -86,8 +86,13 @@ newtype AvsInternalPersonalNo = AvsInternalPersonalNo { avsInternalPersonalNo ::
   deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField) 
 instance E.SqlString AvsInternalPersonalNo
 -- AvsInternalPersonalNo is an untagged Text with respect to FromJSON/ToJSON, as needed by AVS API
+
 normalizeAvsInternalPersonalNo :: Text -> Text
 normalizeAvsInternalPersonalNo = Text.dropWhile (\c -> '0' == c || Char.isSpace c)
+
+mkAvsInternalPersonalNo :: Text -> AvsInternalPersonalNo
+mkAvsInternalPersonalNo = AvsInternalPersonalNo . normalizeAvsInternalPersonalNo
+
 instance Canonical AvsInternalPersonalNo where 
   canonical (AvsInternalPersonalNo ipn) = AvsInternalPersonalNo $ Text.dropWhile (\c -> '0' == c || Char.isSpace c) ipn
 instance FromJSON AvsInternalPersonalNo where
@@ -163,7 +168,7 @@ readAvsFullCardNo _ = Nothing
 discernAvsCardPersonalNo :: Text -> Maybe (Either AvsFullCardNo AvsInternalPersonalNo) -- Just implies it is a whole number or decimal with one digit after the point
 discernAvsCardPersonalNo (Text.span Char.isDigit -> (c, pv))
   | Text.null pv 
-    = Just $ Right $ AvsInternalPersonalNo c
+    = Just $ Right $ mkAvsInternalPersonalNo c
   | not $ Text.null c
   , Just ('.', v) <- Text.uncons pv
   , Just (Char.isDigit -> True, "") <- Text.uncons v

src/Utils.hs

@@ -788,6 +788,9 @@ partitionKeysEither = over _2 (Map.mapKeysMonotonic . view $ singular _Right) .
 mapFromSetM :: Applicative m => (k -> m v) -> Set k -> m (Map k v)
 mapFromSetM = (sequenceA .) . Map.fromSet
 
+setToMap :: (Ord k) => (v -> k) -> Set v -> Map k v
+setToMap mkKey = Map.fromList . fmap (\x -> (mkKey x, x)) . Set.toList
+
 mapFM :: (Applicative m, Ord k, Finite k) => (k -> m v) -> m (Map k v)
 mapFM = sequenceA . mapF
 

src/Utils/Avs.hs

@@ -27,6 +27,8 @@ type AVSPersonStatus    = "PersonStatus" :> ReqBody '[JSON] AvsQueryStatus :> Po
 type AVSGetRampLicences = "RampDrivingLicenceInfo" :> ReqBody '[JSON] AvsQueryGetLicences :> Post '[JSON] AvsResponseGetLicences
 type AVSSetRampLicences = "RampDrivingLicence"     :> ReqBody '[JSON] AvsQuerySetLicences :> Post '[JSON] AvsResponseSetLicences
 
+avsMaxSetLicenceAtOnce :: Int
+avsMaxSetLicenceAtOnce = 99   -- maximum input set size for avsQuerySetLicences as enforced by AVS
 
 avsApi :: Proxy AVS
 avsApi = Proxy

templates/ldap.hamlet

@@ -22,3 +22,12 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
             UTF8:  #{presentUtf8 lv}
             —
             Latin: #{presentLatin1 lv}
+<section>
+  <p>
+    LDAP Upsert user in DB:
+    ^{upsertForm}
+  $maybe answer <- mbLdapUpsert
+    <h1>
+      Antwort: #
+    <p>
+      #{tshow answer}

test/Utils/TypesSpec.hs

@@ -15,8 +15,8 @@ instance Arbitrary SloppyBool where
   shrink (SloppyBool x) = SloppyBool <$> shrink x
 
 instance Arbitrary AvsInternalPersonalNo where 
-  arbitrary = canonical . AvsInternalPersonalNo <$> arbitrary
+  arbitrary = mkAvsInternalPersonalNo <$> arbitrary
-  shrink (AvsInternalPersonalNo x) = canonical . AvsInternalPersonalNo <$> shrink x
+  shrink (AvsInternalPersonalNo x) = mkAvsInternalPersonalNo <$> shrink x
 
 instance Arbitrary AvsPersonId where 
   arbitrary = AvsPersonId <$> arbitrary