refactor(avs): rework createAvsUserById (WIP)

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

@@ -39,3 +39,12 @@ AvsCardColorRed: Rot
 AvsCardColorYellow: Gelb
 LastAvsSynchronisation: Letzte AVS-Synchronisation
 LastAvsSynchError: Letzte AVS-Fehlermeldung
+
+AvsInterfaceUnavailable: AVS Schnittstelle nicht richtig konfiguriert oder antwortet nicht
+AvsUserUnassociated user@UserDisplayName: AVS Id unbekannt für Nutzer #{user}
+AvsUserUnknownByAvs api@AvsPersonId: AVS kennt Id #{tshow api} nicht (mehr)
+AvsUserAmbiguous api@AvsPersonId: AVS Id #{tshow api} ist nicht eindeutig
+AvsPersonSearchEmpty: AVS Suche lieferte leeres Ergebnis
+AvsPersonSearchAmbiguous: AVS Suche lieferte mehrere uneindeutige Ergebnisse
+AvsSetLicencesFailed reason@Text: Setzen der Fahrlizenz im AVS fehlgeschlagen. Grund: #{reason}
+AvsIdMismatch api1@AvsPersonId api2@AvsPersonId: AVS Suche für Id #{tshow api1} lieferte stattdessen Id #{tshow api2}

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

@@ -38,4 +38,13 @@ AvsCardColorBlue: Blue
 AvsCardColorRed: Red
 AvsCardColorYellow: Yellow
 LastAvsSynchronisation: Last AVS synchronisation
-LastAvsSynchError: Last AVS Error
+LastAvsSynchError: Last AVS Error
+
+AvsInterfaceUnavailable: AVS interface was not configured correctly or does not respond
+AvsUserUnassociated user: AVS id unknown for user #{user}
+AvsUserUnknownByAvs api: AVS reports id #{tshow api} as unknown (or no longer known)
+AvsUserAmbiguous api: Multiple matching users found for #{tshow api}
+AvsPersonSearchEmpty: AVS search returned empty result
+AvsPersonSearchAmbiguous: AVS search returned more than one result
+AvsSetLicencesFailed reason: Set driving licence within AVS failed. Reason: #{reason}
+AvsIdMismatch api1 api2: AVS search for id #{tshow api1} returned id #{tshow api2} instead

models/users.model

@@ -15,8 +15,8 @@ User json    -- Each Uni2work user has a corresponding row in this table; create
     surname        UserSurname              -- Display user names always through 'nameWidget displayName surname'
     displayName    UserDisplayName
     displayEmail   UserEmail                -- Case-insensitive eMail address, used for sending; leave empty for using auto-update CompanyEmail via UserCompany
-    email          UserEmail                -- Case-insensitive eMail address, used for identification and fallback for sending  TODO: make this nullable
+    email          UserEmail                -- Case-insensitive eMail address, used for identification and fallback for sending. Defaults to "AVSNO:dddddddd" if unknown
-    ident          UserIdent                -- Case-insensitive user-identifier
+    ident          UserIdent                -- Case-insensitive user-identifier. Defaults to "AVSID:dddddddd" if unknown
     authentication AuthenticationMode       -- 'AuthLDAP' or ('AuthPWHash'+password-hash)
     lastAuthentication UTCTime Maybe        -- last login date
     created        UTCTime default=now()
@@ -44,7 +44,7 @@ User json    -- Each Uni2work user has a corresponding row in this table; create
     mobile         Text Maybe
     companyPersonalNumber Text Maybe -- Company will become a new table, but if company=fraport, some information is received via LDAP 
     companyDepartment     Text Maybe -- thus we store such information for ease of reference directly, if available 
-    pinPassword           Text Maybe -- used to encrypt pins within emails
+    pinPassword           Text Maybe -- used to encrypt pins within emails, defaults to cardno.version
     postAddress           StoredMarkup Maybe    -- including company name, if any, but excluding username; leave empty for using auto-update CompanyPostAddress via UserCompany
     postLastUpdate        UTCTime Maybe         -- record postal address updates
     prefersPostal         Bool default=false    -- user prefers letters by post instead of email

src/Handler/Utils/Avs.hs

@@ -34,19 +34,26 @@ import Import
 -- import qualified Database.Esqueleto.Legacy as E
 
 import Utils.Avs
-import Utils.Users
+-- import Utils.Users
 
 import qualified Data.Set             as Set
 import qualified Data.Map             as Map
 import qualified Data.Text            as Text
 import qualified Data.CaseInsensitive as CI
+
+import qualified Control.Monad.Catch  as Catch
+
 -- import Auth.LDAP (ldapUserPrincipalName)
 import Foundation.Yesod.Auth (ldapLookupAndUpsert) -- , CampusUserConversionException())
 
