494 lines
21 KiB
Haskell
494 lines
21 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <jost@cip.ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, David Mosbach <david.mosbach@uniworx.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Foundation.Yesod.Auth
|
|
( authenticate
|
|
, userLookupAndUpsert
|
|
, upsertUser, maybeUpsertUser
|
|
, decodeUserTest
|
|
, DecodeUserException(..)
|
|
, updateUserLanguage
|
|
) where
|
|
|
|
import Import.NoFoundation hiding (authenticate)
|
|
|
|
import Auth.Dummy (apDummy)
|
|
import Auth.LDAP
|
|
import Auth.OAuth2
|
|
import Auth.PWHash (apHash)
|
|
|
|
import Foundation.Type
|
|
import Foundation.Types
|
|
import Foundation.I18n
|
|
|
|
-- import Handler.Utils.Profile
|
|
import Handler.Utils.LdapSystemFunctions
|
|
import Handler.Utils.Memcached
|
|
import Foundation.Authorization (AuthorizationCacheKey(..))
|
|
|
|
import Yesod.Auth.Message
|
|
import Yesod.Auth.OAuth2 (getAccessToken, getRefreshToken)
|
|
|
|
import qualified Control.Monad.Catch as C (Handler(..))
|
|
|
|
import qualified Data.ByteString as ByteString
|
|
import qualified Data.CaseInsensitive as CI
|
|
import qualified Data.Map as Map
|
|
import qualified Data.List.NonEmpty as NonEmpty (toList)
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Encoding as Text
|
|
|
|
import qualified Ldap.Client as Ldap
|
|
|
|
|
|
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
|
|
$logErrorS "Auth Debug" $ "\a\27[31m" <> tshow creds <> "\27[0m" -- TODO: debug only
|
|
setSessionJson SessionOAuth2Token (getAccessToken creds, getRefreshToken creds)
|
|
sess <- getSession
|
|
$logErrorS "OAuth session Debug" $ "\27[34m" <> tshow sess <> "\27[0m" -- TODO: debug only
|
|
|
|
now <- liftIO getCurrentTime
|
|
userAuthConf <- getsYesod $ view _appUserAuthConf -- TODO: debug only
|
|
$logErrorS "authenticate AuthConf Debug" $ "\27[31m" <> tshow userAuthConf <> "\27[0m" -- TODO: debug only
|
|
|
|
let
|
|
uAuth = UniqueAuthentication $ CI.mk credsIdent
|
|
upsertMode = creds ^? _upsertUserMode
|
|
|
|
isDummy = is (_Just . _UpsertUserLoginDummy) upsertMode
|
|
isOther = is (_Just . _UpsertUserLoginOther) 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 $ \(fExc :: FetchUserDataException) -> case fExc of
|
|
FetchUserDataNoResult -> do
|
|
$logWarnS "FetchUserException" $ "User lookup failed after successful login for " <> credsIdent
|
|
excRecovery . UserError $ IdentifierNotFound credsIdent
|
|
FetchUserDataAmbiguous -> do
|
|
$logWarnS "FetchUserException" $ "Multiple User results for " <> credsIdent
|
|
excRecovery . UserError $ IdentifierNotFound credsIdent
|
|
err -> do
|
|
$logErrorS "FetchUserException" $ tshow err
|
|
mr <- getMessageRender
|
|
excRecovery . ServerError $ mr MsgInternalLoginError
|
|
, C.Handler $ \(dExc :: DecodeUserException) -> do
|
|
$logErrorS "Auth" $ tshow dExc
|
|
mr <- getMessageRender
|
|
excRecovery . ServerError $ mr dExc
|
|
]
|
|
|
|
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{..}
|
|
|
|
flip catches excHandlers $ if
|
|
| not isDummy, not isOther
|
|
, Just upsertMode' <- upsertMode -> fetchUserData Creds{..} >>= \case
|
|
Just userData -> do
|
|
$logDebugS "Auth" $ "Successful user data lookup: " <> tshow userData
|
|
Authenticated . entityKey <$> upsertUser upsertMode' userData
|
|
Nothing
|
|
-> throwM FetchUserDataNoResult
|
|
| otherwise
|
|
-> acceptExisting
|
|
|
|
|
|
data DecodeUserException
|
|
= DecodeUserInvalidIdent
|
|
| DecodeUserInvalidEmail
|
|
| DecodeUserInvalidDisplayName
|
|
| DecodeUserInvalidGivenName
|
|
| DecodeUserInvalidSurname
|
|
| DecodeUserInvalidTitle
|
|
| DecodeUserInvalidFeaturesOfStudy Text
|
|
| DecodeUserInvalidAssociatedSchools Text
|
|
deriving (Eq, Ord, Read, Show, Generic)
|
|
deriving anyclass (Exception)
|
|
|
|
|
|
_upsertUserMode :: Traversal' (Creds UniWorX) UpsertUserMode
|
|
_upsertUserMode mMode cs@Creds{..}
|
|
| credsPlugin == apDummy = setMode <$> mMode (UpsertUserLoginDummy $ CI.mk credsIdent)
|
|
| credsPlugin `elem` loginAPs
|
|
= setMode <$> mMode (UpsertUserLogin credsPlugin)
|
|
| otherwise = setMode <$> mMode (UpsertUserLoginOther $ CI.mk credsIdent)
|
|
where
|
|
setMode UpsertUserLogin{..} | upsertUserSource `elem` loginAPs
|
|
= cs { credsPlugin = upsertUserSource }
|
|
setMode UpsertUserLoginDummy{..}
|
|
= cs { credsPlugin = apDummy
|
|
, credsIdent = CI.original upsertUserIdent
|
|
}
|
|
setMode UpsertUserLoginOther{..}
|
|
= cs { credsPlugin = bool defaultOther credsPlugin (credsPlugin `notElem` [apDummy, apLdap, apAzure])
|
|
, credsIdent = CI.original upsertUserIdent
|
|
}
|
|
setMode _ = cs
|
|
|
|
loginAPs = [ apAzure, apLdap ]
|
|
defaultOther = apHash
|
|
|
|
|
|
userLookupAndUpsert :: forall m.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, MonadMask m
|
|
, MonadUnliftIO m
|
|
)
|
|
=> Text
|
|
-> UpsertUserMode
|
|
-> SqlPersistT m (Maybe (Entity User))
|
|
userLookupAndUpsert credsIdent mode =
|
|
fetchUserData Creds{credsPlugin=mempty,credsExtra=mempty,..} >>= maybeUpsertUser mode
|
|
|
|
|
|
data FetchUserDataException
|
|
= FetchUserDataNoResult
|
|
| FetchUserDataAmbiguous
|
|
| FetchUserDataException
|
|
deriving (Eq, Ord, Read, Show, Generic)
|
|
deriving anyclass (Exception)
|
|
|
|
-- | Fetch user data with given credentials from external source(s)
|
|
fetchUserData :: forall m site.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, MonadCatch m
|
|
, MonadMask m
|
|
, MonadUnliftIO m
|
|
)
|
|
=> Creds site
|
|
-> SqlPersistT m (Maybe (NonEmpty UpsertUserData))
|
|
fetchUserData Creds{..} = do
|
|
userAuthConf <- getsYesod $ view _appUserAuthConf
|
|
now <- liftIO getCurrentTime
|
|
|
|
results :: Maybe (NonEmpty UpsertUserData) <- case userAuthConf of
|
|
UserAuthConfSingleSource{..} -> fmap (:| []) <$> case userAuthConfSingleSource of
|
|
AuthSourceConfAzureAdV2 AzureConf{ azureConfClientId = upsertUserAzureTenantId } -> do
|
|
queryOAuth2User @[(Text, [ByteString])] credsIdent >>= \case
|
|
Right upsertUserAzureData -> return $ Just UpsertUserDataAzure{..}
|
|
Left _ -> return Nothing
|
|
AuthSourceConfLdap LdapConf{..} -> getsYesod (view _appLdapPool) >>= \case
|
|
Just ldapPool -> fmap (UpsertUserDataLdap ldapConfSourceId) <$> ldapUser'' ldapPool credsIdent
|
|
Nothing -> throwM FetchUserDataException
|
|
|
|
-- insert ExternalUser entries for each fetched dataset
|
|
whenIsJust results $ \ress -> forM_ ress $ \res -> do
|
|
let externalUserLastSync = now
|
|
(externalUserData, externalUserSource) = case res of
|
|
UpsertUserDataAzure{..} -> (toJSON upsertUserAzureData, AuthSourceIdAzure upsertUserAzureTenantId)
|
|
UpsertUserDataLdap{..} -> (toJSON upsertUserLdapData, AuthSourceIdLdap upsertUserLdapHost)
|
|
externalUserUser <- if
|
|
| UpsertUserDataAzure{..} <- res
|
|
, azureData <- Map.fromListWith (++) $ upsertUserAzureData <&> second (filter (not . ByteString.null))
|
|
, [Text.decodeUtf8' -> Right azureUserPrincipalName'] <- azureData !!! azureUserPrincipalName
|
|
-> return $ CI.mk azureUserPrincipalName'
|
|
| UpsertUserDataLdap{..} <- res
|
|
, ldapData <- Map.fromListWith (++) $ upsertUserLdapData <&> second (filter (not . ByteString.null))
|
|
, [Text.decodeUtf8' -> Right ldapPrimaryKey'] <- ldapData !!! ldapPrimaryKey
|
|
-> return $ CI.mk ldapPrimaryKey'
|
|
| otherwise
|
|
-> throwM DecodeUserInvalidIdent
|
|
void $ upsert ExternalUser{..} [ExternalUserData =. externalUserData, ExternalUserLastSync =. externalUserLastSync]
|
|
|
|
return results
|
|
|
|
|
|
-- | Upsert User and related auth in DB according to given external source data (does not query source itself)
|
|
maybeUpsertUser :: forall m.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, MonadCatch m
|
|
)
|
|
=> UpsertUserMode
|
|
-> Maybe (NonEmpty UpsertUserData)
|
|
-> SqlPersistT m (Maybe (Entity User))
|
|
maybeUpsertUser _upsertMode Nothing = return Nothing
|
|
maybeUpsertUser _upsertMode (Just upsertData) = do
|
|
now <- liftIO getCurrentTime
|
|
userDefaultConf <- getsYesod $ view _appUserDefaults
|
|
|
|
(newUser,userUpdate) <- decodeUser now userDefaultConf upsertData
|
|
--TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.upsertUserCompany, but this is called by upsertAvsUser already - conflict?
|
|
|
|
oldUsers <- selectKeysList [ UserIdent ==. userIdent newUser ] []
|
|
|
|
user@(Entity userId _userRec) <- case oldUsers of
|
|
[oldUserId] -> updateGetEntity oldUserId userUpdate
|
|
_other -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate
|
|
|
|
let
|
|
userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions'
|
|
userSystemFunctions' = concat $ upsertData <&> \case
|
|
UpsertUserDataAzure{..} -> do
|
|
(_k, v) <- upsertUserAzureData
|
|
v' <- v
|
|
Right str <- return $ Text.decodeUtf8' v'
|
|
assertM' (not . Text.null) $ Text.strip str
|
|
UpsertUserDataLdap{..} -> do
|
|
(k, v) <- upsertUserLdapData
|
|
guard $ k == ldapAffiliation
|
|
v' <- v
|
|
Right str <- return $ Text.decodeUtf8' v'
|
|
assertM' (not . Text.null) $ Text.strip str
|
|
|
|
iforM_ userSystemFunctions $ \func preset -> do
|
|
memcachedByInvalidate (AuthCacheSystemFunctionList func) $ Proxy @(Set UserId)
|
|
if | preset -> void $ upsert (UserSystemFunction userId func False False) []
|
|
| otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False]
|
|
|
|
return $ Just user
|
|
|
|
upsertUser :: forall m.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, MonadCatch m
|
|
)
|
|
=> UpsertUserMode
|
|
-> NonEmpty UpsertUserData
|
|
-> SqlPersistT m (Entity User)
|
|
upsertUser upsertMode upsertData = maybeUpsertUser upsertMode (Just upsertData) >>= \case
|
|
Nothing -> error "upsertUser: No user result from maybeUpsertUser!"
|
|
Just user -> return user
|
|
|
|
|
|
decodeUser :: ( MonadThrow m
|
|
)
|
|
=> UTCTime -- ^ Now
|
|
-> UserDefaultConf
|
|
-> NonEmpty UpsertUserData -- ^ Raw source data
|
|
-> m (User,_) -- ^ Data for new User entry and updating existing User entries
|
|
decodeUser now UserDefaultConf{..} upsertData = do
|
|
userIdent <- if
|
|
| Just azureData <- mbAzureData
|
|
, [Text.decodeUtf8' -> Right azureUserPrincipalName'] <- azureData !!! azureUserPrincipalName
|
|
, Just azureUserPrincipalName'' <- assertM' (not . Text.null) $ Text.strip azureUserPrincipalName'
|
|
-> return $ CI.mk azureUserPrincipalName''
|
|
| Just ldapData <- mbLdapData
|
|
, [Text.decodeUtf8' -> Right ldapPrimaryKey'] <- ldapData !!! ldapPrimaryKey
|
|
, Just ldapPrimaryKey'' <- assertM' (not . Text.null) $ Text.strip ldapPrimaryKey'
|
|
-> return $ CI.mk ldapPrimaryKey''
|
|
| otherwise
|
|
-> throwM DecodeUserInvalidIdent
|
|
|
|
let
|
|
(azureSurname, azureFirstName, azureDisplayName, azureEmail, azureTelephone, azureMobile, azureLanguages)
|
|
| Just azureData <- mbAzureData
|
|
= ( azureData `decodeAzure` azureUserSurname
|
|
, azureData `decodeAzure` azureUserGivenName
|
|
, azureData `decodeAzure` azureUserDisplayName
|
|
, azureData `decodeAzure` azureUserMail
|
|
, azureData `decodeAzure` azureUserTelephone
|
|
, azureData `decodeAzure` azureUserMobile
|
|
, Nothing -- azureData `decodeAzure` azureUserPreferredLanguage -- TODO: parse Languages from azureUserPreferredLanguage
|
|
)
|
|
| otherwise
|
|
= ( Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing )
|
|
|
|
(ldapSurname, ldapFirstName, ldapDisplayName, ldapEmail, ldapTelephone, ldapMobile, ldapCompanyPersonalNumber, ldapCompanyDepartment)
|
|
| Just ldapData <- mbLdapData
|
|
= ( ldapData `decodeLdap` ldapUserSurname
|
|
, ldapData `decodeLdap` ldapUserFirstName
|
|
, ldapData `decodeLdap` ldapUserDisplayName
|
|
, ldapData `decodeLdap` Ldap.Attr "mail" -- TODO: use ldapUserEmail?
|
|
, ldapData `decodeLdap` ldapUserTelephone
|
|
, ldapData `decodeLdap` ldapUserMobile
|
|
, ldapData `decodeLdap` ldapUserFraportPersonalnummer
|
|
, ldapData `decodeLdap` ldapUserFraportAbteilung
|
|
)
|
|
| otherwise
|
|
= ( Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing )
|
|
|
|
-- TODO: throw on collisions?
|
|
|
|
-- TODO: use user-auth precedence from app config when implementing multi-source support
|
|
let
|
|
userSurname = fromMaybe mempty $ azureSurname <|> ldapSurname
|
|
userFirstName = fromMaybe mempty $ azureFirstName <|> ldapFirstName
|
|
userDisplayName = fromMaybe mempty $ azureDisplayName <|> ldapDisplayName
|
|
userEmail = maybe mempty CI.mk $ azureEmail <|> ldapEmail
|
|
userTelephone = azureTelephone <|> ldapTelephone
|
|
userMobile = azureMobile <|> ldapMobile
|
|
userLanguages = azureLanguages
|
|
userCompanyPersonalNumber = ldapCompanyPersonalNumber
|
|
userCompanyDepartment = ldapCompanyDepartment
|
|
|
|
newUser = User
|
|
{ userMaxFavourites = userDefaultMaxFavourites
|
|
, userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
|
|
, userTheme = userDefaultTheme
|
|
, userDateTimeFormat = userDefaultDateTimeFormat
|
|
, userDateFormat = userDefaultDateFormat
|
|
, userTimeFormat = userDefaultTimeFormat
|
|
, userDownloadFiles = userDefaultDownloadFiles
|
|
, userWarningDays = userDefaultWarningDays
|
|
, userShowSex = userDefaultShowSex
|
|
, userSex = Nothing
|
|
, userBirthday = Nothing
|
|
, userTitle = Nothing
|
|
, userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
|
|
, userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
|
|
, userNotificationSettings = def
|
|
, userCsvOptions = def
|
|
, userTokensIssuedAfter = Nothing
|
|
, userDisplayEmail = userEmail
|
|
, userMatrikelnummer = Nothing -- TODO: not known from Azure/LDAP, must be derived from REST interface to AVS
|
|
, userPostAddress = Nothing -- TODO: not known from Azure/LDAP, must be derived from REST interface to AVS
|
|
, userPostLastUpdate = Nothing
|
|
, userPinPassword = Nothing -- must be derived via AVS
|
|
, userPrefersPostal = userDefaultPrefersPostal
|
|
, userPasswordHash = Nothing
|
|
, userLastAuthentication = Nothing
|
|
, userCreated = now
|
|
, userLastSync = Just now
|
|
, ..
|
|
}
|
|
userUpdate =
|
|
[ UserSurname =. userSurname
|
|
, UserFirstName =. userFirstName
|
|
-- , UserDisplayName =. userDisplayName -- not updated, since users are allowed to change their DisplayName
|
|
, UserEmail =. userEmail
|
|
, UserTelephone =. userTelephone
|
|
, UserMobile =. userMobile
|
|
, UserCompanyPersonalNumber =. userCompanyPersonalNumber
|
|
, UserCompanyDepartment =. userCompanyDepartment
|
|
, UserLastSync =. Just now
|
|
]
|
|
return (newUser, userUpdate)
|
|
|
|
where
|
|
mbAzureData :: Maybe (Map Text [ByteString])
|
|
mbAzureData = fmap (Map.fromListWith (++) . map (second (filter (not . ByteString.null)))) . concat $ preview _upsertUserAzureData <$> NonEmpty.toList upsertData
|
|
mbLdapData :: Maybe (Map Ldap.Attr [Ldap.AttrValue]) -- Recall: Ldap.AttrValue == ByteString
|
|
mbLdapData = fmap (Map.fromListWith (++) . map (second (filter (not . ByteString.null)))) . concat $ preview _upsertUserLdapData <$> NonEmpty.toList upsertData
|
|
|
|
-- just returns Nothing on error, pure
|
|
decodeAzure :: Map Text [ByteString] -> Text -> Maybe Text
|
|
decodeAzure azureData k = listToMaybe . rights $ Text.decodeUtf8' <$> azureData !!! k
|
|
decodeLdap :: Map Ldap.Attr [Ldap.AttrValue] -> Ldap.Attr -> Maybe Text
|
|
decodeLdap ldapData attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapData !!! attr
|
|
|
|
-- decodeAzure' :: Map Text [ByteString] -> Text -> Text
|
|
-- decodeAzure' azureData = fromMaybe "" . decodeAzure azureData
|
|
-- decodeLdap' :: Map Ldap.Attr [Ldap.AttrValue] -> Ldap.Attr -> Text
|
|
-- decodeLdap' ldapData = fromMaybe "" . decodeLdap ldapData
|
|
-- accept the first successful decoding or empty; only throw an error if all decodings fail
|
|
-- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m (Maybe Text)
|
|
-- decodeLdap' attr err
|
|
-- | [] <- vs = return Nothing
|
|
-- | (h:_) <- rights vs = return $ Just h
|
|
-- | otherwise = throwM err
|
|
-- where
|
|
-- vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
|
|
|
|
-- only accepts the first successful decoding, ignoring all others, but failing if there is none
|
|
-- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text
|
|
-- decodeLdap1 ldapData attr err
|
|
-- | (h:_) <- rights vs = return h
|
|
-- | otherwise = throwM err
|
|
-- where
|
|
-- vs = Text.decodeUtf8' <$> (ldapData !!! attr)
|
|
|
|
-- accept and merge one or more successful decodings, ignoring all others
|
|
-- decodeLdapN attr err
|
|
-- | t@(_:_) <- rights vs
|
|
-- = return $ Text.unwords t
|
|
-- | otherwise = throwM err
|
|
-- where
|
|
-- vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
|
|
|
|
decodeUserTest :: ( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, MonadCatch m
|
|
)
|
|
=> NonEmpty UpsertUserData
|
|
-> m (Either DecodeUserException (User, [Update User]))
|
|
decodeUserTest decodeData = do
|
|
now <- liftIO getCurrentTime
|
|
userDefaultConf <- getsYesod $ view _appUserDefaults
|
|
try $ decodeUser now userDefaultConf decodeData
|
|
|
|
|
|
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 : nubOrd (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
|
|
|
|
embedRenderMessage ''UniWorX ''DecodeUserException id
|