chore(avs): expand avs interface

routes

@@ -55,10 +55,10 @@
 /users/#CryptoUUIDUser        AdminUserR       GET POST
 /users/#CryptoUUIDUser/delete AdminUserDeleteR     POST
 /users/#CryptoUUIDUser/hijack AdminHijackUserR     POST       !adminANDno-escalation
-/users/#CryptoUUIDUser/notifications UserNotificationR GET POST   !self
+/users/#CryptoUUIDUser/notifications  UserNotificationR           GET POST   !self
-/users/#CryptoUUIDUser/password      UserPasswordR     GET POST   !selfANDis-pw-hash
+/users/#CryptoUUIDUser/password       UserPasswordR               GET POST   !selfANDis-pw-hash
-!/users/functionary-invite/new AdminNewFunctionaryInviteR  GET POST
+!/users/functionary-invite/new        AdminNewFunctionaryInviteR  GET POST
-!/users/functionary-invite     AdminFunctionaryInviteR     GET POST
+!/users/functionary-invite            AdminFunctionaryInviteR     GET POST
 !/users/add                   AdminUserAddR    GET POST
 /admin                        AdminR           GET
 /admin/test                   AdminTestR       GET POST

src/Handler/Users/Add.hs

@@ -4,7 +4,7 @@
 
 module Handler.Users.Add
   ( getAdminUserAddR, postAdminUserAddR
-  -- , AdminUserForm(..), adminUserForm                 -- no longer needed elsewhere
+  , AdminUserForm(..), adminUserForm                    -- no longer needed elsewhere
   -- , AuthenticationKind(..), classifyAuth, mkAuthMode -- no longer needed elsewhere   
   ) where
 

src/Handler/Utils/Avs.hs

@@ -9,6 +9,7 @@ module Handler.Utils.Avs
   , setLicence, setLicenceAvs, setLicencesAvs
   , checkLicences
   , lookupAvsUser, lookupAvsUsers
+  , upsertAvsUser, upsertAvsUserByCard
   ) where
 
 import Import
@@ -22,6 +23,7 @@ import qualified Data.Set           as Set
 import qualified Data.Map           as Map
 -- import qualified Data.Text          as Text
 
+import Handler.Users.Add
 
 
 --------------------
@@ -29,8 +31,11 @@ import qualified Data.Map           as Map
 --------------------
 
 data AvsException
-  = AvsInterfaceUnavailable
+  = AvsInterfaceUnavailable             -- Interface to AVS was not configured at startup or does not respond
-  | AvsUserUnknown UserId
+  | AvsUserUnassociated UserId          -- Manipulating AVS Data for a user that is not linked to AVS yet
+  | AvsUserUnknownByAvs AvsPersonId     -- AvsPersionId not (or no longer) found in AVS DB
+  | AvsPersonSearchEmpty                -- AvsPersonSearch returned empty result 
+  | AvsPersonSearchAmbiguous            -- AvsPersonSearch returned more than one result 
   deriving (Show, Generic, Typeable)
 instance Exception AvsException
 
@@ -56,7 +61,7 @@ instance Exception AvsException
 getLicence :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, WithRunDB SqlReadBackend (HandlerFor UniWorX) m ) => UserId -> m (Maybe AvsLicence)
 getLicence uid = do
   AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
-  Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnknown uid) $ useRunDB $ getBy $ UniqueUserAvsUser uid
+  Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnassociated uid) $ useRunDB $ getBy $ UniqueUserAvsUser uid
   AvsResponseGetLicences licences <- throwLeftM $ avsQueryGetLicences $ AvsQueryGetLicences $ Set.singleton $ AvsObjPersonId userAvsPersonId
   let ulicence = Set.lookupMax $ Set.filter ((userAvsPersonId ==) . avsLicencePersonID) licences
   return (avsLicenceRampLicence <$> ulicence)
