chore(avs): upsertAvsUserById completed

models/users.model

@@ -84,10 +84,10 @@ UserGroupMember
     UniqueUserGroupMember group user
     deriving Generic
 UserCompany 
-    company               CompanyId 
     user                  UserId  
-    supervisor            Bool       -- is this user a company supervisor?
+    company               CompanyId     
-    UniqueCompanyUser company user
+    supervisor            Bool       -- is this user a company supervisor?    
+    UniqueUserCompany user -- only one company per user is currently allowed
     deriving Generic
 UserSupervisor
     supervisor            UserId -- multiple supervisor per trainee possible

src/Handler/Profile.hs

@@ -1023,7 +1023,7 @@ mkQualificationsTable =
       , dbtProj      = dbtProjId 
       , dbtColonnade = mconcat
           [ colSchool (_dbrOutput . _1 . _entityVal . _qualificationSchool)
-          , sortable (Just "quali")         (i18nCell MsgQualificationName)             $ qualificationCell         <$> view (_dbrOutput . _1 . _entityVal)
+          , sortable (Just "quali")         (i18nCell MsgQualificationName)             $ qualificationDescrCell         <$> view (_dbrOutput . _1 . _entityVal)
           , sortable (Just "blocked-due")   (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip
                                                                                      )  $ qualificationBlockedCell  <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserBlockedDue )
           , sortable (Just "valid-until")   (i18nCell MsgLmsQualificationValidUntil)    $ dayCell                   <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserValidUntil )

src/Handler/Utils/Avs.hs

@@ -117,12 +117,8 @@ checkLicences = do
 
 
 upsertAvsUser :: Text -> Handler (Maybe UserId)
--- upsertAvsUser (readAvsFullCardNo -> Just afcn) = upsertAvsUserByCard afcn
+upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = upsertAvsUserByCard someid    -- Note: Right case is a number, it could be AvsPersonId or AvsInternalPersonalNumber; we cannot know, but the latter is much more likely and useful to users!
--- upsertAvsUser someid 
+upsertAvsUser _other = return Nothing -- TODO: attempt LDAP lookup to find by eMail; merely for convenience, not necessary right now
--- | Just avsid <- discernAvsIds someid 
--- = upsertAvsUserByCard $ over _Right (const someid) avsid -- Note: Right case is a number, it could be AvsPersonId or AvsInternalPersonalNumber; we cannot discern, but the latter is much more likely and useful!
-upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = upsertAvsUserByCard someid
-upsertAvsUser _other = return Nothing -- TODO: attempt LDAP lookup to find by eMail; merely for convenience, not necessary now
   {- maybe this code helps?
   upsRes :: Either CampusUserConversionException (Entity User)
     <- try $ upsertCampusUserByOther persNo
@@ -132,7 +128,27 @@ upsertAvsUser _other = return Nothing -- TODO: attempt LDAP lookup to find by eM
   -}
 
 
--- | Retrieve and _always_ update user by AvsPersonId. Non-existing users are created.
+-- | 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 :: Either AvsFullCardNo AvsInternalPersonalNo -> Handler (Maybe UserId) -- Idee: Eingabe ohne Punkt is AvsInternalPersonalNo mit Punkt is Ausweisnummer?!
+upsertAvsUserByCard persNo = do
+  let qry = case persNo of
+              Left AvsFullCardNo{..} -> def{ avsPersonQueryCardNo = Just avsFullCardNo, avsPersonQueryVersionNo = Just avsFullCardVersion }
+              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 -> upsertAvsUserById appi
+
+
+
+-- | Retrieve and _always_ update user by AvsPersonId. Non-existing users are created. Ignore AVS Licence status! Updates Company, Address, PinPassword
 --   Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB (should never happen).
 upsertAvsUserById :: AvsPersonId -> Handler (Maybe UserId)
 upsertAvsUserById api = do
@@ -150,16 +166,19 @@ upsertAvsUserById api = do
                 upsRes :: Either CampusUserConversionException (Entity User)
                   <- try $ upsertCampusUserByCn persNo
                 case upsRes of
-                  Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid
+                  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
       _other -> return mbuid
   case (mbuid, mbapd) of
     ( _     , Nothing               ) -> throwM $ AvsUserUnknownByAvs api -- User not found in AVS at all, i.e. no valid card exists yet
-    (Nothing, Just AvsDataPerson{..}) -> do                               -- No LDAP User, but found in AVS; create user
+    (Nothing, Just AvsDataPerson{..}) -> do                               -- No LDAP User, but found in AVS; create new user
       let firmAddress = guessLicenceAddress avsPersonPersonCards
           mbCompany   = firmAddress ^? _Just . _1 . _Just
