532 lines
22 KiB
Haskell
532 lines
22 KiB
Haskell
module Foundation.Yesod.Auth
|
|
( authenticate
|
|
, upsertCampusUser
|
|
, CampusUserConversionException(..)
|
|
, campusUserFailoverMode, updateUserLanguage
|
|
) where
|
|
|
|
import Import.NoFoundation hiding (authenticate)
|
|
|
|
import Foundation.Type
|
|
import Foundation.Types
|
|
import Foundation.I18n
|
|
|
|
import Handler.Utils.Profile
|
|
import Handler.Utils.StudyFeatures
|
|
import Handler.Utils.SchoolLdap
|
|
import Handler.Utils.LdapSystemFunctions
|
|
|
|
import Yesod.Auth.Message
|
|
import Auth.LDAP
|
|
import Auth.PWHash (apHash)
|
|
import Auth.Dummy (apDummy)
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
import qualified Control.Monad.Catch as C (Handler(..))
|
|
import qualified Ldap.Client as Ldap
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Encoding as Text
|
|
import qualified Data.ByteString as ByteString
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Conduit.Combinators as C
|
|
|
|
import qualified Data.List as List ((\\))
|
|
|
|
import qualified Data.UUID as UUID
|
|
import Data.ByteArray (convert)
|
|
import Crypto.Hash (SHAKE128)
|
|
import qualified Data.Binary as Binary
|
|
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import Crypto.Hash.Conduit (sinkHash)
|
|
|
|
|
|
authenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX
|
|
, YesodPersist UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
|
|
, YesodAuth UniWorX, UserId ~ AuthId UniWorX
|
|
)
|
|
=> Creds UniWorX -> m (AuthenticationResult UniWorX)
|
|
authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do
|
|
now <- liftIO getCurrentTime
|
|
|
|
let
|
|
uAuth = UniqueAuthentication $ CI.mk credsIdent
|
|
upsertMode = creds ^? _upsertCampusUserMode
|
|
|
|
isDummy = is (_Just . _UpsertCampusUserLoginDummy) upsertMode
|
|
isOther = is (_Just . _UpsertCampusUserLoginOther) upsertMode
|
|
|
|
excRecovery res
|
|
| isDummy || isOther
|
|
= do
|
|
case res of
|
|
UserError err -> addMessageI Error err
|
|
ServerError err -> addMessage Error $ toHtml err
|
|
_other -> return ()
|
|
acceptExisting
|
|
| otherwise
|
|
= return res
|
|
|
|
excHandlers =
|
|
[ C.Handler $ \case
|
|
CampusUserNoResult -> do
|
|
$logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent
|
|
excRecovery . UserError $ IdentifierNotFound credsIdent
|
|
CampusUserAmbiguous -> do
|
|
$logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent
|
|
excRecovery . UserError $ IdentifierNotFound credsIdent
|
|
err -> do
|
|
$logErrorS "LDAP" $ tshow err
|
|
mr <- getMessageRender
|
|
excRecovery . ServerError $ mr MsgInternalLdapError
|
|
, C.Handler $ \(cExc :: CampusUserConversionException) -> do
|
|
$logErrorS "LDAP" $ tshow cExc
|
|
mr <- getMessageRender
|
|
excRecovery . ServerError $ mr cExc
|
|
]
|
|
|
|
acceptExisting :: SqlPersistT (HandlerFor UniWorX) (AuthenticationResult UniWorX)
|
|
acceptExisting = do
|
|
res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
|
|
case res of
|
|
Authenticated uid
|
|
-> associateUserSchoolsByTerms uid
|
|
_other
|
|
-> return ()
|
|
case res of
|
|
Authenticated uid
|
|
| not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]
|
|
_other -> return res
|
|
|
|
$logDebugS "auth" $ tshow Creds{..}
|
|
UniWorX{..} <- getYesod
|
|
|
|
flip catches excHandlers $ case appLdapPool of
|
|
Just ldapPool
|
|
| Just upsertMode' <- upsertMode -> do
|
|
ldapData <- campusUser ldapPool campusUserFailoverMode Creds{..}
|
|
$logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
|
|
Authenticated . entityKey <$> upsertCampusUser upsertMode' ldapData
|
|
_other
|
|
-> acceptExisting
|
|
|
|
|
|
data CampusUserConversionException
|
|
= CampusUserInvalidIdent
|
|
| CampusUserInvalidEmail
|
|
| CampusUserInvalidDisplayName
|
|
| CampusUserInvalidGivenName
|
|
| CampusUserInvalidSurname
|
|
| CampusUserInvalidTitle
|
|
| CampusUserInvalidMatriculation
|
|
| CampusUserInvalidSex
|
|
| CampusUserInvalidFeaturesOfStudy Text
|
|
| CampusUserInvalidAssociatedSchools Text
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
deriving anyclass (Exception)
|
|
|
|
_upsertCampusUserMode :: Traversal' (Creds UniWorX) UpsertCampusUserMode
|
|
_upsertCampusUserMode mMode cs@Creds{..}
|
|
| credsPlugin == apDummy = setMode <$> mMode (UpsertCampusUserLoginDummy $ CI.mk credsIdent)
|
|
| credsPlugin == apLdap = setMode <$> mMode UpsertCampusUserLoginLdap
|
|
| otherwise = setMode <$> mMode (UpsertCampusUserLoginOther $ CI.mk credsIdent)
|
|
where
|
|
setMode UpsertCampusUserLoginLdap
|
|
= cs{ credsPlugin = apLdap }
|
|
setMode (UpsertCampusUserLoginDummy ident)
|
|
= cs{ credsPlugin = apDummy
|
|
, credsIdent = CI.original ident
|
|
}
|
|
setMode (UpsertCampusUserLoginOther ident)
|
|
= cs{ credsPlugin = bool defaultOther credsPlugin (credsPlugin /= apDummy && credsPlugin /= apLdap)
|
|
, credsIdent = CI.original ident
|
|
}
|
|
setMode _ = cs
|
|
|
|
defaultOther = apHash
|
|
|
|
upsertCampusUser :: forall m.
|
|
( MonadHandler m, HandlerSite m ~ UniWorX
|
|
, MonadThrow m
|
|
)
|
|
=> UpsertCampusUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User)
|
|
upsertCampusUser upsertMode ldapData = do
|
|
now <- liftIO getCurrentTime
|
|
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
|
|
|
|
let
|
|
userIdent'' = fold [ v | (k, v) <- ldapData, k == ldapUserPrincipalName ]
|
|
userMatrikelnummer' = fold [ v | (k, v) <- ldapData, k == ldapUserMatriculation ]
|
|
userLdapPrimaryKey' = fold [ v | (k, v) <- ldapData, k == ldapPrimaryKey ]
|
|
userEmail' = fold $ do
|
|
k' <- toList ldapUserEmail
|
|
(k, v) <- ldapData
|
|
guard $ k' == k
|
|
return v
|
|
userDisplayName'' = fold [ v | (k, v) <- ldapData, k == ldapUserDisplayName ]
|
|
userFirstName' = fold [ v | (k, v) <- ldapData, k == ldapUserFirstName ]
|
|
userSurname' = fold [ v | (k, v) <- ldapData, k == ldapUserSurname ]
|
|
userTitle' = fold [ v | (k, v) <- ldapData, k == ldapUserTitle ]
|
|
userSex' = fold [ v | (k, v) <- ldapData, k == ldapSex ]
|
|
|
|
userAuthentication
|
|
| is _UpsertCampusUserLoginOther upsertMode
|
|
= error "Non-LDAP logins should only work for users that are already known"
|
|
| otherwise = AuthLDAP
|
|
userLastAuthentication = guardOn isLogin now
|
|
isLogin = has (_UpsertCampusUserLoginLdap <> _UpsertCampusUserLoginOther . united) upsertMode
|
|
|
|
userIdent <- if
|
|
| [bs] <- userIdent''
|
|
, Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
|
|
, hasn't _upsertCampusUserIdent upsertMode || has (_upsertCampusUserIdent . only userIdent') upsertMode
|
|
-> return userIdent'
|
|
| Just userIdent' <- upsertMode ^? _upsertCampusUserIdent
|
|
-> return userIdent'
|
|
| otherwise
|
|
-> throwM CampusUserInvalidIdent
|
|
userEmail <- if
|
|
| userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') userEmail'
|
|
-> return $ CI.mk userEmail
|
|
| otherwise
|
|
-> throwM CampusUserInvalidEmail
|
|
userDisplayName' <- if
|
|
| [bs] <- userDisplayName''
|
|
, Right userDisplayName' <- Text.decodeUtf8' bs
|
|
-> return userDisplayName'
|
|
| otherwise
|
|
-> throwM CampusUserInvalidDisplayName
|
|
userFirstName <- if
|
|
| [bs] <- userFirstName'
|
|
, Right userFirstName <- Text.decodeUtf8' bs
|
|
-> return userFirstName
|
|
| otherwise
|
|
-> throwM CampusUserInvalidGivenName
|
|
userSurname <- if
|
|
| [bs] <- userSurname'
|
|
, Right userSurname <- Text.decodeUtf8' bs
|
|
-> return userSurname
|
|
| otherwise
|
|
-> throwM CampusUserInvalidSurname
|
|
userTitle <- if
|
|
| all ByteString.null userTitle'
|
|
-> return Nothing
|
|
| [bs] <- userTitle'
|
|
, Right userTitle <- Text.decodeUtf8' bs
|
|
-> return $ Just userTitle
|
|
| otherwise
|
|
-> throwM CampusUserInvalidTitle
|
|
userMatrikelnummer <- if
|
|
| [bs] <- userMatrikelnummer'
|
|
, Right userMatrikelnummer <- Text.decodeUtf8' bs
|
|
-> return $ Just userMatrikelnummer
|
|
| [] <- userMatrikelnummer'
|
|
-> return Nothing
|
|
| otherwise
|
|
-> throwM CampusUserInvalidMatriculation
|
|
userSex <- if
|
|
| [bs] <- userSex'
|
|
, Right userSex'' <- Text.decodeUtf8' bs
|
|
, Just userSex''' <- readMay userSex''
|
|
, Just userSex <- userSex''' ^? iso5218
|
|
-> return $ Just userSex
|
|
| [] <- userSex'
|
|
-> return Nothing
|
|
| otherwise
|
|
-> throwM CampusUserInvalidSex
|
|
userLdapPrimaryKey <- if
|
|
| [bs] <- userLdapPrimaryKey'
|
|
, Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs
|
|
, Just userLdapPrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userLdapPrimaryKey''
|
|
-> return $ Just userLdapPrimaryKey'''
|
|
| otherwise
|
|
-> return Nothing
|
|
|
|
let
|
|
newUser = User
|
|
{ userMaxFavourites = userDefaultMaxFavourites
|
|
, userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
|
|
, userTheme = userDefaultTheme
|
|
, userDateTimeFormat = userDefaultDateTimeFormat
|
|
, userDateFormat = userDefaultDateFormat
|
|
, userTimeFormat = userDefaultTimeFormat
|
|
, userDownloadFiles = userDefaultDownloadFiles
|
|
, userWarningDays = userDefaultWarningDays
|
|
, userShowSex = userDefaultShowSex
|
|
, userNotificationSettings = def
|
|
, userLanguages = Nothing
|
|
, userCsvOptions = def
|
|
, userTokensIssuedAfter = Nothing
|
|
, userCreated = now
|
|
, userLastLdapSynchronisation = Just now
|
|
, userDisplayName = userDisplayName'
|
|
, userDisplayEmail = userEmail
|
|
, ..
|
|
}
|
|
userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
|
|
-- , UserDisplayName =. userDisplayName
|
|
, UserFirstName =. userFirstName
|
|
, UserSurname =. userSurname
|
|
, UserTitle =. userTitle
|
|
, UserEmail =. userEmail
|
|
, UserSex =. userSex
|
|
, UserLastLdapSynchronisation =. Just now
|
|
, UserLdapPrimaryKey =. userLdapPrimaryKey
|
|
] ++
|
|
[ UserLastAuthentication =. Just now | isLogin ]
|
|
|
|
oldUsers <- for userLdapPrimaryKey $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] []
|
|
|
|
user@(Entity userId userRec) <- case oldUsers of
|
|
Just [oldUserId] -> updateGetEntity oldUserId userUpdate
|
|
_other -> upsertBy (UniqueAuthentication userIdent) newUser userUpdate
|
|
unless (validDisplayName userTitle userFirstName userSurname $ userDisplayName userRec) $
|
|
update userId [ UserDisplayName =. userDisplayName' ]
|
|
|
|
let
|
|
userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now
|
|
userStudyFeatures' = do
|
|
(k, v) <- ldapData
|
|
guard $ k == ldapUserStudyFeatures
|
|
v' <- v
|
|
Right str <- return $ Text.decodeUtf8' v'
|
|
return str
|
|
|
|
termNames = nubBy ((==) `on` CI.mk) $ do
|
|
(k, v) <- ldapData
|
|
guard $ k == ldapUserFieldName
|
|
v' <- v
|
|
Right str <- return $ Text.decodeUtf8' v'
|
|
return str
|
|
|
|
userSubTermsSemesters = forM userSubTermsSemesters' parseSubTermsSemester
|
|
userSubTermsSemesters' = do
|
|
(k, v) <- ldapData
|
|
guard $ k == ldapUserSubTermsSemester
|
|
v' <- v
|
|
Right str <- return $ Text.decodeUtf8' v'
|
|
return str
|
|
|
|
fs' <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userStudyFeatures
|
|
sts <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userSubTermsSemesters
|
|
|
|
let
|
|
studyTermCandidates = Set.fromList $ do
|
|
let sfKeys = unStudyTermsKey . studyFeaturesField <$> fs'
|
|
subTermsKeys = unStudyTermsKey . fst <$> sts
|
|
|
|
(,) <$> sfKeys ++ subTermsKeys <*> termNames
|
|
|
|
let
|
|
assimilateSubTerms :: [(StudyTermsId, Int)] -> [StudyFeatures] -> WriterT (Set (StudyTermsId, Maybe StudyTermsId)) (SqlPersistT m) [StudyFeatures]
|
|
assimilateSubTerms [] xs = return xs
|
|
assimilateSubTerms ((subterm, subSemester) : subterms) unusedFeats = do
|
|
standalone <- lift $ get subterm
|
|
case standalone of
|
|
_other
|
|
| (match : matches, unusedFeats') <- partition
|
|
(\StudyFeatures{..} -> subterm == studyFeaturesField
|
|
&& subSemester == studyFeaturesSemester
|
|
) unusedFeats
|
|
-> do
|
|
$logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}” and matching feature “#{tshow match}”|]
|
|
(:) match <$> assimilateSubTerms subterms (matches ++ unusedFeats')
|
|
| any ((== subterm) . studyFeaturesField) unusedFeats
|
|
-> do
|
|
$logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}” due to feature of matching field|]
|
|
assimilateSubTerms subterms unusedFeats
|
|
Just StudyTerms{..}
|
|
| Just defDegree <- studyTermsDefaultDegree
|
|
, Just defType <- studyTermsDefaultType
|
|
-> do
|
|
$logDebugS "Campus" [st|Applying default for standalone study term “#{tshow subterm}”|]
|
|
let sf = StudyFeatures
|
|
{ studyFeaturesUser = userId
|
|
, studyFeaturesDegree = defDegree
|
|
, studyFeaturesField = subterm
|
|
, studyFeaturesSuperField = Nothing
|
|
, studyFeaturesType = defType
|
|
, studyFeaturesSemester = subSemester
|
|
, studyFeaturesFirstObserved = Just now
|
|
, studyFeaturesLastObserved = now
|
|
, studyFeaturesValid = True
|
|
, studyFeaturesRelevanceCached = False
|
|
}
|
|
(sf :) <$> assimilateSubTerms subterms unusedFeats
|
|
Nothing
|
|
| [] <- unusedFeats -> do
|
|
$logDebugS "Campus" [st|Saw subterm “#{tshow subterm}” when no fos-terms remain|]
|
|
tell $ Set.singleton (subterm, Nothing)
|
|
assimilateSubTerms subterms []
|
|
_other -> do
|
|
knownParents <- lift $ map (studySubTermsParent . entityVal) <$> selectList [ StudySubTermsChild ==. subterm ] []
|
|
let matchingFeatures = case knownParents of
|
|
[] -> filter ((== subSemester) . studyFeaturesSemester) unusedFeats
|
|
ps -> filter (\StudyFeatures{studyFeaturesField, studyFeaturesSemester} -> elem studyFeaturesField ps && studyFeaturesSemester == subSemester) unusedFeats
|
|
when (null knownParents) . forM_ matchingFeatures $ \StudyFeatures{..} ->
|
|
tell $ Set.singleton (subterm, Just studyFeaturesField)
|
|
if
|
|
| not $ null knownParents -> do
|
|
$logDebugS "Campus" [st|Applying subterm “#{tshow subterm}” to #{tshow matchingFeatures}|]
|
|
let setSuperField sf = sf
|
|
& _studyFeaturesSuperField %~ (<|> Just (sf ^. _studyFeaturesField))
|
|
& _studyFeaturesField .~ subterm
|
|
(++) (map setSuperField matchingFeatures) <$> assimilateSubTerms subterms (unusedFeats List.\\ matchingFeatures)
|
|
| otherwise -> do
|
|
$logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}”|]
|
|
assimilateSubTerms subterms unusedFeats
|
|
$logDebugS "Campus" [st|Terms for “#{userIdent}”: #{tshow (sts, fs')}|]
|
|
(fs, studyFieldParentCandidates) <- runWriterT $ assimilateSubTerms sts fs'
|
|
|
|
let
|
|
studyTermCandidateIncidence
|
|
= fromMaybe (error "Could not convert studyTermCandidateIncidence-Hash to UUID") -- Should never happen
|
|
. UUID.fromByteString
|
|
. fromStrict
|
|
. (convert :: Digest (SHAKE128 128) -> ByteString)
|
|
. runConduitPure
|
|
$ C.yieldMany ((toStrict . Binary.encode <$> Set.toList studyTermCandidates) ++ (toStrict . Binary.encode <$> Set.toList studyFieldParentCandidates)) .| sinkHash
|
|
|
|
candidatesRecorded <- E.selectExists . E.from $ \(candidate `E.FullOuterJoin` parentCandidate `E.FullOuterJoin` standaloneCandidate) -> do
|
|
E.on $ candidate E.?. StudyTermNameCandidateIncidence E.==. standaloneCandidate E.?. StudyTermStandaloneCandidateIncidence
|
|
E.on $ candidate E.?. StudyTermNameCandidateIncidence E.==. parentCandidate E.?. StudySubTermParentCandidateIncidence
|
|
E.where_ $ candidate E.?. StudyTermNameCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)
|
|
E.||. parentCandidate E.?. StudySubTermParentCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)
|
|
E.||. standaloneCandidate E.?. StudyTermStandaloneCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)
|
|
|
|
unless candidatesRecorded $ do
|
|
let
|
|
studyTermCandidates' = do
|
|
(studyTermNameCandidateKey, studyTermNameCandidateName) <- Set.toList studyTermCandidates
|
|
let studyTermNameCandidateIncidence = studyTermCandidateIncidence
|
|
return StudyTermNameCandidate{..}
|
|
insertMany_ studyTermCandidates'
|
|
|
|
let
|
|
studySubTermParentCandidates' = do
|
|
(StudyTermsKey' studySubTermParentCandidateKey, Just (StudyTermsKey' studySubTermParentCandidateParent)) <- Set.toList studyFieldParentCandidates
|
|
let studySubTermParentCandidateIncidence = studyTermCandidateIncidence
|
|
return StudySubTermParentCandidate{..}
|
|
insertMany_ studySubTermParentCandidates'
|
|
|
|
let
|
|
studyTermStandaloneCandidates' = do
|
|
(StudyTermsKey' studyTermStandaloneCandidateKey, Nothing) <- Set.toList studyFieldParentCandidates
|
|
let studyTermStandaloneCandidateIncidence = studyTermCandidateIncidence
|
|
return StudyTermStandaloneCandidate{..}
|
|
insertMany_ studyTermStandaloneCandidates'
|
|
|
|
E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False]
|
|
forM_ fs $ \f@StudyFeatures{..} -> do
|
|
insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
|
|
insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing Nothing Nothing
|
|
void $ upsert f
|
|
[ StudyFeaturesLastObserved =. now
|
|
, StudyFeaturesValid =. True
|
|
, StudyFeaturesSuperField =. studyFeaturesSuperField
|
|
]
|
|
associateUserSchoolsByTerms userId
|
|
|
|
cacheStudyFeatureRelevance $ \studyFeatures -> studyFeatures E.^. StudyFeaturesUser E.==. E.val userId
|
|
|
|
let
|
|
userAssociatedSchools = concat <$> forM userAssociatedSchools' parseLdapSchools
|
|
userAssociatedSchools' = do
|
|
(k, v) <- ldapData
|
|
guard $ k == ldapUserSchoolAssociation
|
|
v' <- v
|
|
Right str <- return $ Text.decodeUtf8' v'
|
|
return str
|
|
|
|
ss <- either (throwM . CampusUserInvalidAssociatedSchools . tshow) return userAssociatedSchools
|
|
|
|
forM_ ss $ \frag -> void . runMaybeT $ do
|
|
let
|
|
exactMatch = MaybeT . getBy $ UniqueOrgUnit frag
|
|
infixMatch = (hoistMaybe . preview _head) <=< (lift . E.select . E.from) $ \schoolLdap -> do
|
|
E.where_ $ E.val frag `E.isInfixOf` schoolLdap E.^. SchoolLdapOrgUnit
|
|
E.&&. E.not_ (E.isNothing $ schoolLdap E.^. SchoolLdapSchool)
|
|
return schoolLdap
|
|
Entity _ SchoolLdap{..} <- exactMatch <|> infixMatch
|
|
ssh <- hoistMaybe schoolLdapSchool
|
|
|
|
lift . void $ insertUnique UserSchool
|
|
{ userSchoolUser = userId
|
|
, userSchoolSchool = ssh
|
|
, userSchoolIsOptOut = False
|
|
}
|
|
|
|
forM_ ss $ void . insertUnique . SchoolLdap Nothing
|
|
|
|
let
|
|
userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions'
|
|
userSystemFunctions' = do
|
|
(k, v) <- ldapData
|
|
guard $ k == ldapAffiliation
|
|
v' <- v
|
|
Right str <- return $ Text.decodeUtf8' v'
|
|
assertM' (not . Text.null) $ Text.strip str
|
|
|
|
iforM_ userSystemFunctions $ \func preset -> if
|
|
| preset -> void $ upsert (UserSystemFunction userId func False False) []
|
|
| otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False]
|
|
|
|
return user
|
|
where
|
|
insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
|
|
|
|
associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m ()
|
|
associateUserSchoolsByTerms uid = do
|
|
sfs <- selectList [StudyFeaturesUser ==. uid] []
|
|
|
|
forM_ sfs $ \(Entity _ StudyFeatures{..}) -> do
|
|
schoolTerms <- selectList [SchoolTermsTerms ==. studyFeaturesField] []
|
|
forM_ schoolTerms $ \(Entity _ SchoolTerms{..}) ->
|
|
void $ insertUnique UserSchool
|
|
{ userSchoolUser = uid
|
|
, userSchoolSchool = schoolTermsSchool
|
|
, userSchoolIsOptOut = False
|
|
}
|
|
|
|
updateUserLanguage :: ( MonadHandler m, HandlerSite m ~ UniWorX
|
|
, YesodAuth UniWorX
|
|
, UserId ~ AuthId UniWorX
|
|
)
|
|
=> Maybe Lang -> SqlPersistT m (Maybe Lang)
|
|
updateUserLanguage (Just lang) = do
|
|
unless (lang `elem` appLanguages) $
|
|
invalidArgs ["Unsupported language"]
|
|
|
|
muid <- maybeAuthId
|
|
for_ muid $ \uid -> do
|
|
langs <- languages
|
|
update uid [ UserLanguages =. Just (Languages $ lang : nub (filter ((&&) <$> (`elem` appLanguages) <*> (/= lang)) langs)) ]
|
|
setRegisteredCookie CookieLang lang
|
|
return $ Just lang
|
|
updateUserLanguage Nothing = runMaybeT $ do
|
|
uid <- MaybeT maybeAuthId
|
|
User{..} <- MaybeT $ get uid
|
|
setLangs <- toList . selectLanguages appLanguages <$> languages
|
|
highPrioSetLangs <- toList . selectLanguages appLanguages <$> highPrioRequestedLangs
|
|
let userLanguages' = toList . selectLanguages appLanguages <$> userLanguages ^? _Just . _Wrapped
|
|
lang <- case (userLanguages', setLangs, highPrioSetLangs) of
|
|
(_, _, hpl : _)
|
|
-> lift $ hpl <$ update uid [ UserLanguages =. Just (Languages highPrioSetLangs) ]
|
|
(Just (l : _), _, _)
|
|
-> return l
|
|
(Nothing, l : _, _)
|
|
-> lift $ l <$ update uid [ UserLanguages =. Just (Languages setLangs) ]
|
|
(Just [], l : _, _)
|
|
-> return l
|
|
(_, [], _)
|
|
-> mzero
|
|
setRegisteredCookie CookieLang lang
|
|
return lang
|
|
|
|
campusUserFailoverMode :: FailoverMode
|
|
campusUserFailoverMode = FailoverUnlimited
|
|
|
|
embedRenderMessage ''UniWorX ''CampusUserConversionException id
|