Synchronise matrikelnummer from LDAP

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

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

models

@@ -1,7 +1,7 @@
 User
     plugin Text
     ident Text
-    matrikelnummer Text
+    matrikelnummer Text Maybe
     UniqueAuthentication plugin ident
 Term json
     name          TermIdentifier

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