@@ -64,15 +69,14 @@ getLicence uid = do
 getLicenceDB :: UserId -> DB (Maybe AvsLicence)
 getLicenceDB uid = do
   AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ liftHandler $ getsYesod $ view _appAvsQuery
-  Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnknown uid) $ getBy $ UniqueUserAvsUser uid
+  Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnassociated uid) $ getBy $ UniqueUserAvsUser uid
   AvsResponseGetLicences licences <- throwLeftM $ avsQueryGetLicences $ AvsQueryGetLicences $ Set.singleton $ AvsObjPersonId userAvsPersonId
   let ulicence = Set.lookupMax $ Set.filter ((userAvsPersonId ==) . avsLicencePersonID) licences
   return (avsLicenceRampLicence <$> ulicence)
 
-
 setLicence :: UserId -> AvsLicence -> DB ()
 setLicence uid lic = do
-  Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnknown uid) $ getBy $ UniqueUserAvsUser uid
+  Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnassociated uid) $ getBy $ UniqueUserAvsUser uid
   setLicenceAvs userAvsPersonId lic
 
 setLicenceAvs :: AvsPersonId -> AvsLicence -> DB ()
@@ -111,19 +115,63 @@ or
 
 -}
 
-{-
+-- | Retrieve and _always_ update user by AvsPersonId. Non-existing users are created.
-upsertAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => 
+--   Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB (should never happen).
-                AvsPersonId -> m ()
+upsertAvsUser :: AvsPersonId -> Handler (Maybe UserId)
 upsertAvsUser api = do
-  mbuid <- getBy $ UniqueUserAvsId api 
+  mbuid <- runDB $ getBy $ UniqueUserAvsId api 
   mbapd <- lookupAvsUser api
   case (mbuid, mbapd) of
-    ( _     , Nothing)    -> error "TODO" -- CONTINUE HERE   -- this should no happen
+    ( _     , Nothing)    -> throwM $ AvsUserUnknownByAvs api -- this should never happen
-    (Nothing, Just apd)   -> do   -- unknown user
+    (Nothing, Just AvsDataPerson{..})   -> do   -- unknown user, must be created
+      -- if | Just ipn <- avsPersonInternalPersonalNo -> TODO?
+      let _newUsr = AdminUserForm 
+            { aufTitle     = Nothing
+            , aufFirstName = avsPersonFirstName
+            , aufSurname   = avsPersonLastName
+            , aufDisplayName = avsPersonFirstName <> " " <> avsPersonLastName
+            , aufDisplayEmail = "" -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO)
+            , aufMatriculation = Nothing
+            , aufSex = Nothing 
+            , aufMobile = Nothing
+            , aufTelephone = Nothing
+            , aufFPersonalNumber = avsPersonInternalPersonalNo
+            , aufFDepartment = Nothing
+            , aufPostAddress = error "TODO" -- CONTINUE HERE
+            , aufPrefersPostal = error "TODO" -- CONTINUE HERE
+            , aufPinPassword = error "TODO" -- CONTINUE HERE
+            , aufEmail = "" 
+            , aufIdent = error "TODO" -- CONTINUE HERE
+            , aufAuth  = error "TODO" -- CONTINUE HERE AuthKindNoLogin or AuthKindLDAP if ldap search worked 
+            }
+          -- _newAvs = UserAvs avsPersonPersonID uid
+          -- _newAvsCards = UserAvsCard 
       error "TODO" -- CONTINUE HERE
-    (Just uid, Just apd)  -> do   -- known user 
+    (Just _uid, Just _apd)  -> do   -- known user 
       error "TODO" -- CONTINUE HERE
