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