+
+import Utils.Mail (pickValidEmail)
+import Utils.Users
+import Handler.Utils.Users
+import Handler.Utils.Profile (validPostAddressText)
 import Handler.Utils.Company
 import Handler.Utils.Qualification
 import Handler.Utils.Memcached
-import Handler.Utils.Users
 
 import           Database.Persist.Sql (deleteWhereCount) --, updateWhereCount)
 import           Database.Esqueleto.Experimental ((:&)(..))
@@ -56,8 +63,6 @@ import qualified Database.Esqueleto.PostgreSQL   as E
 
 import Servant.Client.Core.ClientError (ClientError)
 
-import Utils.Mail (pickValidEmail)
-import Handler.Utils.Profile (validPostAddressText)
 
 
 --------------------
@@ -66,26 +71,37 @@ import Handler.Utils.Profile (validPostAddressText)
 
 data AvsException
   = AvsInterfaceUnavailable                   -- Interface to AVS was not configured at startup or does not respond
-  | AvsUserUnassociated UserId                -- Manipulating AVS Data for a user that is not linked to AVS yet
+  | AvsUserUnassociated Text                  -- Manipulating AVS Data for a user that is not linked to AVS yet
-  | AvsUserUnknownByAvs AvsPersonId           -- AvsPersonId not (or no longer) found in AVS DB
+  | AvsUserUnknownByAvs AvsPersonId           -- AvsPersonId not (or no longer) found in AVS
-  | AvsUserAmbiguous    AvsPersonId           -- Multiple matching existing users found in our DB
+  | AvsUserAmbiguous    AvsPersonId           -- Multiple matching existing users found for a query in AVS or DB
   | AvsPersonSearchEmpty                      -- AvsPersonSearch returned empty result
   | AvsPersonSearchAmbiguous                  -- AvsPersonSearch returned more than one result
   | AvsSetLicencesFailed Text                 -- AvsSetLicence total failure
+  | AvsIdMismatch AvsPersonId AvsPersonId     -- First AVS Id was requested, but second one was returned for that query    
   deriving (Show, Eq, Ord, Generic)
 instance Exception AvsException
+embedRenderMessage ''UniWorX ''AvsException id  -- display as feedback for user initiated actions -- moved to Foundation.I18n
 
 {-
   Error Handling: in Addition to AvsException, Servant.ClientError must be expected. Maybe we should wrap it within an AvsException?
-
-  handleAvsExceptions = (`catches` handlers)
-    where 
-      handlers = 
-        [ Handler (\(e::AvsException  -> handleAvsException e))
-        , Handler (\(e::ClientError   -> handleClientError  e))
-        ]
 -}
 
+-- | Catch AVS exceptions and display them as messages
+-- catchAVS2message :: (MonadHandler m, MonadCatch m, RenderMessage (HandlerSite m) AvsException) => m (Maybe a) -> m (Maybe a)
+catchAVS2message :: Handler (Maybe a) -> Handler (Maybe a)
+catchAVS2message act = act `catches` handlers
+  where
+    handlers = 
+      [ Catch.Handler (\(exc::AvsException) -> addMessageI Warning exc >> return Nothing)
+      , Catch.Handler (\(exc::ClientError ) -> do
+            let msg = "AVS fatal communicaton failure: " <> tshow exc
+            $logErrorS "AVS" msg
+            addMessage Warning $ toHtml msg
+            return Nothing
+          )
+      ]
+
+
 ------------------
 -- AVS Handlers --
 ------------------
@@ -412,6 +428,17 @@ queryAvsCardNo crd = do
                                        , avsPersonQueryVersionNo  = Just avsFullCardVersion
                                        }
 
+-- | Queries AVS Status to retrieve primary card
+queryAvsPrimaryCard :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => AvsPersonId -> m (Maybe AvsDataPersonCard)
+queryAvsPrimaryCard api = runMaybeT $ do 
+  AvsResponseStatus res <- MaybeT . maybeCatchAll . fmap Just . avsQuery . AvsQueryStatus $ Set.singleton api
+  pstatus <- hoistMaybe $ Set.lookupMax $ Set.filter ((api ==) . avsStatusPersonID) res
+  hoistMaybe $ Set.lookupMax $ avsStatusPersonCardStatus pstatus
+  
+-- | Queries AVS to retrieve pin generated from primary card no 
+queryAvsPin :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => AvsPersonId -> m (Maybe Text)
+queryAvsPin = fmap (fmap personCard2pin) . queryAvsPrimaryCard
+
 
 _avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe StoredMarkup)
 _avsFirmPostAddress = to mkPost
