Copy more information from LDAP on login

models

@@ -2,7 +2,26 @@ User
     plugin Text
     ident Text
     matrikelnummer Text Maybe
+    email Text
+    displayName Text
     UniqueAuthentication plugin ident
+StudyFeatures
+    user          UserId
+    degree        StudyDegreeId
+    field         StudyTermsId
+    type          StudyFieldType
+    semester      Int
+    UniqueUserSubject user degree field
+StudyDegree
+    key           Int
+    shorthand     Text Maybe
+    name          Text Maybe
+    Primary key
+StudyTerms
+    key           Int
+    shorthand     Text Maybe
+    name          Text Maybe
+    Primary key
 Term json
     name          TermIdentifier
     start         Day

package.yaml

@@ -74,6 +74,7 @@ dependencies:
 - conduit-resumablesink >=0.2
 - yesod-auth-ldap
 - LDAP
+- parsec
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.

src/Foundation.hs

@@ -45,6 +45,9 @@ import qualified Data.Text.Encoding as Text
 import Data.Conduit (($$))
 import Data.Conduit.List (sourceList)
 
+import Control.Monad.Except (MonadError(..), runExceptT)
+import Handler.Utils.StudyFeatures
+
 -- | The foundation datatype for your application. This can be a good place to
 -- keep settings and values requiring initialization before your application
 -- starts running, such as database connections. Every handler will have
@@ -268,7 +271,7 @@ instance YesodAuth UniWorX where
     -- Override the above two destinations when a Referer: header is present
     redirectToReferer _ = True
 
-    authenticate creds@(Creds{..}) = runDB $ do
+    authenticate creds@(Creds{..}) = runDB . fmap (either id id) . runExceptT $ do
       let (userPlugin, userIdent)
             | isDummy
             , [dummyPlugin, dummyIdent] <- Text.splitOn ":" credsIdent
@@ -280,17 +283,42 @@ instance YesodAuth UniWorX where
 
       $logDebugS "auth" $ tshow ((userPlugin, userIdent), creds)
 
-      case isDummy of
+      when isDummy . (throwError =<<) . lift $ 
-        True  ->
           maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
-        False -> do
-          let
-            userMatrikelnummer = lookup "LMU-Stud-Matrikelnummer" credsExtra
 
-            newUser = User{..}
+      let
-            userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
+        userMatrikelnummer = lookup "LMU-Stud-Matrikelnummer" credsExtra
-                         ]
+        userEmail' = lookup "mail" credsExtra
-          Authenticated . entityKey <$> upsertBy uAuth newUser userUpdate 
+        userDisplayName' = lookup "displayName" credsExtra
+
+      userEmail <- maybe (throwError $ ServerError "Could not retrieve user email") return userEmail'
+      userDisplayName <- maybe (throwError $ ServerError "Could not retrieve user name") return userDisplayName'
+            
+      let
+        newUser = User{..}
+        userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
+                     , UserDisplayName =. userDisplayName
+                     , UserEmail =. userEmail
+                     ]
+
+      userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate
+
+      let
+        userStudyFeatures = concat <$> mapM (parseStudyFeatures userId) userStudyFeatures'
+        userStudyFeatures' = [ v | (k, v) <- credsExtra, k == "dfnEduPersonFeaturesOfStudy" ]
+
+      fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures
+    
+      lift $ deleteWhere [StudyFeaturesUser ==. userId]
+
+      forM_ fs $ \StudyFeatures{..} -> do
+        lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
+        lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing
+              
+      lift $ insertMany_ fs
+      return $ Authenticated userId
+      where
+        insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
 
     -- You can add other plugins like Google Email, email or OAuth here
     authPlugins app = [genericAuthLDAP $ ldapConfig app] ++ extraAuthPlugins

src/Handler/Utils/StudyFeatures.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE NoImplicitPrelude
+           , RecordWildCards
+  #-}
+
+module Handler.Utils.StudyFeatures
+  ( parseStudyFeatures
+  ) where
+
+import Import.NoFoundation hiding (try, (<|>))
+
+import Data.Bifunctor
+
+import Text.Parsec
+import Text.Parsec.Text
+
+import Data.List (foldl')
+
+
+parseStudyFeatures :: UserId -> Text -> Either Text [StudyFeatures]
+parseStudyFeatures uId = first tshow . parse (pStudyFeatures uId <* eof) ""
+
+  
+pStudyFeatures :: UserId -> Parser [StudyFeatures]
+pStudyFeatures studyFeaturesUser = do
+  studyFeaturesDegree <- StudyDegreeKey' <$> pKey
+  void $ string "$$"
+
+  let
+    pStudyFeature = do
+      _ <- pKey -- Meaning unknown at this time
+      void $ char '!'
+      _ <- pKey -- Meaning unknown
+      void $ char '!'
+      studyFeaturesField <- StudyTermsKey' <$> pKey
+      void $ char '!'
+      studyFeaturesType <- pType
+      void $ char '!'
+      studyFeaturesSemester <- decimal
+
+      return StudyFeatures{..}
+
+  pStudyFeature `sepBy1` char '#'
+
+pKey :: Parser Int
+pKey = decimal
+
+pType :: Parser StudyFieldType
+pType = FieldPrimary   <$ (try $ string "HF")
+    <|> FieldSecondary <$ (try $ string "NF")
+
+decimal :: Parser Int
+decimal = foldl' (\now next -> now * 10 + next) 0 <$> many1 digit'
+  where
+    digit' = dVal <$> digit
+    dVal c = fromEnum c - fromEnum '0'

src/Model/Types.hs

@@ -126,3 +126,7 @@ time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100
     timeYear = fst3 $ toGregorian time      
     termYear = year term 
       
+
+data StudyFieldType = FieldPrimary | FieldSecondary
+  deriving (Eq, Ord, Enum, Show, Read, Bounded)
+derivePersistField "StudyFieldType"