chore(avs): add all new avs functions to admin test interface for testing

messages/uniworx/categories/avs/de-de-formal.msg

@@ -11,3 +11,4 @@ AvsInternalPersonalNo: Personalnummer (nur Fraport AG)
 AvsVersionNo: Versionsnummer
 AvsQueryEmpty: Bitte mindestens ein Anfragefeld ausfüllen!
 AvsQueryStatusInvalid t@Text: Nur numerische IDs eingeben, durch Komma getrennt! Erhalten: #{show t}
+AvsLicence: Fahrberechtigung

messages/uniworx/categories/avs/en-eu.msg

@@ -11,3 +11,4 @@ AvsInternalPersonalNo: Personnel number (Fraport AG only)
 AvsVersionNo: Version number
 AvsQueryEmpty: At least one query field must be filled!
 AvsQueryStatusInvalid t: Numeric IDs only, comma seperated! #{show t}
+AvsLicence: Driving Licence

src/Handler/Admin/Avs.hs

@@ -14,9 +14,24 @@ import qualified Data.Text as Text
 import qualified Data.Set  as Set
 
 import Handler.Utils
+import Handler.Utils.Avs
 
 import Utils.Avs
 
+-- Button needed only here
+data ButtonAvsTest = BtnCheckLicences
+  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
+instance Universe ButtonAvsTest
+instance Finite ButtonAvsTest
+
+nullaryPathPiece ''ButtonAvsTest camelToPathPiece
+
+instance Button UniWorX ButtonAvsTest where
+  btnLabel    BtnCheckLicences = "Check all licences" -- could be msg
+  btnClasses  BtnCheckLicences = [BCIsButton, BCPrimary]  
+-- END Button
+
+
 avsCardNoField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m AvsCardNo
 avsCardNoField = convertField AvsCardNo avsCardNo textField
 
@@ -57,6 +72,17 @@ validateAvsQueryStatus = do
   AvsQueryStatus ids <- State.get
   guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids)
 
+
+avsLicenceOptions :: OptionList AvsLicence
+avsLicenceOptions = mkOptionList 
+  [ Option 
+    { optionDisplay       = Text.singleton $ licence2char l
+    , optionInternalValue = l
+    , optionExternalValue = toJsonText l
+    }  
+  | l <- universeF
+  ]
+
 getAdminAvsR,  postAdminAvsR :: Handler Html
 getAdminAvsR = postAdminAvsR
 postAdminAvsR = do
@@ -81,16 +107,73 @@ postAdminAvsR = do
               Right jsn -> return . Just $ tshow jsn         
       mbStatus <- formResultMaybe sresult procFormStatus
 
