refactor(avs): rework createAvsUserById, dealing with supervision (WIP)
This commit is contained in:
parent
a373abad26
commit
cb2778e206
@ -33,8 +33,6 @@ import Import
|
||||
-- import Handler.Utils
|
||||
-- import qualified Database.Esqueleto.Legacy as E
|
||||
|
||||
import Utils.Avs
|
||||
-- import Utils.Users
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
@ -46,7 +44,7 @@ import qualified Control.Monad.Catch as Catch
|
||||
-- import Auth.LDAP (ldapUserPrincipalName)
|
||||
import Foundation.Yesod.Auth (ldapLookupAndUpsert) -- , CampusUserConversionException())
|
||||
|
||||
|
||||
import Utils.Avs
|
||||
import Utils.Mail (pickValidEmail)
|
||||
import Utils.Users
|
||||
import Handler.Utils.Users
|
||||
@ -59,7 +57,7 @@ import Database.Persist.Sql (deleteWhereCount) --, updateWhereCount)
|
||||
import Database.Esqueleto.Experimental ((:&)(..))
|
||||
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import qualified Database.Esqueleto.PostgreSQL as E
|
||||
-- import qualified Database.Esqueleto.PostgreSQL as E
|
||||
|
||||
import Servant.Client.Core.ClientError (ClientError)
|
||||
|
||||
@ -78,6 +76,7 @@ data AvsException
|
||||
| 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
|
||||
-- | AvsUserCreationFailed
|
||||
deriving (Show, Eq, Ord, Generic)
|
||||
instance Exception AvsException
|
||||
embedRenderMessage ''UniWorX ''AvsException id -- display as feedback for user initiated actions -- moved to Foundation.I18n
|
||||
@ -428,21 +427,17 @@ queryAvsCardNo crd = do
|
||||
, avsPersonQueryVersionNo = Just avsFullCardVersion
|
||||
}
|
||||
|
||||
-- | Queries AVS Status to retrieve primary card
|
||||
-- | Queries AVS Status to retrieve primary card (heursitic)
|
||||
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 CardNo from primary card (heursitic)
|
||||
queryAvsFullCardNo :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => AvsPersonId -> m (Maybe AvsFullCardNo)
|
||||
queryAvsFullCardNo = fmap (fmap getFullCardNo) . queryAvsPrimaryCard
|
||||
|
||||
-- | 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
|
||||
where
|
||||
@ -477,7 +472,6 @@ _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
|
||||
@ -509,15 +503,6 @@ updateRecord dbv inp (CheckAvsUpdate up l) =
|
||||
lensRec = fieldLensVal up
|
||||
in dbv & lensRec .~ newval
|
||||
|
||||
{-
|
||||
filterExisting :: (MonoFoldable mono, AvsPersonId ~ Element mono) => mono -> DB [AvsPersonId]
|
||||
filterExisting apids = fmap E.unValue <<$>>
|
||||
E.select $ do
|
||||
usrAvs <- E.from $ E.table @UserAvs
|
||||
E.where_ $ usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids
|
||||
return $ usrAvs E.^. UserAvsPersonId
|
||||
-}
|
||||
|
||||
-- | Update given AvsPersonId by querying AVS for each; update only, no insertion! Uses batch mechanism.
|
||||
updateAvsUserByIds :: Set AvsPersonId -> DB (Set (AvsPersonId, UserId))
|
||||
updateAvsUserByIds apids0 = do
|
||||
@ -536,11 +521,11 @@ updateAvsUserByIds apids0 = do
|
||||
let usrId = userAvsUser usravs
|
||||
usr <- MaybeT $ get usrId
|
||||
lift $ do -- maybeT no longer needed from here onwards
|
||||
newAvsCardNo <- queryAvsFullCardNo apid -- We must not abort entire synch when receiving `Nothing` here, hence no MaybeT here
|
||||
newAvsCardNo <- queryAvsFullCardNo apid -- Nothing os ok here
|
||||
now <- liftIO getCurrentTime
|
||||
let oldAvsPersonInfo = userAvsLastPersonInfo usravs -- We must not abort entire synch when receiving `Nothing` here, hence no hoistMaybe here
|
||||
oldAvsFirmInfo = userAvsLastFirmInfo usravs -- We must not abort entire synch when receiving `Nothing` here, hence no hoistMaybe here
|
||||
oldAvsCardNo = userAvsLastCardNo usravs -- We must not abort entire synch when receiving `Nothing` here, hence no hoistMaybe here
|
||||
let oldAvsPersonInfo = userAvsLastPersonInfo usravs -- Nothing is ok here
|
||||
oldAvsFirmInfo = userAvsLastFirmInfo usravs -- Nothing is ok here
|
||||
oldAvsCardNo = userAvsLastCardNo usravs & fmap Just
|
||||
per_ups = mapMaybe (mkUpdate usr newAvsPersonInfo oldAvsPersonInfo) -- NOTE: Updates erfolgen nur, wenn der Alt-Wert identisch zu Aktuellem-Wert sind! Bei mehreren Update-Möglichkeiten für ein Feld kann nur eines zutreffen.
|
||||
[ CheckAvsUpdate UserFirstName _avsInfoFirstName
|
||||
, CheckAvsUpdate UserSurname _avsInfoLastName
|
||||
@ -557,7 +542,7 @@ updateAvsUserByIds apids0 = do
|
||||
eml_up = em_p_up <|> em_f_up -- ensure that only one email update is produced; there is no Eq instance for the Update type
|
||||
frm_up = mkUpdate usr newAvsFirmInfo oldAvsFirmInfo $ -- Legacy, if company postal is stored in user; should no longer be true for new users,
|
||||
CheckAvsUpdate UserPostAddress _avsFirmPostAddress -- since company address should now be referenced with UserCompany instead
|
||||
pin_up = mkUpdate usr newAvsCardNo (Just oldAvsCardNo) $ -- Maybe update PDF pin to latest card
|
||||
pin_up = mkUpdate usr newAvsCardNo oldAvsCardNo $ -- Maybe update PDF pin to latest card
|
||||
CheckAvsUpdate UserPinPassword $ to $ fmap avsFullCardNo2pin -- _Just . to avsFullCardNo2pin . re _Just
|
||||
usr_up1 = eml_up `mcons` (frm_up `mcons` (pin_up `mcons` per_ups))
|
||||
avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons`
|
||||
@ -617,88 +602,87 @@ updateAvsUserByIds apids0 = do
|
||||
void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds
|
||||
-- adjust supervison
|
||||
oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef]
|
||||
E.insertSelectWithConflict
|
||||
UniqueUserSupervisor
|
||||
( do
|
||||
userCompany <- E.from $ E.table @UserCompany
|
||||
E.where_ $ userCompany E.^. UserCompanyCompany E.==. E.val newCompanyId
|
||||
E.&&. userCompany E.^. UserCompanySupervisor
|
||||
return $ UserSupervisor
|
||||
E.<# (userCompany E.^. UserCompanyUser)
|
||||
E.<&> E.val usrId
|
||||
E.<&> (userCompany E.^. UserCompanySupervisorReroute)
|
||||
E.<&> E.justVal newCompanyId
|
||||
E.<&> E.justVal superReasonComDef
|
||||
)
|
||||
(\current excluded -> -- Supervision between chosen individuals exists already; keep old reason and company, if exists
|
||||
[ UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany] -- do we want this? Ok, since we delete unconditionally first?!
|
||||
, UserSupervisorReason E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason ]
|
||||
]
|
||||
)
|
||||
addCompanySupervisors newCompanyId usrId
|
||||
newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
|
||||
when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
|
||||
return pst_up
|
||||
-- ensure firmInfo superior is at least normal supervisor, must be executed after updating company default supervisors
|
||||
whenIsJust (newAvsFirmInfo ^. _avsFirmEMailSuperior) $ \supemail -> forMM_
|
||||
(altM (guessUserByEmail $ supemail ^. from _CI)
|
||||
(maybeCatchAll $ Just . entityKey <$> ldapLookupAndUpsert supemail)
|
||||
) $ \supid -> do
|
||||
let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
|
||||
deleteWhere [UserSupervisorUser ==.usrId, UserSupervisorSupervisor !=. supid, UserSupervisorReason ==. reasonSuperior]
|
||||
void $ insertUnique $ UserSupervisor supid usrId False (Just newCompanyId) reasonSuperior
|
||||
-- update stored avsinfo
|
||||
update usrId $ usr_up2 `mcons` usr_up1
|
||||
update uaId avs_ups
|
||||
repsertSuperiorSupervisor (Just newCompanyId) newAvsFirmInfo usrId -- ensure firmInfo superior is at least normal supervisor, must be executed after updating company default supervisors
|
||||
update usrId $ usr_up2 `mcons` usr_up1 -- update user eventually
|
||||
update uaId avs_ups -- update stored avsinfo for future updates
|
||||
return $ Set.singleton (apid, usrId)
|
||||
|
||||
-- createAvsUserById :: Set AvsPersonId -> Handler (Set (AvsPersonId, UserId)) ???
|
||||
createAvsUserById :: AvsPersonId -> Handler (Maybe UserId)
|
||||
-- | Create new user from AVS-Id. Will throw an AvsException if this is not possible, e.g. due to Uniqueness Constraints
|
||||
createAvsUserById :: AvsPersonId -> Handler UserId
|
||||
createAvsUserById api = do
|
||||
AvsResponseContact res <- avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId api
|
||||
case Set.toList res of
|
||||
[] -> return Nothing
|
||||
(_:_:_) -> throwM $ AvsUserAmbiguous api
|
||||
[] -> throwM $ AvsUserUnknownByAvs api
|
||||
(_:_:_) -> throwM $ AvsUserAmbiguous api
|
||||
[AvsDataContact{avsContactPersonInfo=cpi,..}]
|
||||
| avsContactPersonID /= api -> throwM $ AvsIdMismatch api avsContactPersonID
|
||||
| otherwise -> do
|
||||
pinPass <- queryAvsPin api
|
||||
runDB $ do
|
||||
Entity{entityKey=cid, entityVal=cmp} <- upsertAvsCompany avsContactFirmInfo Nothing
|
||||
-- _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"
|
||||
|
||||
usrCardNo <- queryAvsFullCardNo api
|
||||
let pinPass = avsFullCardNo2pin <$> usrCardNo
|
||||
Entity{entityKey=cid, entityVal=cmp} <- runDB $ upsertAvsCompany avsContactFirmInfo Nothing -- individual runDB, since no need to rollback
|
||||
let internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo
|
||||
persMail :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI
|
||||
newUserData = 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
|
||||
}
|
||||
now <- liftIO getCurrentTime
|
||||
runDB $ do -- any failure must rollback all DB write transactions
|
||||
uid <- maybeThrowM AvsInterfaceUnavailable $ addNewUserDB newUserData
|
||||
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
|
||||
userCompId <- maybeThrowM AvsInterfaceUnavailable $ insertUnique userComp
|
||||
-- TODO: link with existing user, if insertion failed?
|
||||
-- TODO: write suitable exceptions, replacing all 3 AvsInterfaceUnavailable within this block
|
||||
-- TODO: replace upsertAvsUserById with upsertAvsUserById0 and delete old code and old tables
|
||||
-- Supervision
|
||||
addCompanySupervisors cid uid
|
||||
repsertSuperiorSupervisor (Just cid) avsContactFirmInfo uid
|
||||
-- Save AVS data for future updates
|
||||
userAvsId <- maybeThrowM AvsInterfaceUnavailable $ insertUnique UserAvs
|
||||
{ userAvsPersonId = api
|
||||
, userAvsUser = uid
|
||||
, userAvsNoPerson = fromMaybe (negate $ avsPersonId api) $ readMay $ cpi ^. _avsInfoPersonNo -- negative personId as fallback, but readMay should never fail
|
||||
, userAvsLastSynch = now
|
||||
, userAvsLastSynchError = Nothing
|
||||
, userAvsLastPersonInfo = Just cpi
|
||||
, userAvsLastFirmInfo = Just avsContactFirmInfo
|
||||
, userAvsLastCardNo = usrCardNo
|
||||
}
|
||||
return $ seq userCompId $ seq userAvsId uid
|
||||
|
||||
|
||||
|
||||
repsertSuperiorSupervisor :: Maybe CompanyId -> AvsFirmInfo -> UserId -> DB ()
|
||||
repsertSuperiorSupervisor cid afi uid =
|
||||
whenIsJust (afi ^. _avsFirmEMailSuperior) $ \supemail -> forMM_
|
||||
(altM (guessUserByEmail $ stripCI supemail)
|
||||
(maybeCatchAll $ Just . entityKey <$> ldapLookupAndUpsert supemail)
|
||||
) $ \supid -> do
|
||||
let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
|
||||
deleteWhere [UserSupervisorUser ==. uid, UserSupervisorSupervisor !=. supid, UserSupervisorReason ==. reasonSuperior]
|
||||
void $ insertUnique $ UserSupervisor supid uid False cid reasonSuperior
|
||||
|
||||
|
||||
-- | Query DB from given AvsFirmInfo. Guarantees that all Uniqueness-Constraints are checked. Highly unlikely that Nothing is returned, since all AvsResponseContact always contains an AvsFirmInfo
|
||||
getAvsCompany :: AvsFirmInfo -> DB (Maybe (Entity Company))
|
||||
@ -804,14 +788,14 @@ upsertAvsUserByCard persNo = do
|
||||
|
||||
|
||||
-- | 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).
|
||||
upsertAvsUserById0 :: AvsPersonId -> Handler (Maybe UserId)
|
||||
-- Throws errors if the avsInterface in unavailable or new user would violate uniqueness constraints
|
||||
upsertAvsUserById0 :: AvsPersonId -> Handler UserId
|
||||
upsertAvsUserById0 api = do
|
||||
upd <- runDB (updateAvsUserByIds $ Set.singleton api)
|
||||
case Set.toList upd of
|
||||
[] -> createAvsUserById api
|
||||
[(api',uid)]
|
||||
| api == api' -> return $ Just uid
|
||||
| api == api' -> return uid
|
||||
| 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
|
||||
|
||||
@ -14,6 +14,44 @@ import qualified Data.Text as Text
|
||||
|
||||
import Database.Persist.Postgresql
|
||||
|
||||
-- import Database.Esqueleto.Experimental ((:&)(..))
|
||||
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import qualified Database.Esqueleto.PostgreSQL as E
|
||||
|
||||
|
||||
-- TODO: use this function in company view Handler.Firm #157
|
||||
|
||||
-- | add all company supervisors for a given users
|
||||
addCompanySupervisors :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryWrite backend, PersistUniqueWrite backend)
|
||||
=> Key Company -> Key User -> ReaderT backend m ()
|
||||
addCompanySupervisors cid uid =
|
||||
E.insertSelectWithConflict
|
||||
UniqueUserSupervisor
|
||||
( do
|
||||
userCompany <- E.from $ E.table @UserCompany
|
||||
E.where_ $ userCompany E.^. UserCompanyCompany E.==. E.val cid
|
||||
E.&&. userCompany E.^. UserCompanySupervisor
|
||||
return $ UserSupervisor
|
||||
E.<# (userCompany E.^. UserCompanyUser)
|
||||
E.<&> E.val uid
|
||||
E.<&> (userCompany E.^. UserCompanySupervisorReroute)
|
||||
E.<&> E.justVal cid
|
||||
E.<&> E.justVal (tshow SupervisorReasonCompanyDefault)
|
||||
)
|
||||
(\current excluded -> -- Supervision between chosen individuals exists already; keep old reason and company, if exists
|
||||
[ UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany] -- do we want this? Ok, since we delete unconditionally first?!
|
||||
, UserSupervisorReason E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason ]
|
||||
]
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
-------------------
|
||||
-- DEPRECATED
|
||||
|
||||
|
||||
-- | Ensure that the given user is linked to the given company
|
||||
oldUpsertUserCompany :: UserId -> Maybe Text -> Maybe StoredMarkup -> DB () -- TODO: needs reworking
|
||||
oldUpsertUserCompany uid (Just cName) cAddr | notNull cName = do
|
||||
|
||||
@ -1010,7 +1010,7 @@ formResultToMaybe _ = empty
|
||||
maybeThrow :: (MonadThrow m, Exception e) => e -> Maybe a -> m a
|
||||
maybeThrow exc = maybe (throwM exc) return
|
||||
|
||||
-- | Monadic version of 'fromMaybe'
|
||||
-- | Throw an exception upon receiving Nothing
|
||||
maybeThrowM :: (Exception e, MonadThrow m) => e -> m (Maybe a) -> m a
|
||||
maybeThrowM = fromMaybeM . throwM
|
||||
|
||||
|
||||
@ -7,7 +7,7 @@
|
||||
module Utils.Users
|
||||
( AuthenticationKind(..)
|
||||
, AddUserData(..)
|
||||
, addNewUser
|
||||
, addNewUser, addNewUserDB
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -53,50 +53,61 @@ data AddUserData = AddUserData
|
||||
}
|
||||
|
||||
-- | 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!
|
||||
-- Note: `Foundation.Yesod.Auth` contains similar code with potentially differing defaults!
|
||||
addNewUser :: AddUserData -> Handler (Maybe UserId)
|
||||
addNewUser AddUserData{..} = do
|
||||
addNewUser aud = do
|
||||
udc <- getsYesod $ view _appUserDefaults
|
||||
usr <- makeUser udc aud
|
||||
runDB $ insertUnique usr
|
||||
|
||||
-- | Variant of `addNewUser` which allows for rollback through follwing throws
|
||||
addNewUserDB :: AddUserData -> DB (Maybe UserId)
|
||||
addNewUserDB aud = do
|
||||
udc <- liftHandler $ getsYesod $ view _appUserDefaults
|
||||
usr <- makeUser udc aud
|
||||
insertUnique usr
|
||||
|
||||
makeUser :: MonadIO m => UserDefaultConf -> AddUserData -> m User
|
||||
makeUser UserDefaultConf{..} AddUserData{..} = do
|
||||
now <- liftIO getCurrentTime
|
||||
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
|
||||
let
|
||||
newUser = User
|
||||
{ userIdent = audIdent
|
||||
, 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 { csvFormat = review csvPreset CsvPresetXlsx }
|
||||
, userTokensIssuedAfter = Nothing
|
||||
, userCreated = now
|
||||
, userLastLdapSynchronisation = Nothing
|
||||
, userLdapPrimaryKey = audFPersonalNumber
|
||||
, userLastAuthentication = Nothing
|
||||
, userEmail = audEmail
|
||||
, userDisplayName = audDisplayName
|
||||
, userDisplayEmail = audDisplayEmail
|
||||
, userFirstName = audFirstName
|
||||
, userSurname = audSurname
|
||||
, userTitle = audTitle
|
||||
, userSex = audSex
|
||||
, userBirthday = audBirthday
|
||||
, userMobile = audMobile
|
||||
, userTelephone = audTelephone
|
||||
, userCompanyPersonalNumber = audFPersonalNumber
|
||||
, userCompanyDepartment = audFDepartment
|
||||
, userPostAddress = audPostAddress
|
||||
, userPostLastUpdate = Nothing
|
||||
, userPrefersPostal = audPrefersPostal
|
||||
, userPinPassword = audPinPassword
|
||||
, userMatrikelnummer = audMatriculation
|
||||
, userAuthentication = mkAuthMode audAuth
|
||||
}
|
||||
runDB $ insertUnique newUser
|
||||
return User
|
||||
{ userIdent = audIdent
|
||||
, 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 { csvFormat = review csvPreset CsvPresetXlsx }
|
||||
, userTokensIssuedAfter = Nothing
|
||||
, userCreated = now
|
||||
, userLastLdapSynchronisation = Nothing
|
||||
, userLdapPrimaryKey = audFPersonalNumber
|
||||
, userLastAuthentication = Nothing
|
||||
, userEmail = audEmail
|
||||
, userDisplayName = audDisplayName
|
||||
, userDisplayEmail = audDisplayEmail
|
||||
, userFirstName = audFirstName
|
||||
, userSurname = audSurname
|
||||
, userTitle = audTitle
|
||||
, userSex = audSex
|
||||
, userBirthday = audBirthday
|
||||
, userMobile = audMobile
|
||||
, userTelephone = audTelephone
|
||||
, userCompanyPersonalNumber = audFPersonalNumber
|
||||
, userCompanyDepartment = audFDepartment
|
||||
, userPostAddress = audPostAddress
|
||||
, userPostLastUpdate = Nothing
|
||||
, userPrefersPostal = audPrefersPostal
|
||||
, userPinPassword = audPinPassword
|
||||
, userMatrikelnummer = audMatriculation
|
||||
, userAuthentication = mkAuthMode audAuth
|
||||
}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user