chore(avs): upsert avs user continued (WIP)

src/Foundation/Types.hs

@@ -14,7 +14,7 @@ import Import.NoFoundation
 data UpsertCampusUserMode
   = UpsertCampusUserLoginLdap
   | UpsertCampusUserLoginDummy { upsertCampusUserIdent :: UserIdent }
-  | UpsertCampusUserLoginOther { upsertCampusUserIdent :: UserIdent }
+  | UpsertCampusUserLoginOther { upsertCampusUserIdent :: UserIdent } -- erlaubt keinen späteren Login
   | UpsertCampusUserLdapSync   { upsertCampusUserIdent :: UserIdent }
   | UpsertCampusUserGuessUser
   deriving (Eq, Ord, Read, Show, Generic, Typeable)

src/Handler/Users/Add.hs

@@ -4,8 +4,9 @@
 
 module Handler.Users.Add
   ( getAdminUserAddR, postAdminUserAddR
-  , AdminUserForm(..), adminUserForm                    -- no longer needed elsewhere
+  , AdminUserForm(..), AuthenticationKind(..)
-  -- , AuthenticationKind(..), classifyAuth, mkAuthMode -- no longer needed elsewhere   
+  , addNewUser
+  --, adminUserForm , classifyAuth, mkAuthMode -- no longer needed elsewhere   
   ) where
 
 
@@ -74,66 +75,64 @@ adminUserForm template = renderAForm FormStandard
   <*> areq (textField & cfStrip & cfCI) (fslI MsgAdminUserIdent) (aufIdent <$> template)
   <*> areq (selectField optionsFinite)  (fslI MsgAdminUserAuth) (aufAuth <$> template <|> Just AuthKindLDAP)
   
+addNewUser :: AdminUserForm -> Handler (Maybe UserId)
+addNewUser AdminUserForm{..} = do 
+  now <- liftIO getCurrentTime
+  UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
+  let 
+    newUser = User
+      { userIdent                   = aufIdent
+      , userMaxFavourites           = userDefaultMaxFavourites
+      , userMaxFavouriteTerms       = userDefaultMaxFavouriteTerms
+      , userTheme                   = userDefaultTheme
+      , userDateTimeFormat          = userDefaultDateTimeFormat
+      , userDateFormat              = userDefaultDateFormat
+      , userTimeFormat              = userDefaultTimeFormat
+      , userDownloadFiles           = userDefaultDownloadFiles
+      , userWarningDays             = userDefaultWarningDays
+      , userShowSex                 = userDefaultShowSex
+      , userExamOfficeGetSynced     = userDefaultExamOfficeGetSynced
+      , userExamOfficeGetLabels     = userDefaultExamOfficeGetLabels
+      , userNotificationSettings    = def
+      , userLanguages               = Nothing
+      , userCsvOptions              = def
+      , userTokensIssuedAfter       = Nothing
+      , userCreated                 = now
+      , userLastLdapSynchronisation = Nothing
+      , userLdapPrimaryKey          = aufFPersonalNumber
+      , userLastAuthentication      = Nothing
+      , userEmail                   = aufEmail
+      , userDisplayName             = aufDisplayName
+      , userDisplayEmail            = aufDisplayEmail
+      , userFirstName               = aufFirstName
+      , userSurname                 = aufSurname
+      , userTitle                   = aufTitle
+      , userSex                     = aufSex        
+      , userMobile                  = aufMobile
+      , userTelephone               = aufTelephone
+      , userCompanyPersonalNumber   = aufFPersonalNumber
+      , userCompanyDepartment       = aufFDepartment    
+      , userPostAddress             = aufPostAddress
+      , userPrefersPostal           = aufPrefersPostal
+      , userPinPassword             = aufPinPassword
+      , userMatrikelnummer          = aufMatriculation
+      , userAuthentication          = mkAuthMode aufAuth
+      }
+  runDBJobs . runMaybeT $ do
+    uid <- MaybeT $ insertUnique newUser
+    lift . queueDBJob $ JobSynchroniseLdapUser uid
+    lift . queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid (newUser ^. _userAuthentication)
+    when (aufAuth == AuthKindPWHash) $
+      lift . queueDBJob $ JobSendPasswordReset uid
+    return uid
+
 
 getAdminUserAddR, postAdminUserAddR :: Handler Html
 getAdminUserAddR = postAdminUserAddR
 postAdminUserAddR = do
   ((userRes, userView), userEnctype) <- runFormPost $ adminUserForm Nothing
