diff --git a/config/keter.yml b/config/keter.yml index b6b7bd829..24177b0fc 100644 --- a/config/keter.yml +++ b/config/keter.yml @@ -25,6 +25,8 @@ stanzas: - LDAPPW - LDAPBN - DUMMY_LOGIN + - DETAILED_LOGGING + - LOG_ALL # Use the following to automatically copy your bundle upon creation via `yesod # keter`. Uses `scp` internally, so you can set it to a remote destination diff --git a/config/settings.yml b/config/settings.yml index 378f58f0f..4cf378423 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -13,8 +13,8 @@ approot: "_env:APPROOT:http://localhost:3000" # Optional values with the following production defaults. # In development, they default to the inverse. # -# detailed-logging: false -# should-log-all: false +detailed-logging: "_env:DETAILED_LOGGING:false" +should-log-all: "_env:LOG_ALL:false" # reload-templates: false # mutable-static: false # skip-combining: false diff --git a/models b/models index 7b7d0a666..4f016f828 100644 --- a/models +++ b/models @@ -1,7 +1,7 @@ User plugin Text ident Text - matrikelnummer Text + matrikelnummer Text Maybe UniqueAuthentication plugin ident Term json name TermIdentifier diff --git a/src/Foundation.hs b/src/Foundation.hs index 76729e7b4..9f853da68 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -6,6 +6,7 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternGuards #-} module Foundation where @@ -16,10 +17,12 @@ import Text.Hamlet (hamletFile) import Text.Jasmine (minifym) -- Used only when in "auth-dummy-login" setting is enabled. +import Yesod.Auth.Message import Yesod.Auth.Dummy import Yesod.Auth.LDAP import LDAP.Data (LDAPScope(..)) +import LDAP.Search (LDAPEntry(..)) import Yesod.Default.Util (addStaticContentExternal) import Yesod.Core.Types (Logger) @@ -265,21 +268,29 @@ instance YesodAuth UniWorX where -- Override the above two destinations when a Referer: header is present redirectToReferer _ = True - authenticate Creds{..} = runDB $ do - let (plugin, ident) - | credsPlugin == "dummy" - , [dummyPlugin, dummyIdent] <- Text.splitOn ":" credsIdent - = (dummyPlugin, dummyIdent) - | otherwise - = (credsPlugin, credsIdent) - x <- getBy $ UniqueAuthentication plugin ident - case x of - Just (Entity uid _) -> return $ Authenticated uid - Nothing -> Authenticated <$> insert User - { userPlugin = plugin - , userIdent = ident - , userMatrikelnummer = "DummyMatrikel" - } + authenticate creds@(Creds{..}) = runDB $ do + let (userPlugin, userIdent) + | isDummy + , [dummyPlugin, dummyIdent] <- Text.splitOn ":" credsIdent + = (dummyPlugin, dummyIdent) + | otherwise + = (credsPlugin, credsIdent) + isDummy = credsPlugin == "dummy" + uAuth = UniqueAuthentication userPlugin userIdent + + $logDebugS "auth" $ tshow ((userPlugin, userIdent), creds) + + case isDummy of + True -> + maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth + False -> do + let + userMatrikelnummer = lookup "LMU-Stud-Matrikelnummer" credsExtra + + newUser = User{..} + userUpdate = [ UserMatrikelnummer =. userMatrikelnummer + ] + Authenticated . entityKey <$> upsertBy uAuth newUser userUpdate -- You can add other plugins like Google Email, email or OAuth here authPlugins app = [genericAuthLDAP $ ldapConfig app] ++ extraAuthPlugins @@ -290,14 +301,20 @@ instance YesodAuth UniWorX where ldapConfig :: UniWorX -> LDAPConfig ldapConfig app@(appSettings -> settings) = LDAPConfig - { usernameFilter = ("userPrincipalName=" <>) - , identifierModifier = \n _ -> n + { usernameFilter = \u -> principalName <> "=" <> u + , identifierModifier , ldapUri = appLDAPURI settings , initDN = appLDAPDN settings , initPass = appLDAPPw settings , baseDN = appLDAPBaseName settings , ldapScope = LdapScopeSubtree } + where + principalName :: IsString a => a + principalName = "userPrincipalName" + identifierModifier _ entry = case lookup principalName $ leattrs entry of + Just [n] -> Text.pack n + _ -> error "Could not determine user principal name" -- | Access function to determine if a user is logged in. isAuthenticated :: Handler AuthResult