fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactor(avs): rework createAvsUserById, dealing with supervision (WIP)

Browse Source
This commit is contained in:
Steffen Jost 2024-04-16 17:31:55 +02:00
parent a373abad26
commit cb2778e206
4 changed files with 174 additions and 141 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

172
src/Handler/Utils/Avs.hs
View File

@ -33,8 +33,6 @@ import Import
-- import Handler.Utils -- import Handler.Utils
-- import qualified Database.Esqueleto.Legacy as E -- import qualified Database.Esqueleto.Legacy as E
import Utils.Avs
-- import Utils.Users
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Map as Map import qualified Data.Map as Map
@ -46,7 +44,7 @@ import qualified Control.Monad.Catch as Catch
-- import Auth.LDAP (ldapUserPrincipalName) -- import Auth.LDAP (ldapUserPrincipalName)
import Foundation.Yesod.Auth (ldapLookupAndUpsert) -- , CampusUserConversionException()) import Foundation.Yesod.Auth (ldapLookupAndUpsert) -- , CampusUserConversionException())
import Utils.Avs
import Utils.Mail (pickValidEmail) import Utils.Mail (pickValidEmail)
import Utils.Users import Utils.Users
import Handler.Utils.Users import Handler.Utils.Users
@ -59,7 +57,7 @@ import Database.Persist.Sql (deleteWhereCount) --, updateWhereCount)
import Database.Esqueleto.Experimental ((:&)(..)) import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Utils as E 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) import Servant.Client.Core.ClientError (ClientError)
@ -78,6 +76,7 @@ data AvsException
| AvsPersonSearchAmbiguous -- AvsPersonSearch returned more than one result | AvsPersonSearchAmbiguous -- AvsPersonSearch returned more than one result
| AvsSetLicencesFailed Text -- AvsSetLicence total failure | AvsSetLicencesFailed Text -- AvsSetLicence total failure
| AvsIdMismatch AvsPersonId AvsPersonId -- First AVS Id was requested, but second one was returned for that query | AvsIdMismatch AvsPersonId AvsPersonId -- First AVS Id was requested, but second one was returned for that query
-- | AvsUserCreationFailed
deriving (Show, Eq, Ord, Generic) deriving (Show, Eq, Ord, Generic)
instance Exception AvsException instance Exception AvsException
embedRenderMessage ''UniWorX ''AvsException id -- display as feedback for user initiated actions -- moved to Foundation.I18n 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 , 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 :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => AvsPersonId -> m (Maybe AvsDataPersonCard)
queryAvsPrimaryCard api = runMaybeT $ do queryAvsPrimaryCard api = runMaybeT $ do
AvsResponseStatus res <- MaybeT . maybeCatchAll . fmap Just . avsQuery . AvsQueryStatus $ Set.singleton api AvsResponseStatus res <- MaybeT . maybeCatchAll . fmap Just . avsQuery . AvsQueryStatus $ Set.singleton api
pstatus <- hoistMaybe $ Set.lookupMax $ Set.filter ((api ==) . avsStatusPersonID) res pstatus <- hoistMaybe $ Set.lookupMax $ Set.filter ((api ==) . avsStatusPersonID) res
hoistMaybe $ Set.lookupMax $ avsStatusPersonCardStatus pstatus 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 :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => AvsPersonId -> m (Maybe AvsFullCardNo)
queryAvsFullCardNo = fmap (fmap getFullCardNo) . queryAvsPrimaryCard 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 :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe StoredMarkup)
_avsFirmPostAddress = to mkPost _avsFirmPostAddress = to mkPost
where where
@ -477,7 +472,6 @@ _avsFirmPrefersPostal = to mkPostPref
where where
mkPostPref afi = isJust (afi ^. _avsFirmPostAddress) || isNothing (afi ^. _avsFirmPrimaryEmail) 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 -- 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 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 lensRec = fieldLensVal up
in dbv & lensRec .~ newval 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. -- | Update given AvsPersonId by querying AVS for each; update only, no insertion! Uses batch mechanism.
updateAvsUserByIds :: Set AvsPersonId -> DB (Set (AvsPersonId, UserId)) updateAvsUserByIds :: Set AvsPersonId -> DB (Set (AvsPersonId, UserId))
updateAvsUserByIds apids0 = do updateAvsUserByIds apids0 = do
@ -536,11 +521,11 @@ updateAvsUserByIds apids0 = do
let usrId = userAvsUser usravs let usrId = userAvsUser usravs
usr <- MaybeT $ get usrId usr <- MaybeT $ get usrId
lift $ do -- maybeT no longer needed from here onwards 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 now <- liftIO getCurrentTime
let oldAvsPersonInfo = userAvsLastPersonInfo 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 -- We must not abort entire synch when receiving `Nothing` here, hence no hoistMaybe here oldAvsFirmInfo = userAvsLastFirmInfo usravs -- Nothing is ok here
oldAvsCardNo = userAvsLastCardNo usravs -- We must not abort entire synch when receiving `Nothing` here, hence no hoistMaybe 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. 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 UserFirstName _avsInfoFirstName
, CheckAvsUpdate UserSurname _avsInfoLastName , 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 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, 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 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 CheckAvsUpdate UserPinPassword $ to $ fmap avsFullCardNo2pin -- _Just . to avsFullCardNo2pin . re _Just
usr_up1 = eml_up `mcons` (frm_up `mcons` (pin_up `mcons` per_ups)) usr_up1 = eml_up `mcons` (frm_up `mcons` (pin_up `mcons` per_ups))
avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons` avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons`
@ -617,88 +602,87 @@ updateAvsUserByIds apids0 = do
void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds
-- adjust supervison -- adjust supervison
oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef] oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef]
E.insertSelectWithConflict addCompanySupervisors newCompanyId usrId
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 ]
]
)
newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef) newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
return pst_up return pst_up
-- ensure firmInfo superior is at least normal supervisor, must be executed after updating company default supervisors repsertSuperiorSupervisor (Just newCompanyId) newAvsFirmInfo usrId -- ensure firmInfo superior is at least normal supervisor, must be executed after updating company default supervisors
whenIsJust (newAvsFirmInfo ^. _avsFirmEMailSuperior) $ \supemail -> forMM_ update usrId $ usr_up2 `mcons` usr_up1 -- update user eventually
(altM (guessUserByEmail $ supemail ^. from _CI) update uaId avs_ups -- update stored avsinfo for future updates
(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
return $ Set.singleton (apid, usrId) return $ Set.singleton (apid, usrId)
-- createAvsUserById :: Set AvsPersonId -> Handler (Set (AvsPersonId, UserId)) ??? -- 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 createAvsUserById api = do
AvsResponseContact res <- avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId api AvsResponseContact res <- avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId api
case Set.toList res of case Set.toList res of
[] -> return Nothing [] -> throwM $ AvsUserUnknownByAvs api
(_:_:_) -> throwM $ AvsUserAmbiguous api (_:_:_) -> throwM $ AvsUserAmbiguous api
[AvsDataContact{avsContactPersonInfo=cpi,..}] [AvsDataContact{avsContactPersonInfo=cpi,..}]
| avsContactPersonID /= api -> throwM $ AvsIdMismatch api avsContactPersonID | avsContactPersonID /= api -> throwM $ AvsIdMismatch api avsContactPersonID
| otherwise -> do | otherwise -> do
pinPass <- queryAvsPin api usrCardNo <- queryAvsFullCardNo api
runDB $ do let pinPass = avsFullCardNo2pin <$> usrCardNo
Entity{entityKey=cid, entityVal=cmp} <- upsertAvsCompany avsContactFirmInfo Nothing Entity{entityKey=cid, entityVal=cmp} <- runDB $ upsertAvsCompany avsContactFirmInfo Nothing -- individual runDB, since no need to rollback
-- _now <- liftIO getCurrentTime let internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo
let persMail :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI
internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo newUserData = AddUserData
persMail :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI { audTitle = Nothing
_newUser = AddUserData , audFirstName = cpi ^. _avsInfoFirstName & Text.strip
{ audTitle = Nothing , audSurname = cpi ^. _avsInfoLastName & Text.strip
, audFirstName = cpi ^. _avsInfoFirstName & Text.strip , audDisplayName = cpi ^. _avsInfoDisplayName
, audSurname = cpi ^. _avsInfoLastName & Text.strip , audDisplayEmail = persMail & fromMaybe mempty
, audDisplayName = cpi ^. _avsInfoDisplayName , audEmail = persMail & fromMaybe ("AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI)
, audDisplayEmail = persMail & fromMaybe mempty , audIdent = persMail & fromMaybe ("AVSID:" <> ciShow api )
, audEmail = persMail & fromMaybe ("AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI) , audAuth = maybe AuthKindNoLogin (const AuthKindLDAP) internalPersNo
, audIdent = persMail & fromMaybe ("AVSID:" <> ciShow api ) , audMatriculation = cpi ^. _avsInfoPersonNo & Just . tshow
, audAuth = maybe AuthKindNoLogin (const AuthKindLDAP) internalPersNo , audSex = Nothing
, audMatriculation = cpi ^. _avsInfoPersonNo & Just . tshow , audBirthday = cpi ^. _avsInfoDateOfBirth
, audSex = Nothing , audMobile = cpi ^. _avsInfoPersonMobilePhoneNo
, audBirthday = cpi ^. _avsInfoDateOfBirth , audTelephone = Nothing
, audMobile = cpi ^. _avsInfoPersonMobilePhoneNo , audFPersonalNumber = internalPersNo
, audTelephone = Nothing , audFDepartment = toMaybe (isJust internalPersNo) (cmp ^. _companyShorthand . _CI)
, audFPersonalNumber = internalPersNo , audPostAddress = Nothing -- use company address indirectly
, audFDepartment = toMaybe (isJust internalPersNo) (cmp ^. _companyShorthand . _CI) , audPrefersPostal = cmp ^. _companyPrefersPostal
, audPostAddress = Nothing -- use company address indirectly , audPinPassword = pinPass
, audPrefersPostal = cmp ^. _companyPrefersPostal }
, audPinPassword = pinPass now <- liftIO getCurrentTime
} runDB $ do -- any failure must rollback all DB write transactions
uid <- maybeThrowM AvsInterfaceUnavailable $ addNewUserDB newUserData
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 let userComp = UserCompany uid cid False False 1 True -- default value for new company insertion, if no update can be done
void $ insertUnique userComp userCompId <- maybeThrowM AvsInterfaceUnavailable $ insertUnique userComp
-- TODO: insert supervisors -- TODO: link with existing user, if insertion failed?
-- TODO: add superior from firmInfo -- TODO: write suitable exceptions, replacing all 3 AvsInterfaceUnavailable within this block
return $ Just uid -- 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 -- | 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)) 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 -- | 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). -- Throws errors if the avsInterface in unavailable or new user would violate uniqueness constraints
upsertAvsUserById0 :: AvsPersonId -> Handler (Maybe UserId) upsertAvsUserById0 :: AvsPersonId -> Handler UserId
upsertAvsUserById0 api = do upsertAvsUserById0 api = do
upd <- runDB (updateAvsUserByIds $ Set.singleton api) upd <- runDB (updateAvsUserByIds $ Set.singleton api)
case Set.toList upd of case Set.toList upd of
[] -> createAvsUserById api [] -> createAvsUserById api
[(api',uid)] [(api',uid)]
| api == api' -> return $ Just uid | api == api' -> return uid
| otherwise -> throwM $ AvsIdMismatch api api' | otherwise -> throwM $ AvsIdMismatch api api'
-- error $ "Handler.Utils.Avs.updateAvsUSerByIds returned unasked user with AvsPersonId " <> show api' <> " for queried AvsPersonId " <> show api <> "." -- error $ "Handler.Utils.Avs.updateAvsUSerByIds returned unasked user with AvsPersonId " <> show api' <> " for queried AvsPersonId " <> show api <> "."
(_:_:_) -> throwM $ AvsUserAmbiguous api (_:_:_) -> throwM $ AvsUserAmbiguous api

38
src/Handler/Utils/Company.hs
View File

@ -14,6 +14,44 @@ import qualified Data.Text as Text
import Database.Persist.Postgresql 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 -- | Ensure that the given user is linked to the given company
oldUpsertUserCompany :: UserId -> Maybe Text -> Maybe StoredMarkup -> DB () -- TODO: needs reworking oldUpsertUserCompany :: UserId -> Maybe Text -> Maybe StoredMarkup -> DB () -- TODO: needs reworking
oldUpsertUserCompany uid (Just cName) cAddr | notNull cName = do oldUpsertUserCompany uid (Just cName) cAddr | notNull cName = do

2
src/Utils.hs
View File

@ -1010,7 +1010,7 @@ formResultToMaybe _ = empty
maybeThrow :: (MonadThrow m, Exception e) => e -> Maybe a -> m a maybeThrow :: (MonadThrow m, Exception e) => e -> Maybe a -> m a
maybeThrow exc = maybe (throwM exc) return 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 :: (Exception e, MonadThrow m) => e -> m (Maybe a) -> m a
maybeThrowM = fromMaybeM . throwM maybeThrowM = fromMaybeM . throwM

103
src/Utils/Users.hs
View File

@ -7,7 +7,7 @@
module Utils.Users module Utils.Users
( AuthenticationKind(..) ( AuthenticationKind(..)
, AddUserData(..) , AddUserData(..)
, addNewUser , addNewUser, addNewUserDB
) where ) where
import Import import Import
@ -53,50 +53,61 @@ data AddUserData = AddUserData
} }
-- | Adds a new user to database, no background jobs are scheduled, no notifications send -- | 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 -> 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 now <- liftIO getCurrentTime
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults return User
let { userIdent = audIdent
newUser = User , userMaxFavourites = userDefaultMaxFavourites
{ userIdent = audIdent , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
, userMaxFavourites = userDefaultMaxFavourites , userTheme = userDefaultTheme
, userMaxFavouriteTerms = userDefaultMaxFavouriteTerms , userDateTimeFormat = userDefaultDateTimeFormat
, userTheme = userDefaultTheme , userDateFormat = userDefaultDateFormat
, userDateTimeFormat = userDefaultDateTimeFormat , userTimeFormat = userDefaultTimeFormat
, userDateFormat = userDefaultDateFormat , userDownloadFiles = userDefaultDownloadFiles
, userTimeFormat = userDefaultTimeFormat , userWarningDays = userDefaultWarningDays
, userDownloadFiles = userDefaultDownloadFiles , userShowSex = userDefaultShowSex
, userWarningDays = userDefaultWarningDays , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
, userShowSex = userDefaultShowSex , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
, userExamOfficeGetSynced = userDefaultExamOfficeGetSynced , userNotificationSettings = def
, userExamOfficeGetLabels = userDefaultExamOfficeGetLabels , userLanguages = Nothing
, userNotificationSettings = def , userCsvOptions = def { csvFormat = review csvPreset CsvPresetXlsx }
, userLanguages = Nothing , userTokensIssuedAfter = Nothing
, userCsvOptions = def { csvFormat = review csvPreset CsvPresetXlsx } , userCreated = now
, userTokensIssuedAfter = Nothing , userLastLdapSynchronisation = Nothing
, userCreated = now , userLdapPrimaryKey = audFPersonalNumber
, userLastLdapSynchronisation = Nothing , userLastAuthentication = Nothing
, userLdapPrimaryKey = audFPersonalNumber , userEmail = audEmail
, userLastAuthentication = Nothing , userDisplayName = audDisplayName
, userEmail = audEmail , userDisplayEmail = audDisplayEmail
, userDisplayName = audDisplayName , userFirstName = audFirstName
, userDisplayEmail = audDisplayEmail , userSurname = audSurname
, userFirstName = audFirstName , userTitle = audTitle
, userSurname = audSurname , userSex = audSex
, userTitle = audTitle , userBirthday = audBirthday
, userSex = audSex , userMobile = audMobile
, userBirthday = audBirthday , userTelephone = audTelephone
, userMobile = audMobile , userCompanyPersonalNumber = audFPersonalNumber
, userTelephone = audTelephone , userCompanyDepartment = audFDepartment
, userCompanyPersonalNumber = audFPersonalNumber , userPostAddress = audPostAddress
, userCompanyDepartment = audFDepartment , userPostLastUpdate = Nothing
, userPostAddress = audPostAddress , userPrefersPostal = audPrefersPostal
, userPostLastUpdate = Nothing , userPinPassword = audPinPassword
, userPrefersPostal = audPrefersPostal , userMatrikelnummer = audMatriculation
, userPinPassword = audPinPassword , userAuthentication = mkAuthMode audAuth
, userMatrikelnummer = audMatriculation }
, userAuthentication = mkAuthMode audAuth
}
runDB $ insertUnique newUser