-          bestCard    = Set.lookupMax avsPersonPersonCards
+          userFirmAddr= plaintextToStoredMarkup . mergeCompanyAddress <$> firmAddress
-          fakeIdent   = CI.mk $ tshow api
+          addrCard    = firmAddress ^? _Just . _3 
+          pinCard     = Set.lookupMax avsPersonPersonCards
+          userPin     = tshowAvsFullCardNo . getFullCardNo <$> pinCard          
+          fakeIdent   = CI.mk $ "AVSID:" <> tshow api
           newUsr = AdminUserForm
             { aufTitle     = Nothing
             , aufFirstName = avsPersonFirstName
@@ -172,53 +191,60 @@ upsertAvsUserById api = do
             , aufTelephone = Nothing
             , aufFPersonalNumber = avsPersonInternalPersonalNo
             , aufFDepartment = Nothing
-            , aufPostAddress = plaintextToStoredMarkup . mergeCompanyAddress <$> firmAddress
+            , aufPostAddress = userFirmAddr
             , aufPrefersPostal = isJust firmAddress
-            , aufPinPassword = tshowAvsFullCardNo . getFullCardNo <$> bestCard
+            , aufPinPassword = userPin
             , aufEmail = fakeIdent -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO)
             , aufIdent = fakeIdent -- use AvsPersonId instead
             , aufAuth  = maybe AuthKindNoLogin (const AuthKindLDAP) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personal number is known
             }
       mbUid <- addNewUser newUsr -- triggers JobSynchroniseLdapUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe      
-      case mbUid of 
+      whenIsJust mbUid $ \uid -> runDB $ do 
-        Just uid -> runDB $ do
+        now <- liftIO getCurrentTime
-          now <- liftIO getCurrentTime
+        insert_ $ UserAvs avsPersonPersonID uid
-          insert_ $ UserAvs avsPersonPersonID uid
+        -- forM_ avsPersonPersonCards $ -- save all cards for later
-          -- forM_ avsPersonPersonCards $ -- save all cards for later           
+        let cs :: Set AvsDataPersonCard = Set.fromList $ catMaybes [pinCard, addrCard]
-          forM_ bestCard $  -- only save the card used to the postal address
+        forM_ cs $  -- only save used cards for the postal address update detection
-             \avsCard -> insert_ $ UserAvsCard avsPersonPersonID (avsDataCardNo avsCard) avsCard now 
+            \avsCard -> insert_ $ UserAvsCard avsPersonPersonID (avsDataCardNo avsCard) avsCard now 
-          case mbCompany of
+        upsertUserCompany uid mbCompany                    
-            Just cpy -> do
-              cid <- upsertCompany cpy
-              insert_ $ UserCompany cid uid False
-            _ -> return ()
-        _ -> return ()      
       return mbUid
-
+    
-    (Just (Entity _ UserAvs{}), Just AvsDataPerson{}) -> -- known user, do some updates
+    (Just (Entity _ UserAvs{userAvsUser=uid}), Just AvsDataPerson{avsPersonPersonCards}) -> do -- known user, update address and pinPassword
-      error "TODO" -- CONTINUE HERE
+      let firmAddress = guessLicenceAddress avsPersonPersonCards
+          mbCompany   = firmAddress ^? _Just . _1 . _Just
+          userFirmAddr= plaintextToStoredMarkup . mergeCompanyAddress <$> firmAddress
+          addrCard    = firmAddress ^? _Just . _3 
+          pinCard     = Set.lookupMax avsPersonPersonCards
+          userPin     = tshowAvsFullCardNo . getFullCardNo <$> pinCard          
+      runDB $ do 
+        now <- liftIO getCurrentTime        
+        upsertUserCompany uid mbCompany
+        whenIsJust addrCard $ \aCard ->
+          getBy (UniqueAvsCard $ avsDataCardNo aCard) >>= \case
+            (Just (Entity uac UserAvsCard{..})) | aCard == userAvsCardCard -> -- address seen before, no change
+              update uac [UserAvsCardLastSynch =. now]
+            _ -> do -- possibly new address data 
+              void $ upsert UserAvsCard
+                      { userAvsCardPersonId = api
+                      , userAvsCardCardNo   = avsDataCardNo aCard
+                      , userAvsCardCard     = aCard
+                      , userAvsCardLastSynch= now
+                      }
+                      [ UserAvsCardCard      =. aCard
+                      , UserAvsCardLastSynch =. now
+                      ]            
+              when (isJust userFirmAddr) $ updateWhere [UserId ==. uid] [UserPostAddress =. userFirmAddr]
+        whenIsJust pinCard $ \pCard -> 
+          unlessM (exists [UserAvsCardCardNo ==. avsDataCardNo pCard]) $ do 
+            -- update pin, but only if it was unset or set to the value of an old card
+            oldCards <- selectList [UserAvsCardPersonId ==. api] []
+            let oldPins = Just . tshowAvsFullCardNo . getFullCardNo . userAvsCardCard . entityVal <$> oldCards
+            updateWhere [UserId ==. uid, UserPinPassword !=. userPin, UserPinPassword <-. Nothing:oldPins]
+                        [UserPinPassword =. userPin]
+            insert_ $ UserAvsCard api (avsDataCardNo pCard) pCard now
+      return $ Just uid
 
 
--- | 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 AvsFullCardNo AvsInternalPersonalNo -> Handler (Maybe UserId) -- Idee: Eingabe ohne Punkt is AvsInternalPersonalNo mit Punkt is Ausweisnummer?!
-upsertAvsUserByCard persNo = do
-  let qry = case persNo of
-              Left AvsFullCardNo{..} -> def{ avsPersonQueryCardNo = Just avsFullCardNo, avsPersonQueryVersionNo = Just avsFullCardVersion }
-              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 -> upsertAvsUserById appi
 
 
 