--}
+
+
+-- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible. 
+--   Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB.
+--upsertAvsUserByCard :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => 
+-- upsertAvsUserByCard :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, WithRunDB SqlReadBackend (HandlerFor UniWorX) m )
+upsertAvsUserByCard :: 
+  Either (AvsCardNo,AvsVersionNo) AvsInternalPersonalNo -> Handler (Maybe UserId) -- Idee: Eingabe ohne Punkt is AvsInternalPersonalNo mit Punkt is Ausweisnummer?!
+upsertAvsUserByCard persNo = do
+  let qry = case persNo of 
+              Left (acn,avn) -> def{ avsPersonQueryCardNo = Just acn, avsPersonQueryVersionNo = Just avn }
+              Right fpn      -> def{ avsPersonQueryInternalPersonalNo = Just fpn }
+  AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
+  AvsResponsePerson adps <- throwLeftM $ avsQueryPerson qry
+  case Set.elems adps of 
+    []      -> throwM AvsPersonSearchEmpty
+    (_:_:_) -> throwM AvsPersonSearchAmbiguous 
+    [AvsDataPerson{avsPersonPersonID=appi}] -> do 
+      mbuid <- runDB $ getBy $ UniqueUserAvsId appi
+      case mbuid of 
+        (Just (Entity _ UserAvs{userAvsUser=uau})) -> return $ Just uau
+        Nothing -> upsertAvsUser appi
+
 
 
 lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => 
@@ -136,6 +184,7 @@ lookupAvsUser api = Map.lookup api <$> lookupAvsUsers (Set.singleton api)
 --    - avsQueryStatus only provides limited information
 --   avsQuery is used to obtain all card numbers, which are then queried separately an merged
 --   May throw Servant.ClientError or AvsExceptions
+--   Does not write to our own DB!
 lookupAvsUsers :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => 
                    Set AvsPersonId -> m (Map AvsPersonId AvsDataPerson)
 lookupAvsUsers apis = do 
@@ -143,7 +192,7 @@ lookupAvsUsers apis = do
   AvsResponseStatus statuses <- throwLeftM . avsQueryStatus $ AvsQueryStatus apis
   let forFoldlM = $(permuteFun [3,2,1]) foldlM
   forFoldlM statuses mempty $ \acc1 AvsStatusPerson{avsStatusPersonCardStatus=cards} -> 
-    forFoldlM cards acc1 $ \acc2 AvsDataPersonCard{avsDataCardNo} -> do
+    forFoldlM cards acc1 $ \acc2 AvsDataPersonCard{avsDataCardNo, avsDataVersionNo} -> do
-      AvsResponsePerson adps <- throwLeftM . avsQueryPerson $ def{avsPersonQueryCardNo = Just avsDataCardNo}
+      AvsResponsePerson adps <- throwLeftM . avsQueryPerson $ def{avsPersonQueryCardNo = Just avsDataCardNo, avsPersonQueryVersionNo = Just avsDataVersionNo}
       return $ mergeByPersonId adps acc2
     

src/Model/Types/Avs.hs

@@ -80,13 +80,19 @@ instance FromJSON SloppyBool where
 -- AVS Datatypes --
 -------------------
 
+type AvsInternalPersonalNo = Text -- type synonym for claritty/documentation within types
+
+-- CompleteCardNo = xxxxxxxx.y 
+-- where x is an 8 digit AvsCardNo prefixed by zeros 
+--   and y is the 1 digit AvsVersionNo
+type AvsVersionNo = Text -- always 1 digit 
 newtype AvsCardNo = AvsCardNo { avsCardNo :: Text }  -- always 8 digits
   deriving (Eq, Ord, Show, Generic, Typeable)
   deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField)
 instance E.SqlString AvsCardNo
 -- AvsCardNo is an untagged Text with respect to FromJSON/ToJSON, as needed by AVS API
 instance FromJSON AvsCardNo where
-  parseJSON x = AvsCardNo <$> parseJSON x
+  parseJSON x = AvsCardNo . Text.justifyRight 8 '0' <$> parseJSON x
 instance ToJSON AvsCardNo where
   toJSON (AvsCardNo cno) = toJSON cno
 
@@ -163,17 +169,17 @@ instance FromJSON AvsDataCardColor where
 
 
 data AvsDataPersonCard = AvsDataPersonCard