@@ -447,7 +474,7 @@ _avsFirmPrefersPostal = to mkPostPref
   where 
     mkPostPref afi = isJust (afi ^. _avsFirmPostAddress) || isNothing (afi ^. _avsFirmPrimaryEmail)
 
-
+  
 
 -- A datatype for a specific heterogeneous list to compute DB updates, consisting of a persistent record field and a fitting lens
 data CheckAvsUpdate record iavs = forall typ. (Eq typ, PersistField typ) => CheckAvsUpdate (EntityField record typ) (Getting typ iavs typ) -- A persistent record field and fitting getting
@@ -623,13 +650,44 @@ createAvsUserById api = do
   case Set.toList res of
     []      -> return Nothing
     (_:_:_) -> throwM $ AvsUserAmbiguous api
-    [AvsDataContact{..}] -> runDB $ do
+    [AvsDataContact{avsContactPersonInfo=cpi,..}]
-      _now <- liftIO getCurrentTime
+      | avsContactPersonID /= api -> throwM $ AvsIdMismatch api avsContactPersonID
-      let uid = error "CONTINUE HERE"
+      | otherwise -> do
-      Entity{entityKey=cid, entityVal=_} <- upsertAvsCompany avsContactFirmInfo Nothing
+        pinPass <- queryAvsPin api
-      let userComp = UserCompany uid cid False False 1 True -- default value for new company insertion, if no update can be done
+        runDB $ do
-      void $ insertUnique userComp
+          Entity{entityKey=cid, entityVal=cmp} <- upsertAvsCompany avsContactFirmInfo Nothing
-      return $ Just uid
+          -- _now <- liftIO getCurrentTime
+          let             
+              internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo
+              persMail  :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI
+              _newUser = AddUserData
+                { audTitle            = Nothing                
+                , audFirstName        = cpi ^. _avsInfoFirstName    & Text.strip
+                , audSurname          = cpi ^. _avsInfoLastName     & Text.strip
+                , audDisplayName      = cpi ^. _avsInfoDisplayName                
+                , audDisplayEmail     = persMail & fromMaybe mempty
+                , audEmail            = persMail & fromMaybe ("AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI)
+                , audIdent            = persMail & fromMaybe ("AVSID:" <> ciShow api )
+                , audAuth             = maybe AuthKindNoLogin (const AuthKindLDAP) internalPersNo
+                , audMatriculation    = cpi ^. _avsInfoPersonNo     & Just . tshow
+                , audSex              = Nothing
+                , audBirthday         = cpi ^. _avsInfoDateOfBirth
+                , audMobile           = cpi ^. _avsInfoPersonMobilePhoneNo 
+                , audTelephone        = Nothing
+                , audFPersonalNumber  = internalPersNo
+                , audFDepartment      = toMaybe (isJust internalPersNo) (cmp ^. _companyShorthand . _CI)                  
+                , audPostAddress      = Nothing -- use company address indirectly
+                , audPrefersPostal    = cmp ^. _companyPrefersPostal
+                , audPinPassword      = pinPass
+                }  
+
+          let uid = error "CONTINUE HERE"
+          
+          let userComp = UserCompany uid cid False False 1 True -- default value for new company insertion, if no update can be done
+          void $ insertUnique userComp
+          -- TODO: insert supervisors
+          -- TODO: add superior from firmInfo
+          return $ Just uid
       
 
 
@@ -662,7 +720,7 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
                   , companyAvsId          = newAvsFirmInfo ^. _avsFirmFirmNo
                   , companyPrefersPostal  = True
                   , companyPostAddress    = newAvsFirmInfo ^. _avsFirmPostAddress
-                  , companyEmail          = newAvsFirmInfo ^. _avsFirmPrimaryEmail . _Just . from _CI . re _Just
+                  , companyEmail          = newAvsFirmInfo ^? _avsFirmPrimaryEmail . _Just . from _CI
                   }
         newCmp <- insertEntity $ foldl' upd dmy firmInfo2company
         reportAdminProblem $ AdminProblemNewCompany $ entityKey newCmp
@@ -694,18 +752,18 @@ guessAvsUser (Text.splitAt 6 -> (Text.toUpper -> prefix, readMay -> Just nr))
       let avsid = AvsPersonId nr in 
       runDB (getBy $ UniqueUserAvsId avsid)          >>= \case
         (Just Entity{entityVal=UserAvs{userAvsUser=uid}}) -> return $ Just uid