src/Handler/Utils/Company.hs

@@ -13,6 +13,15 @@ import qualified Data.Char as Char
 import qualified Data.Text as Text
 
 
+-- | Ensure that the given user is linked to the given company
+upsertUserCompany :: UserId -> Maybe Text -> DB ()
+upsertUserCompany uid (Just cName) | notNull cName = do 
+  cid <- upsertCompany cName
+  void $ upsertBy (UniqueUserCompany uid) 
+                  (UserCompany uid cid False) 
+                  [UserCompanyCompany =. cid, UserCompanySupervisor =. False]  
+upsertUserCompany uid _ = deleteBy (UniqueUserCompany uid) 
+
 upsertCompany :: Text -> DB CompanyId
 upsertCompany cName = 
   let cName' = CI.mk cName in

src/Handler/Utils/Table/Cells.hs

@@ -272,10 +272,14 @@ courseCell Course{..} = anchorCell link name `mappend` desc
               |]
 
 qualificationCell :: IsDBTable m a => Qualification -> DBCell m a
-qualificationCell Qualification{..} = anchorCell link name <> desc
+qualificationCell Qualification{..} = anchorCell link name
   where
     link = QualificationR qualificationSchool qualificationShorthand
     name = citext2widget qualificationName
+
+qualificationDescrCell :: IsDBTable m a => Qualification -> DBCell m a
+qualificationDescrCell q@Qualification{..} = qualificationCell q <> desc
+  where
     desc = case qualificationDescription of
             Nothing      -> mempty
             (Just descr) -> spacerCell <> markupCellLargeModal descr

src/Handler/Utils/Users.hs

@@ -910,12 +910,12 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
 
   -- Companies, in conflict, keep the newUser-Company as is
   E.insertSelectWithConflict
-    UniqueCompanyUser
+    UniqueUserCompany
     (E.from $ \userCompany -> do 
       E.where_ $ userCompany E.^. UserCompanyUser E.==. E.val oldUserId
       return $ UserCompany 
-        E.<#  (userCompany E.^. UserCompanyCompany)
+        E.<#  E.val newUserId
-        E.<&> E.val newUserId
+        E.<&> (userCompany E.^. UserCompanyCompany)
         E.<&> (userCompany E.^. UserCompanySupervisor)
     )
     (\current _excluded -> [ UserCompanySupervisor E.=. (current E.^. UserCompanySupervisor)] )

src/Utils.hs

@@ -623,7 +623,8 @@ mTuple = liftA2 (,)
 -- Lists --
 -----------
 
--- notNull = not . null
+notNull :: MonoFoldable mono => mono -> Bool
+notNull = not . null
 
 headDef :: a -> [a] -> a 
 headDef _ (h:_) = h

test/Database/Fill.hs

@@ -113,7 +113,7 @@ fillDb = do
     , userShowSex = userDefaultShowSex
     , userTelephone = Nothing
     , userMobile = Nothing
-    , userCompanyPersonalNumber = Nothing
+    , userCompanyPersonalNumber = Just "00000"
     , userCompanyDepartment = Nothing
     , userPinPassword = Nothing
     , userPostAddress = Nothing
@@ -271,7 +271,7 @@ fillDb = do
     , userShowSex = userDefaultShowSex
     , userTelephone = Nothing
     , userMobile = Nothing
-    , userCompanyPersonalNumber = Nothing
+    , userCompanyPersonalNumber = Just "12345"
     , userCompanyDepartment = Nothing
     , userPinPassword = Nothing
     , userPostAddress = Nothing