-      { avsDataValid     :: Bool        -- card currently valid? Note that AVS encodes booleans as JSON String "true" and "false" and not as JSON booleans
+      { avsDataValid     :: Bool          -- card currently valid? Note that AVS encodes booleans as JSON String "true" and "false" and not as JSON booleans
-      , avsDataValidTo   :: Maybe Day   -- Nothing if returned with AvsResponseStatus
+      , avsDataValidTo   :: Maybe Day     -- Nothing if returned with AvsResponseStatus
-      , avsDataIssueDate :: Maybe Day   -- Nothing if returned with AvsResponseStatus
+      , avsDataIssueDate :: Maybe Day     -- Nothing if returned with AvsResponseStatus
       , avsDataCardColor :: AvsDataCardColor
-      , avsDataCardAreas :: Set Char    -- logically a set of upper-case letters
+      , avsDataCardAreas :: Set Char      -- logically a set of upper-case letters
-      , avsDataStreet    :: Maybe Text  -- Nothing if returned with AvsResponseStatus
+      , avsDataStreet    :: Maybe Text    -- Nothing if returned with AvsResponseStatus
-      , avsDataPostalCode:: Maybe Text  -- Nothing if returned with AvsResponseStatus
+      , avsDataPostalCode:: Maybe Text    -- Nothing if returned with AvsResponseStatus
-      , avsDataCity      :: Maybe Text  -- Nothing if returned with AvsResponseStatus
+      , avsDataCity      :: Maybe Text    -- Nothing if returned with AvsResponseStatus
-      , avsDataFirm      :: Maybe Text  -- Nothing if returned with AvsResponseStatus
+      , avsDataFirm      :: Maybe Text    -- Nothing if returned with AvsResponseStatus
-      , avsDataCardNo    :: AvsCardNo   -- always 8 digits
+      , avsDataCardNo    :: AvsCardNo     -- always 8 digits number, prefixed with 0 
-      , avsDataVersionNo :: Text
+      , avsDataVersionNo :: AvsVersionNo  -- always 1 digit number
       }
   deriving (Eq, Ord, Show, Generic, Typeable)
   deriving anyclass (NFData)
@@ -257,9 +263,9 @@ deriveJSON defaultOptions
 data AvsDataPerson = AvsDataPerson
       { avsPersonFirstName          :: Text
       , avsPersonLastName           :: Text
-      , avsPersonInternalPersonalNo :: Maybe Text   -- Fraport Personalnummer
+      , avsPersonInternalPersonalNo :: Maybe AvsInternalPersonalNo  -- Fraport Personalnummer
-      , avsPersonPersonNo           :: Int          -- AVS Personennummer, Bedeutung ist unklar
+      , avsPersonPersonNo           :: Int                          -- AVS Personennummer, Bedeutung ist unklar
-      , avsPersonPersonID           :: AvsPersonId  -- Eindeutige PersonenID, wichtig für die Schnittstelle!
+      , avsPersonPersonID           :: AvsPersonId                  -- Eindeutige PersonenID, wichtig für die Schnittstelle!
       , avsPersonPersonCards        :: Set AvsDataPersonCard
       }
     deriving (Eq, Ord, Show, Generic, Typeable)
@@ -373,10 +379,10 @@ deriveJSON defaultOptions
 -------------
 data AvsQueryPerson = AvsQueryPerson
         { avsPersonQueryCardNo             :: Maybe AvsCardNo
+        , avsPersonQueryVersionNo          :: Maybe AvsVersionNo
         , avsPersonQueryFirstName          :: Maybe Text
         , avsPersonQueryLastName           :: Maybe Text
-        , avsPersonQueryInternalPersonalNo :: Maybe Text
+        , avsPersonQueryInternalPersonalNo :: Maybe AvsInternalPersonalNo
-        , avsPersonQueryVersionNo          :: Maybe Text
         }
   deriving (Eq, Ord, Show, Generic, Typeable)