-
+  formResult userRes $ addNewUser >=> \case
-  formResult userRes $ \AdminUserForm{..} -> do
+      (Just uid) -> do
-    now <- liftIO getCurrentTime
-    UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
-
-    let
-      newUser@User{..} = User
-        { userIdent                   = aufIdent
-        , userMaxFavourites           = userDefaultMaxFavourites
-        , userMaxFavouriteTerms       = userDefaultMaxFavouriteTerms
-        , userTheme                   = userDefaultTheme
-        , userDateTimeFormat          = userDefaultDateTimeFormat
-        , userDateFormat              = userDefaultDateFormat
-        , userTimeFormat              = userDefaultTimeFormat
-        , userDownloadFiles           = userDefaultDownloadFiles
-        , userWarningDays             = userDefaultWarningDays
-        , userShowSex                 = userDefaultShowSex
-        , userExamOfficeGetSynced     = userDefaultExamOfficeGetSynced
-        , userExamOfficeGetLabels     = userDefaultExamOfficeGetLabels
-        , userNotificationSettings    = def
-        , userLanguages               = Nothing
-        , userCsvOptions              = def
-        , userTokensIssuedAfter       = Nothing
-        , userCreated                 = now
-        , userLastLdapSynchronisation = Nothing
-        , userLdapPrimaryKey          = Nothing
-        , userLastAuthentication      = Nothing
-        , userEmail                   = aufEmail
-        , userDisplayName             = aufDisplayName
-        , userDisplayEmail            = aufDisplayEmail
-        , userFirstName               = aufFirstName
-        , userSurname                 = aufSurname
-        , userTitle                   = aufTitle
-        , userSex                     = aufSex        
-        , userMobile                  = aufMobile
-        , userTelephone               = aufTelephone
-        , userCompanyPersonalNumber   = aufFPersonalNumber
-        , userCompanyDepartment       = aufFDepartment    
-        , userPostAddress             = aufPostAddress
-        , userPrefersPostal           = aufPrefersPostal
-        , userPinPassword             = aufPinPassword
-        , userMatrikelnummer          = aufMatriculation
-        , userAuthentication          = mkAuthMode aufAuth
-        }
-
-    didInsert <- runDBJobs . runMaybeT $ do
-      uid <- MaybeT $ insertUnique newUser
-      lift . queueDBJob $ JobSynchroniseLdapUser uid
-      lift . queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid userAuthentication
-      when (aufAuth == AuthKindPWHash) $
-        lift . queueDBJob $ JobSendPasswordReset uid
-      return uid
-
-    case didInsert of
-      Just uid -> do
         addMessageI Success MsgUserAdded
         cID <- encrypt uid
         redirect $ AdminUserR cID

src/Handler/Utils/Avs.hs

@@ -21,7 +21,11 @@ import Utils.Avs
 
 import qualified Data.Set           as Set
 import qualified Data.Map           as Map
--- import qualified Data.Text          as Text
+import qualified Data.Text.Encoding as Text
+
+import qualified Data.CaseInsensitive as CI
+import Auth.LDAP (ldapUserPrincipalName)
+import Foundation.Yesod.Auth (upsertCampusUser,CampusUserConversionException())
 
 import Handler.Users.Add
 
@@ -34,8 +38,10 @@ 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
   | AvsUserUnknownByAvs AvsPersonId     -- AvsPersionId not (or no longer) found in AVS DB
+  | AvsUserAmbiguous                    -- Multiple matching existing users found in our DB
   | AvsPersonSearchEmpty                -- AvsPersonSearch returned empty result 
   | AvsPersonSearchAmbiguous            -- AvsPersonSearch returned more than one result 
+  
   deriving (Show, Generic, Typeable)
 instance Exception AvsException
 
@@ -118,14 +124,30 @@ or
 -- | Retrieve and _always_ update user by AvsPersonId. Non-existing users are created.
 --   Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB (should never happen).
 upsertAvsUser :: AvsPersonId -> Handler (Maybe UserId)
-upsertAvsUser api = do
+upsertAvsUser api = do  
-  mbuid <- runDB $ getBy $ UniqueUserAvsId api 
   mbapd <- lookupAvsUser api
+  mbuid <- runDB $ do 
+    mbuid <- getBy (UniqueUserAvsId api)
+    case (mbuid, mbapd) of
+      (Nothing, Just AvsDataPerson{..})                         -- FRADriver User does not exist yet, but found in AVS and has Internal Personal Number
+        | Just persNo <- avsPersonInternalPersonalNo -> do 
+            candidates <- selectKeysList [UserCompanyPersonalNumber ==. avsPersonInternalPersonalNo] []
+            case candidates of
+              [uid] -> insertUniqueEntity $ UserAvs api uid
+              (_:_) -> throwM AvsUserAmbiguous
+              [] -> do
+                upsRes :: Either CampusUserConversionException (Entity User) <- try $ upsertCampusUser UpsertCampusUserGuessUser [(ldapUserPrincipalName,[Text.encodeUtf8 persNo])]
+                case upsRes of 
+                  Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid
+                  _other -> return mbuid -- ==Nothing -- user could not be created somehow
+      _other -> return mbuid
   case (mbuid, mbapd) of