-        Nothing -> maybeCatchAll $ upsertAvsUserById avsid  
+        Nothing -> catchAVS2message $ upsertAvsUserById avsid  
   | prefix=="AVSNO:" = 
       runDB (view (_entityVal . _userAvsUser) <<$>> getByFilter [UserAvsNoPerson ==. nr])
 guessAvsUser someid@(discernAvsCardPersonalNo -> Just someavsid) =  
-    maybeCatchAll $ upsertAvsUserByCard someavsid >>= \case
+    catchAVS2message $ upsertAvsUserByCard someavsid >>= \case
       Nothing | Left{} <- someavsid -> -- attempt to find PersonalNumber in DB
         runDB (getKeyByFilter [UserCompanyPersonalNumber ==. Just someid])
       other -> return other
 guessAvsUser someid = do 
     try (runDB $ ldapLookupAndUpsert someid) >>= \case
       Right Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}} -> -- ensure internal user is linked to avs, if possible
-        maybeCatchAll (upsertAvsUserByCard $ Left $ mkAvsInternalPersonalNo persNo) <&> \case
+        catchAVS2message (upsertAvsUserByCard $ Left $ mkAvsInternalPersonalNo persNo) <&> \case
           Nothing -> Just uid
           other   -> other
       Right Entity{entityKey=uid} -> return $ Just uid
@@ -746,7 +804,8 @@ upsertAvsUserById0 api = do
     []              -> createAvsUserById api
     [(api',uid)] 
       | api == api' -> return $ Just uid
-      | otherwise   -> error  $ "Handler.Utils.Avs.updateAvsUSerByIds returned unasked user with API " <> show api' <> " for queried API " <> show api <> "."
+      | otherwise   -> throwM $ AvsIdMismatch api api'         
+                       -- error  $ "Handler.Utils.Avs.updateAvsUSerByIds returned unasked user with AvsPersonId " <> show api' <> " for queried AvsPersonId " <> show api <> "."
     (_:_:_)         -> throwM $ AvsUserAmbiguous api
 
 
@@ -755,9 +814,12 @@ setLicence :: (PersistUniqueRead backend, MonadThrow m,
                      MonadHandler m, HandlerSite m ~ UniWorX,
                      BaseBackend backend ~ SqlBackend) =>
                     UserId -> AvsLicence -> ReaderT backend m Bool
-setLicence uid lic = do
+setLicence uid lic = 
-  Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnassociated uid) $ getBy $ UniqueUserAvsUser uid
+  getBy (UniqueUserAvsUser uid) >>= \case
-  setLicenceAvs userAvsPersonId lic
+    Just (Entity{entityVal=UserAvs{userAvsPersonId=api}}) -> setLicenceAvs api lic
+    Nothing -> do
+      uname <- userDisplayName <<$>> get uid      
+      throwM $ AvsUserUnassociated $ fromMaybe "user id unknown" uname
 
 setLicenceAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) =>
                   AvsPersonId -> AvsLicence -> m Bool

src/Model/Types/Avs.hs

@@ -417,6 +417,9 @@ getFullCardNo AvsDataPersonCard{avsDataCardNo, avsDataVersionNo} = AvsFullCardNo
 personCard2pin :: AvsDataPersonCard -> Text
 personCard2pin = Text.dropWhile ('0'==) . tshowAvsFullCardNo . getFullCardNo
 
+personCards2pin :: Set AvsDataPersonCard -> Maybe Text
+personCards2pin = fmap personCard2pin . Set.lookupMax
+
 data AvsStatusPerson = AvsStatusPerson
       { avsStatusPersonID         :: AvsPersonId
       , avsStatusPersonCardStatus :: Set AvsDataPersonCard -- only delivers non-Maybe fields, all Maybe-fields are Nothing

src/Utils.hs

@@ -314,6 +314,9 @@ stripFold = Text.toCaseFold . Text.strip
 ciOriginal :: CI Text -> Text 
 ciOriginal = CI.original
 
+ciShow :: Show a => a -> CI Text
+ciShow = CI.mk . tshow
+
 citext2lower :: CI Text -> Text 
 citext2lower = Text.toLower . CI.original
 

src/Utils/Users.hs

@@ -49,10 +49,11 @@ data AddUserData = AddUserData
   , audPinPassword      :: Maybe Text
   , audEmail            :: UserEmail
   , audIdent            :: UserIdent
-  , audAuth             :: AuthenticationKind  
+  , audAuth             :: AuthenticationKind
   }
 
 -- | Adds a new user to database, no background jobs are scheduled, no notifications send
+-- Note:  Foundation.Yesod.Auth contains similar code with potentially differing defaults!
 addNewUser :: AddUserData -> Handler (Maybe UserId)
 addNewUser AddUserData{..} = do 
   now <- liftIO getCurrentTime