+      ((crUsrRes, crUsrWgt), crUsrEnctype) <- runFormPost $ identifyForm FIDAvsCreateUser $ \html -> 
+        flip (renderAForm FormStandard) html $ areq textField (fslI MsgAvsCardNo) Nothing
+      let procFormCrUsr fr = do 
+            res <- try $ upsertAvsUser fr
+            case res of 
+              (Right (Just uid)) -> do 
+                uuid :: CryptoUUIDUser <- encrypt uid
+                return $ Just [whamlet|<h2>Success:</h2> <a href=@{ForProfileR uuid}>User created or updated.|]
+              (Right Nothing) ->
+                return $ Just [whamlet|<h2>Warning:</h2> No user found.|]
+              (Left e) -> do
+                let msg = tshow (e :: SomeException)
+                return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
+      mbCrUser <- formResultMaybe crUsrRes procFormCrUsr
+
+      ((getLicRes, getLicWgt), getLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicence $ \html -> 
+        flip (renderAForm FormStandard) html $ areq intField (fslI MsgAvsPersonId) Nothing
+      let procFormGetLic fr = do 
+            res <- try $ getLicenceByAvsId $ AvsPersonId fr
+            case res of 
+              (Right (Just lic)) -> 
+                return $ Just [whamlet|<h2>Success:</h2> Licence #{tshow lic}|]
+              (Right Nothing) ->
+                return $ Just [whamlet|<h2>Warning:</h2> User not found.|]
+              (Left e) -> do
+                let msg = tshow (e :: SomeException)
+                return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
+      mbGetLic <- formResultMaybe getLicRes procFormGetLic
+
+      ((setLicRes, setLicWgt), setLicEnctype) <- runFormPost $ identifyForm FIDAvsSetLicence $ \html -> 
+        flip (renderAForm FormStandard) html $ (,) <$> areq intField (fslI MsgAvsPersonId) Nothing 
+                                                   <*> areq (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) (Just AvsLicenceVorfeld)
+      let procFormSetLic (aid, lic) = do 
+            res <- try $ setLicenceAvs (AvsPersonId aid) lic
+            case res of 
+              (Right True) -> 
+                return $ Just [whamlet|<h2>Success:</h2> Licence #{tshow (licence2char lic)} set for #{tshow aid}.|]
+              (Right False) ->
+                return $ Just [whamlet|<h2>Error:</h2> Licence could not be set for #{tshow aid}.|]
+              (Left e) -> do
+                let msg = tshow (e :: SomeException)
+                return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
+      mbSetLic <- formResultMaybe setLicRes procFormSetLic
+
+
+      ((qryLicRes, qryLicWgt), qryLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicenceDiffs (buttonForm :: Form ButtonAvsTest)
+      let procFormQryLic BtnCheckLicences = 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>Error:</h2> #{msg}|]
+      mbQryLic <- formResultMaybe qryLicRes procFormQryLic
+
       actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
       siteLayoutMsg MsgMenuAvs $ do
         setTitleI MsgMenuAvs
-        let personForm = wrapForm pwidget def 
+        let wrapFormHere fw fe = wrapForm fw def { formAction = Just $ SomeRoute actionUrl, formEncoding = fe }
-                          { formAction = Just $ SomeRoute actionUrl
+            personForm = wrapFormHere pwidget  penctype
-                          , formEncoding = penctype
+            statusForm = wrapFormHere swidget  senctype
-                          }
+            crUsrForm  = wrapFormHere crUsrWgt crUsrEnctype
-            statusForm = wrapForm swidget def 
+            getLicForm = wrapFormHere getLicWgt getLicEnctype
-                          { formAction = Just $ SomeRoute actionUrl
+            setLicForm = wrapFormHere setLicWgt setLicEnctype
-                          , formEncoding = senctype
+            qryLicForm = wrapForm     qryLicWgt def { formAction = Just $ SomeRoute actionUrl, formEncoding = qryLicEnctype, formSubmit = FormNoSubmit }
-                          }
         -- TODO: use i18nWidgetFile instead if this is to become permanent
         $(widgetFile "avs")  

src/Handler/Utils/Avs.hs

@@ -7,7 +7,7 @@
 
 module Handler.Utils.Avs
   ( upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard
-  , getLicence, getLicenceDB
+  , getLicence, getLicenceDB, getLicenceByAvsId
   , setLicence, setLicenceAvs, setLicencesAvs
   , checkLicences
   , lookupAvsUser, lookupAvsUsers
@@ -85,6 +85,14 @@ getLicenceDB uid = do
   let ulicence = Set.lookupMax $ Set.filter ((userAvsPersonId ==) . avsLicencePersonID) licences
   return (avsLicenceRampLicence <$> ulicence)
 
+getLicenceByAvsId :: (MonadHandler m, MonadThrow m, MonadReader UniWorX ((->) (HandlerSite m)), HandlerSite m ~ UniWorX) =>
+                      AvsPersonId -> m (Maybe AvsLicence)
+getLicenceByAvsId aid = do
+  AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ liftHandler $ getsYesod $ view _appAvsQuery
+  AvsResponseGetLicences licences <- throwLeftM $ avsQueryGetLicences $ AvsQueryGetLicences $ Set.singleton $ AvsObjPersonId aid
+  let ulicence = Set.lookupMax $ Set.filter ((aid ==) . avsLicencePersonID) licences
+  return (avsLicenceRampLicence <$> ulicence)
+
 
 -- setLicence :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => UserId -> AvsLicence -> m Bool
 setLicence :: (PersistUniqueRead backend, MonadThrow m,
@@ -179,7 +187,7 @@ computeDifferingLicences (AvsResponseGetLicences licences) = do
     <$> antijoinAvsLicences AvsLicenceVorfeld  vorORrollfeld
     <*> antijoinAvsLicences AvsLicenceRollfeld rollfeld
   let setTo0 = vorfRevoke -- ready to use with SET 0 
-      setTo1 = (vorfGrant \\ rollGrant ) `Set.union` (rollRevoke Set.\\ vorfRevoke)
+      setTo1 = (vorfGrant Set.\\ rollGrant ) `Set.union` (rollRevoke Set.\\ vorfRevoke)
       setTo2 = (rollGrant Set.\\ vorfRevoke) `Set.intersection` (vorfGrant `Set.union` vorORrollfeld)
       {-
         Cases to consider (AVS_Licence,has_valid_F, has_valid_R) -> (vorfeld@(toset,unset), rollfeld@(toset,unset)) : 
@@ -336,9 +344,6 @@ upsertAvsUserById api = do
       return $ Just uid
 
 
-
-
-
 lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
                   AvsPersonId -> m (Maybe AvsDataPerson)
 lookupAvsUser api = Map.lookup api <$> lookupAvsUsers (Set.singleton api)

src/Utils/Form.hs

@@ -303,6 +303,10 @@ data FormIdentifier
   | FIDAllocationNotification
   | FIDAvsQueryPerson
   | FIDAvsQueryStatus
+  | FIDAvsCreateUser
+  | FIDAvsQueryLicenceDiffs
+  | FIDAvsQueryLicence
+  | FIDAvsSetLicence
   | FIDLmsLetter
   deriving (Eq, Ord, Read, Show)
 

templates/avs.hamlet

@@ -6,7 +6,39 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
 
 <section>
   <p> 
-    Person Search:
+    Upsert User by CardNo or Fraport Personnel Number:
+    ^{crUsrForm}
+  $maybe answer <- mbCrUser
+    <p>
+      ^{answer}  
+
+<section>
+  <p> 
+    Get Licence by AVS Person ID:
+    ^{getLicForm}
+  $maybe answer <- mbGetLic
+    <p>
+      ^{answer}  
+
+<section>
+  <p> 
+    Set Licence by AVS Person ID:
+    ^{setLicForm}
+  $maybe answer <- mbSetLic
+    <p>
+      ^{answer}  
+
+<section>
+  <p> 
+    Synchronize licences with AVS.
+    ^{qryLicForm}
+  $maybe answer <- mbQryLic
+    <p>
+      ^{answer}  
+
+<section>
+  <p> 
+    Person search:
     ^{personForm}
   $maybe answer <- mbPerson
     <p>
@@ -15,7 +47,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
 
 <section>
   <p> 
-    Person Status:
+    Person status:
     ^{statusForm}
   $maybe answer <- mbStatus
     <p>