-    ( _     , Nothing)    -> throwM $ AvsUserUnknownByAvs api -- this should never happen
+    ( _     , Nothing               ) -> throwM $ AvsUserUnknownByAvs api -- User not found in AVS at all, i.e. no valid card exists yet
-    (Nothing, Just AvsDataPerson{..})   -> do   -- unknown user, must be created
+    (Nothing, Just AvsDataPerson{..}) -> do                               -- No LDAP User, but found in AVS; create user
-      -- if | Just ipn <- avsPersonInternalPersonalNo -> TODO?
+      let firmAddress = mergeFirmAddress <$> guessLicenceAddress avsPersonPersonCards
-      let _newUsr = AdminUserForm 
+          bestCard    = Set.lookupMax avsPersonPersonCards
+          fakeIdent   = CI.mk $ tshow api
+          newUsr = AdminUserForm 
             { aufTitle     = Nothing
             , aufFirstName = avsPersonFirstName
             , aufSurname   = avsPersonLastName
@@ -137,17 +159,18 @@ upsertAvsUser api = do
             , aufTelephone = Nothing
             , aufFPersonalNumber = avsPersonInternalPersonalNo
             , aufFDepartment = Nothing
-            , aufPostAddress = error "TODO" -- CONTINUE HERE
+            , aufPostAddress = plaintextToStoredMarkup <$> firmAddress
-            , aufPrefersPostal = error "TODO" -- CONTINUE HERE
+            , aufPrefersPostal = isJust firmAddress
-            , aufPinPassword = error "TODO" -- CONTINUE HERE
+            , aufPinPassword = getFullCardNo <$> bestCard
-            , aufEmail = "" 
+            , aufEmail = fakeIdent -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO)
-            , aufIdent = error "TODO" -- CONTINUE HERE
+            , aufIdent = fakeIdent -- use AvsPersonId instead
-            , aufAuth  = error "TODO" -- CONTINUE HERE AuthKindNoLogin or AuthKindLDAP if ldap search worked 
+            , aufAuth  = maybe AuthKindNoLogin (const AuthKindLDAP) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personal number is known
             }
+      _ <- addNewUser newUsr
           -- _newAvs = UserAvs avsPersonPersonID uid
           -- _newAvsCards = UserAvsCard 
-      error "TODO" -- CONTINUE HERE
+      error "TODO" -- CONTINUE HERE    
-    (Just _uid, Just _apd)  -> do   -- known user 
+    (Just (Entity _ UserAvs{}), Just AvsDataPerson{}) -> -- known user, do some updates 
       error "TODO" -- CONTINUE HERE
 
 

src/Model/Types/Avs.hs

@@ -80,7 +80,7 @@ instance FromJSON SloppyBool where
 -- AVS Datatypes --
 -------------------
 
-type AvsInternalPersonalNo = Text -- type synonym for claritty/documentation within types
+type AvsInternalPersonalNo = Text -- type synonym for clarity/documentation within types
 
 -- CompleteCardNo = xxxxxxxx.y 
 -- where x is an 8 digit AvsCardNo prefixed by zeros 
@@ -246,6 +246,8 @@ instance ToJSON AvsDataPersonCard where
     ]
 derivePersistFieldJSON ''AvsDataPersonCard
 
+getFullCardNo :: AvsDataPersonCard -> Text
+getFullCardNo AvsDataPersonCard{avsDataCardNo, avsDataVersionNo} = avsCardNo avsDataCardNo <> Text.cons '.' avsDataVersionNo
 
 data AvsStatusPerson = AvsStatusPerson
       { avsStatusPersonID         :: AvsPersonId

src/Utils/Avs.hs

@@ -87,16 +87,21 @@ getValidLicence cutoff licence' cards = Set.lookupMax validLicenceCards
     cardMatch AvsDataPersonCard{..} =
       avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas)
 
-guessLicenceAddress :: Set AvsDataPersonCard -> Maybe (Maybe Text, Text)
+guessLicenceAddress :: Set AvsDataPersonCard -> Maybe (Maybe Text, Text, AvsDataPersonCard)
 guessLicenceAddress cards
   | Just c <- Set.lookupMax cards
-  , AvsDataPersonCard{..} <- Set.foldr pickLicenceAddress c cards
+  , card@AvsDataPersonCard{..} <- Set.foldr pickLicenceAddress c cards
   , Just street <- avsDataStreet
   , Just pcode  <- avsDataPostalCode
   , Just city   <- avsDataCity
-    = Just (avsDataFirm, Text.unlines [street, Text.unwords [pcode, city]])
+    = Just (avsDataFirm, Text.unlines [street, Text.unwords [pcode, city]], card)
   | otherwise = Nothing
 
+-- | Helper for guessLicenceAddress
+mergeFirmAddress :: (Maybe Text, Text, a) -> Text
+mergeFirmAddress (Nothing  , addr, _) = addr
+mergeFirmAddress (Just firm, addr, _) = firm <> Text.cons '\n' addr
+
 hasAddress :: AvsDataPersonCard -> Bool
 hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity && isJust avsDataPostalCode