diff --git a/models b/models index 4f016f828..792cc9b90 100644 --- a/models +++ b/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 diff --git a/package.yaml b/package.yaml index 536c40907..9d3b509b1 100644 --- a/package.yaml +++ b/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. diff --git a/src/Foundation.hs b/src/Foundation.hs index 9f853da68..d81828ca6 100644 --- a/src/Foundation.hs +++ b/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 - True -> + when isDummy . (throwError =<<) . lift $ maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth - False -> do - let - userMatrikelnummer = lookup "LMU-Stud-Matrikelnummer" credsExtra + + let + userMatrikelnummer = lookup "LMU-Stud-Matrikelnummer" credsExtra + userEmail' = lookup "mail" credsExtra + 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' - newUser = User{..} - userUpdate = [ UserMatrikelnummer =. userMatrikelnummer - ] - Authenticated . entityKey <$> upsertBy uAuth newUser userUpdate + 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 diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs new file mode 100644 index 000000000..467897ca1 --- /dev/null +++ b/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' diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 3365a8351..ee5048292 100644 --- a/src/Model/Types.hs +++ b/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"