diff --git a/messages/uniworx/categories/user/de-de-formal.msg b/messages/uniworx/categories/user/de-de-formal.msg
index 919f49587..923097b7c 100644
--- a/messages/uniworx/categories/user/de-de-formal.msg
+++ b/messages/uniworx/categories/user/de-de-formal.msg
@@ -8,6 +8,10 @@ AdminUserIdent: Identifikation
AdminUserAuth: Authentifizierung
AdminUserMatriculation: Matrikelnummer
AdminUserSex: Geschlecht
+AdminUserTelephone: Telefonnummer
+AdminUserMobile: Mobiltelefonmummer
+AdminUserFPersonalNumber: Personalnummer (nur Fraport AG)
+AdminUserFDepartment: Abteilung
AdminUserAssimilate: Benutzer assimilieren
UserAdded: Benutzer erfolgreich angelegt
UserCollision: Benutzer konnte wegen Eindeutigkeit nicht angelegt werden
diff --git a/messages/uniworx/categories/user/en-eu.msg b/messages/uniworx/categories/user/en-eu.msg
index 09bccc500..bd21fc1c6 100644
--- a/messages/uniworx/categories/user/en-eu.msg
+++ b/messages/uniworx/categories/user/en-eu.msg
@@ -8,6 +8,10 @@ AdminUserIdent: Identification
AdminUserAuth: Authentication
AdminUserMatriculation: Matriculation
AdminUserSex: Sex
+AdminUserTelephone: Phone
+AdminUserMobile: Mobile
+AdminUserFPersonalNumber: Personalnumber (Fraport AG only)
+AdminUserFDepartment: Department
AdminUserAssimilate: Assimilate user
UserAdded: Successfully added user
UserCollision: Could not create user due to uniqueness constraint
diff --git a/models/users.model b/models/users.model
index 28e336f8e..0960f9d57 100644
--- a/models/users.model
+++ b/models/users.model
@@ -19,7 +19,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create
lastLdapSynchronisation UTCTime Maybe
ldapPrimaryKey Text Maybe
tokensIssuedAfter UTCTime Maybe -- do not accept bearer tokens issued before this time (accept all tokens if null)
- matrikelnummer UserMatriculation Maybe -- optional immatriculation-string; usually a number, but not always (e.g. lecturers, pupils, guests,...)
+ matrikelnummer UserMatriculation Maybe -- usually a number; AVS Personalnummer; nicht Fraport Personalnummer!
firstName Text -- For export in tables, pre-split firstName from displayName
title Text Maybe -- For upcoming name customisation
maxFavourites Int default=12 -- max number of non-manual entries in favourites bar (pruned only if below a set importance threshold)
@@ -35,6 +35,10 @@ User json -- Each Uni2work user has a corresponding row in this table; create
csvOptions CsvOptions "default='{}'::jsonb"
sex Sex Maybe
showSex Bool default=false
+ telephone Text Maybe
+ mobile Text Maybe
+ companyPersonalNumber Text Maybe -- Company will become a new table, but if company=fraport, some information is received via LDAP
+ companyDepartment Text Maybe -- thus we store such information for ease of reference directly, if available
UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table
UniqueEmail email -- Column 'email' can be used as a row-key in this table
deriving Show Eq Ord Generic -- Haskell-specific settings for runtime-value representing a row in memory
@@ -63,7 +67,6 @@ UserSchool -- Managed by users themselves, encodes "schools of interest"
isOptOut Bool -- true if this a marker, that the user manually deleted this entry; it should not be recreated automatically
UniqueUserSchool user school
deriving Generic
-
UserGroupMember
group UserGroupName
user UserId
diff --git a/routes b/routes
index 76e11b5f0..152afe2b8 100644
--- a/routes
+++ b/routes
@@ -54,7 +54,6 @@
!/users/functionary-invite AdminFunctionaryInviteR GET POST
!/users/add AdminUserAddR GET POST
/admin AdminR GET
-/admin/features AdminFeaturesR GET POST
/admin/test AdminTestR GET POST
/admin/errMsg AdminErrMsgR GET POST
/admin/tokens AdminTokensR GET POST
diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs
index 6d6db7bce..f0f30bd7a 100644
--- a/src/Auth/LDAP.hs
+++ b/src/Auth/LDAP.hs
@@ -7,11 +7,12 @@ module Auth.LDAP
, campusUserReTest, campusUserReTest'
, campusUserMatr, campusUserMatr'
, CampusMessage(..)
+ , ldapPrimaryKey
, ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName
- , ldapUserMatriculation, ldapUserFirstName, ldapUserSurname
- , ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName
- , ldapUserSchoolAssociation, ldapUserSubTermsSemester, ldapSex
- , ldapAffiliation, ldapPrimaryKey
+ , ldapUserFirstName, ldapUserSurname
+ , ldapAffiliation
+ , ldapUserMobile, ldapUserTelephone
+ , ldapUserFraportPersonalnummer, ldapUserFraportAbteilung
) where
import Import.NoFoundation
@@ -47,21 +48,20 @@ findUser conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM
where
userFilters =
[ ldapUserPrincipalName Ldap.:= Text.encodeUtf8 ident
- , ldapUserPrincipalName Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|]
+ , ldapUserPrincipalName Ldap.:= Text.encodeUtf8 [st|#{ident}@fraport.de|]
] ++
[ ldapUserEmail' Ldap.:= Text.encodeUtf8 ident'
- | ident' <- [ident, [st|#{ident}@lmu.de|], [st|#{ident}@campus.lmu.de|]]
+ | ident' <- [ident, [st|#{ident}@lmu.de|], [st|#{ident}@fraport.de|]]
, ldapUserEmail' <- toList ldapUserEmail
] ++
[ ldapUserDisplayName Ldap.:= Text.encodeUtf8 ident
- , ldapUserMatriculation Ldap.:= Text.encodeUtf8 ident
]
findUserMatr :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
findUserMatr conf@LdapConf{..} ldap userMatr retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase $ userSearchSettings conf) retAttrs) userFilters
where
userFilters =
- [ ldapUserMatriculation Ldap.:= Text.encodeUtf8 userMatr
+ [ ldapUserFraportPersonalnummer Ldap.:= Text.encodeUtf8 userMatr
]
userSearchSettings :: LdapConf -> Ldap.Mod Ldap.Search
@@ -72,24 +72,32 @@ userSearchSettings LdapConf{..} = mconcat
, Ldap.derefAliases Ldap.DerefAlways
]
-ldapUserPrincipalName, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName, ldapUserSchoolAssociation, ldapSex, ldapUserSubTermsSemester, ldapAffiliation, ldapPrimaryKey :: Ldap.Attr
+ldapPrimaryKey, ldapUserPrincipalName, ldapUserDisplayName, ldapUserFirstName, ldapUserSurname, ldapAffiliation, ldapUserMobile, ldapUserTelephone, ldapUserFraportPersonalnummer, ldapUserFraportAbteilung :: Ldap.Attr
+ldapPrimaryKey = Ldap.Attr "cn" -- should always be identical to "sAMAccountName"
ldapUserPrincipalName = Ldap.Attr "userPrincipalName"
ldapUserDisplayName = Ldap.Attr "displayName"
-ldapUserMatriculation = Ldap.Attr "LMU-Stud-Matrikelnummer"
ldapUserFirstName = Ldap.Attr "givenName"
ldapUserSurname = Ldap.Attr "sn"
+ldapAffiliation = Ldap.Attr "memberOf" -- group determine user functions, see Handler.Utils.LdapSystemFunctions.determineSystemFunctions
+-- new
+ldapUserTelephone = Ldap.Attr "telephoneNumber"
+ldapUserMobile = Ldap.Attr "mobile"
+ldapUserFraportPersonalnummer = Ldap.Attr "sAMAccountName"
+ldapUserFraportAbteilung = Ldap.Attr "Department"
+
+{- --outdated to be removed
+ldapUserMatriculation = Ldap.Attr "LMU-Stud-Matrikelnummer"
ldapUserTitle = Ldap.Attr "title"
ldapUserStudyFeatures = Ldap.Attr "dfnEduPersonFeaturesOfStudy"
ldapUserFieldName = Ldap.Attr "LMU-Stg-Fach"
ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString"
ldapSex = Ldap.Attr "schacGender"
ldapUserSubTermsSemester = Ldap.Attr "LMU-Stg-FachundFS"
-ldapAffiliation = Ldap.Attr "eduPersonAffiliation"
-ldapPrimaryKey = Ldap.Attr "eduPersonPrincipalName"
+-}
ldapUserEmail :: NonEmpty Ldap.Attr
ldapUserEmail = Ldap.Attr "mail" :|
- [ Ldap.Attr "name"
+ [ Ldap.Attr "userPrincipalName"
]
diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs
index ebed962d2..d23cc21f7 100644
--- a/src/Foundation/Navigation.hs
+++ b/src/Foundation/Navigation.hs
@@ -99,7 +99,6 @@ breadcrumb AdminNewFunctionaryInviteR = i18nCrumb MsgMenuLecturerInvite $ Just U
breadcrumb AdminFunctionaryInviteR = i18nCrumb MsgBreadcrumbFunctionaryInvite Nothing
breadcrumb AdminR = i18nCrumb MsgAdminHeading Nothing
-breadcrumb AdminFeaturesR = i18nCrumb MsgAdminFeaturesHeading $ Just AdminR
breadcrumb AdminTestR = i18nCrumb MsgMenuAdminTest $ Just AdminR
breadcrumb AdminErrMsgR = i18nCrumb MsgMenuAdminErrMsg $ Just AdminR
breadcrumb AdminTokensR = i18nCrumb MsgMenuAdminTokens $ Just AdminR
@@ -695,14 +694,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
, navQuick' = mempty
, navForceActive = False
}
- , NavLink
- { navLabel = MsgMenuAdminFeaturesHeading
- , navRoute = AdminFeaturesR
- , navAccess' = NavAccessTrue
- , navType = NavTypeLink { navModal = False }
- , navQuick' = mempty
- , navForceActive = False
- }
, NavLink
{ navLabel = MsgMenuMessageList
, navRoute = MessageListR
diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs
index 29c77c654..b9d920751 100644
--- a/src/Foundation/Yesod/Auth.hs
+++ b/src/Foundation/Yesod/Auth.hs
@@ -12,8 +12,7 @@ import Foundation.Types
import Foundation.I18n
import Handler.Utils.Profile
-import Handler.Utils.StudyFeatures
-import Handler.Utils.SchoolLdap
+-- import Handler.Utils.SchoolLdap -- Delete this module?
import Handler.Utils.LdapSystemFunctions
import Handler.Utils.Memcached
import Foundation.Authorization (AuthorizationCacheKey(..))
@@ -28,21 +27,21 @@ 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.ByteString as ByteString
import qualified Data.Set as Set
-import qualified Data.Conduit.Combinators as C
+-- import qualified Data.Conduit.Combinators as C
-import qualified Data.List as List ((\\))
+-- 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 Data.UUID as UUID
+-- import Data.ByteArray (convert)
+-- import Crypto.Hash (SHAKE128)
+-- import qualified Data.Binary as Binary
-import qualified Database.Esqueleto.Legacy as E
-import qualified Database.Esqueleto.Utils as E
+-- import qualified Database.Esqueleto.Legacy as E
+-- import qualified Database.Esqueleto.Utils as E
-import Crypto.Hash.Conduit (sinkHash)
+-- import Crypto.Hash.Conduit (sinkHash)
authenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX
@@ -158,20 +157,22 @@ 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 ]
+ let
userEmail' = fold $ do
k' <- toList ldapUserEmail
(k, v) <- ldapData
guard $ k' == k
return v
+ -- SJ says: this highly repetitive code needs fefactoring; why not turn ldapData into a Data.Map right away instead of repetitive list iteration?
+ userLdapPrimaryKey' = fold [ v | (k, v) <- ldapData, k == ldapPrimaryKey ]
+ userIdent'' = fold [ v | (k, v) <- ldapData, k == ldapUserPrincipalName ]
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 ]
+ userTelephone' = fold [ v | (k, v) <- ldapData, k == ldapUserTelephone ]
+ userMobile' = fold [ v | (k, v) <- ldapData, k == ldapUserMobile ]
+ userFraportPersonalnummer' = fold [ v | (k, v) <- ldapData, k == ldapUserFraportPersonalnummer ]
+ userFraportAbteilung' = fold [ v | (k, v) <- ldapData, k == ldapUserFraportAbteilung ]
userAuthentication
| is _UpsertCampusUserLoginOther upsertMode
@@ -212,32 +213,31 @@ upsertCampusUser upsertMode ldapData = do
-> return userSurname
| otherwise
-> throwM CampusUserInvalidSurname
- userTitle <- if
- | all ByteString.null userTitle'
+ userTelephone <- if
+ | [bs] <- userTelephone'
+ , Right userTelephone <- Text.decodeUtf8' bs
+ -> return $ Just userTelephone
+ | otherwise
-> return Nothing
- | [bs] <- userTitle'
- , Right userTitle <- Text.decodeUtf8' bs
- -> return $ Just userTitle
+ userMobile <- if
+ | [bs] <- userMobile'
+ , Right userMobile <- Text.decodeUtf8' bs
+ -> return $ Just userMobile
| otherwise
- -> throwM CampusUserInvalidTitle
- userMatrikelnummer <- if
- | [bs] <- userMatrikelnummer'
- , Right userMatrikelnummer <- Text.decodeUtf8' bs
- -> return $ Just userMatrikelnummer
- | [] <- userMatrikelnummer'
-> return Nothing
+ userCompanyPersonalNumber <- if
+ | [bs] <- userFraportPersonalnummer'
+ , Right dt <- Text.decodeUtf8' bs
+ -> return $ Just dt
| 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
+ -> return Nothing
+ userCompanyDepartment <- if
+ | [bs] <- userFraportAbteilung'
+ , Right dt <- Text.decodeUtf8' bs
+ -> return $ Just dt
| otherwise
- -> throwM CampusUserInvalidSex
+ -> return Nothing
+
userLdapPrimaryKey <- if
| [bs] <- userLdapPrimaryKey'
, Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs
@@ -257,6 +257,7 @@ upsertCampusUser upsertMode ldapData = do
, userDownloadFiles = userDefaultDownloadFiles
, userWarningDays = userDefaultWarningDays
, userShowSex = userDefaultShowSex
+ , userSex = Nothing
, userNotificationSettings = def
, userLanguages = Nothing
, userCsvOptions = def
@@ -265,15 +266,15 @@ upsertCampusUser upsertMode ldapData = do
, userLastLdapSynchronisation = Just now
, userDisplayName = userDisplayName'
, userDisplayEmail = userEmail
+ , userMatrikelnummer = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
+ , userTitle = Nothing
, ..
}
- userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
- -- , UserDisplayName =. userDisplayName
- , UserFirstName =. userFirstName
- , UserSurname =. userSurname
- , UserTitle =. userTitle
- , UserEmail =. userEmail
- , UserSex =. userSex
+ userUpdate = [
+ -- UserDisplayName =. userDisplayName
+ UserFirstName =. userFirstName
+ , UserSurname =. userSurname
+ , UserEmail =. userEmail
, UserLastLdapSynchronisation =. Just now
, UserLdapPrimaryKey =. userLdapPrimaryKey
] ++
@@ -284,184 +285,9 @@ upsertCampusUser upsertMode ldapData = do
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) $
+ unless (validDisplayName Nothing 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 = nubOrdOn 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 = Nothing
- }
- (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
@@ -476,9 +302,7 @@ upsertCampusUser upsertMode ldapData = do
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 ())
+ return user
associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m ()
associateUserSchoolsByTerms uid = do
diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs
index 18be649b1..9752d878b 100644
--- a/src/Handler/Admin.hs
+++ b/src/Handler/Admin.hs
@@ -6,7 +6,6 @@ import Import
import Handler.Admin.Test as Handler.Admin
import Handler.Admin.ErrorMessage as Handler.Admin
-import Handler.Admin.StudyFeatures as Handler.Admin
import Handler.Admin.Tokens as Handler.Admin
import Handler.Admin.Crontab as Handler.Admin
diff --git a/src/Handler/Admin/StudyFeatures.hs b/src/Handler/Admin/StudyFeatures.hs
deleted file mode 100644
index ef6b7f051..000000000
--- a/src/Handler/Admin/StudyFeatures.hs
+++ /dev/null
@@ -1,533 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
-
-module Handler.Admin.StudyFeatures
- ( getAdminFeaturesR, postAdminFeaturesR
- ) where
-
-import Import
-import Handler.Utils
-
-import qualified Data.Text as Text
-
-import qualified Data.Set as Set
-import qualified Data.Map as Map
-
-import qualified Database.Esqueleto.Legacy as E
-import Database.Esqueleto.Utils (mkExactFilter, mkContainsFilter)
-
-import qualified Handler.Utils.TermCandidates as Candidates
-
-
-data ButtonAdminStudyTermsNames
- = BtnNameCandidatesInfer
- | BtnNameCandidatesDeleteConflicts
- | BtnNameCandidatesDeleteAll
- deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
-instance Universe ButtonAdminStudyTermsNames
-instance Finite ButtonAdminStudyTermsNames
-
-nullaryPathPiece ''ButtonAdminStudyTermsNames $ camelToPathPiece' 1
-embedRenderMessage ''UniWorX ''ButtonAdminStudyTermsNames id
-
-instance Button UniWorX ButtonAdminStudyTermsNames where
- btnClasses BtnNameCandidatesInfer = [BCIsButton, BCPrimary]
- btnClasses BtnNameCandidatesDeleteConflicts = [BCIsButton, BCDanger]
- btnClasses BtnNameCandidatesDeleteAll = [BCIsButton, BCDanger]
-
-data ButtonAdminStudyTermsParents
- = BtnParentCandidatesInfer
- | BtnParentCandidatesDeleteAll
- deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
-instance Universe ButtonAdminStudyTermsParents
-instance Finite ButtonAdminStudyTermsParents
-
-nullaryPathPiece ''ButtonAdminStudyTermsParents $ camelToPathPiece' 1
-embedRenderMessage ''UniWorX ''ButtonAdminStudyTermsParents id
-
-instance Button UniWorX ButtonAdminStudyTermsParents where
- btnClasses BtnParentCandidatesInfer = [BCIsButton, BCPrimary]
- btnClasses BtnParentCandidatesDeleteAll = [BCIsButton, BCDanger]
-
-data ButtonAdminStudyTermsStandalone
- = BtnStandaloneCandidatesDeleteRedundant
- | BtnStandaloneCandidatesDeleteAll
- deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
-instance Universe ButtonAdminStudyTermsStandalone
-instance Finite ButtonAdminStudyTermsStandalone
-
-nullaryPathPiece ''ButtonAdminStudyTermsStandalone $ camelToPathPiece' 1
-embedRenderMessage ''UniWorX ''ButtonAdminStudyTermsStandalone id
-
-instance Button UniWorX ButtonAdminStudyTermsStandalone where
- btnClasses BtnStandaloneCandidatesDeleteRedundant = [BCIsButton, BCPrimary]
- btnClasses BtnStandaloneCandidatesDeleteAll = [BCIsButton, BCDanger]
-
-
-{-# ANN postAdminFeaturesR ("HLint: ignore Redundant void" :: String) #-}
-getAdminFeaturesR, postAdminFeaturesR :: Handler Html
-getAdminFeaturesR = postAdminFeaturesR
-postAdminFeaturesR = do
- uid <- requireAuthId
- ((nameBtnResult, nameBtnWdgt), nameBtnEnctype) <- runFormPost $ identifyForm ("infer-names-button" :: Text) buttonForm
- let nameBtnForm = wrapForm nameBtnWdgt def
- { formAction = Just $ SomeRoute AdminFeaturesR
- , formEncoding = nameBtnEnctype
- , formSubmit = FormNoSubmit
- }
- infNameConflicts <- case nameBtnResult of
- FormSuccess BtnNameCandidatesInfer -> do
- (infConflicts, infAmbiguous, infRedundantNames, infAccepted) <- Candidates.inferNamesHandler
- unless (null infAmbiguous) . addMessageI Info . MsgAmbiguousNameCandidatesRemoved $ length infAmbiguous
- unless (null infRedundantNames) . addMessageI Info . MsgRedundantNameCandidatesRemoved $ length infRedundantNames
- unless (null infConflicts) $ do
- let badKeys = map entityKey infConflicts
- setSessionJson SessionConflictingStudyTerms badKeys
- addMessageI Warning MsgStudyFeatureConflict
-
- let newKeys = map fst infAccepted
- setSessionJson SessionNewStudyTerms newKeys
-
- if | null infAccepted
- -> addMessageI Info MsgNoNameCandidatesInferred
- | otherwise
- -> addMessageI Success . MsgNameCandidatesInferred $ length infAccepted
- redirect AdminFeaturesR
- FormSuccess BtnNameCandidatesDeleteConflicts -> do
- runDB $ do
- confs <- Candidates.nameConflicts
- incis <- Candidates.getNameIncidencesFor $ map entityKey confs
- deleteWhere [StudyTermNameCandidateIncidence <-. (E.unValue <$> incis)]
- addMessageI Success $ MsgIncidencesDeleted $ length incis
- redirect AdminFeaturesR
- FormSuccess BtnNameCandidatesDeleteAll -> do
- runDB $ do
- deleteWhere ([] :: [Filter StudyTermNameCandidate])
- addMessageI Success MsgAllNameIncidencesDeleted
- redirect AdminFeaturesR
- _other -> runDB Candidates.nameConflicts
-
- ((parentsBtnResult, parentsBtnWdgt), parentsBtnEnctype) <- runFormPost $ identifyForm ("infer-parents-button" :: Text) buttonForm
- let parentsBtnForm = wrapForm parentsBtnWdgt def
- { formAction = Just $ SomeRoute AdminFeaturesR
- , formEncoding = parentsBtnEnctype
- , formSubmit = FormNoSubmit
- }
- formResult parentsBtnResult $ \case
- BtnParentCandidatesInfer -> do
- (infRedundantParents, infAccepted) <- Candidates.inferParentsHandler
- unless (null infRedundantParents) . addMessageI Info . MsgRedundantParentCandidatesRemoved $ length infRedundantParents
-
- let newKeys = map (studySubTermsChild . entityVal) infAccepted
- setSessionJson SessionNewStudyTerms newKeys
-
- if | null infAccepted
- -> addMessageI Info MsgNoParentCandidatesInferred
- | otherwise
- -> addMessageI Success . MsgParentCandidatesInferred $ length infAccepted
- redirect AdminFeaturesR
- BtnParentCandidatesDeleteAll -> do
- runDB $ do
- deleteWhere ([] :: [Filter StudySubTermParentCandidate])
- addMessageI Success MsgAllParentIncidencesDeleted
- redirect AdminFeaturesR
-
- ((standaloneBtnResult, standaloneBtnWdgt), standaloneBtnEnctype) <- runFormPost $ identifyForm ("infer-standalone-button" :: Text) buttonForm
- let standaloneBtnForm = wrapForm standaloneBtnWdgt def
- { formAction = Just $ SomeRoute AdminFeaturesR
- , formEncoding = standaloneBtnEnctype
- , formSubmit = FormNoSubmit
- }
- formResult standaloneBtnResult $ \case
- BtnStandaloneCandidatesDeleteRedundant -> do
- infRedundantStandalone <- runDB Candidates.removeRedundantStandalone
- unless (null infRedundantStandalone) . addMessageI Info . MsgRedundantStandaloneCandidatesRemoved $ length infRedundantStandalone
- redirect AdminFeaturesR
- BtnStandaloneCandidatesDeleteAll -> do
- runDB $ do
- deleteWhere ([] :: [Filter StudyTermStandaloneCandidate])
- addMessageI Success MsgAllStandaloneIncidencesDeleted
- redirect AdminFeaturesR
-
-
- newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson SessionNewStudyTerms
- badStudyTermKeys <- lookupSessionJson SessionConflictingStudyTerms
- ( (degreeResult,degreeTable)
- , (studyTermsResult,studytermsTable)
- , ((), candidateTable)
- , userSchools
- , ((), parentCandidateTable)
- , (standaloneResult, standaloneCandidateTable)) <- runDB $ do
- schools <- E.select . E.from $ \school -> do
- E.where_ . E.exists . E.from $ \schoolFunction ->
- E.where_ $ schoolFunction E.^. UserFunctionSchool E.==. school E.^. SchoolId
- E.&&. schoolFunction E.^. UserFunctionUser E.==. E.val uid
- E.&&. schoolFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin
- return school
- (,,,,,)
- <$> mkDegreeTable
- <*> mkStudytermsTable (Set.fromList newStudyTermKeys)
- (Set.fromList $ fromMaybe (map entityKey infNameConflicts) badStudyTermKeys)
- (Set.fromList schools)
- <*> mkCandidateTable
- <*> pure schools
- <*> mkParentCandidateTable
- <*> mkStandaloneCandidateTable
-
- let degreeResult' :: FormResult (Map (Key StudyDegree) (Maybe Text, Maybe Text))
- degreeResult' = degreeResult <&> getDBFormResult
- (\row -> ( row ^. _dbrOutput . _entityVal . _studyDegreeName
- , row ^. _dbrOutput . _entityVal . _studyDegreeShorthand
- ))
- updateDegree degreeKey (name,short) = update degreeKey [StudyDegreeName =. name, StudyDegreeShorthand =. short]
- formResult degreeResult' $ \res -> do
- void . runDB $ Map.traverseWithKey updateDegree res
- addMessageI Success MsgStudyDegreeChangeSuccess
- redirect $ AdminFeaturesR :#: ("admin-studydegrees-table-wrapper" :: Text)
-
- let standaloneResult' :: FormResult (Map (Key StudyTermStandaloneCandidate) (Maybe StudyDegreeId, Maybe StudyFieldType))
- standaloneResult' = standaloneResult <&> getDBFormResult
- (\row -> ( row ^? _dbrOutput . _2 . _Just . _entityVal . _studyTermsDefaultDegree . _Just
- , row ^? _dbrOutput . _2 . _Just . _entityVal . _studyTermsDefaultType . _Just
- ))
- formResult standaloneResult' $ \res -> do
- updated <- runDB . iforM res $ \candidateId (mDegree, mType) -> do
- StudyTermStandaloneCandidate{..} <- getJust candidateId
- let termsId = StudyTermsKey' studyTermStandaloneCandidateKey
- updated <- case (,) <$> mDegree <*> mType of
- Nothing -> return Nothing
- Just (degree, typ) -> do
- ifM (existsKey termsId)
- ( update termsId
- [ StudyTermsDefaultDegree =. Just degree
- , StudyTermsDefaultType =. Just typ
- ]
- )
- ( insert_ $ StudyTerms studyTermStandaloneCandidateKey Nothing Nothing (Just degree) (Just typ)
- )
- return $ Just termsId
- infRedundantStandalone <- Candidates.removeRedundantStandalone
- unless (null infRedundantStandalone) . addMessageI Info . MsgRedundantStandaloneCandidatesRemoved $ length infRedundantStandalone
- return updated
-
- let newKeys = catMaybes $ Map.elems updated
- unless (null newKeys) $ do
- setSessionJson SessionNewStudyTerms newKeys
-
- redirect $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text)
-
-
- let studyTermsResult' :: FormResult (Map StudyTermsId (Maybe Text, Maybe Text, Set SchoolId, Set StudyTermsId, Maybe StudyDegreeId, Maybe StudyFieldType))
- studyTermsResult' = studyTermsResult <&> getDBFormResult
- (\row -> ( row ^? _dbrOutput . _1 . _entityVal . _studyTermsName . _Just
- , row ^? _dbrOutput . _1 . _entityVal . _studyTermsShorthand . _Just
- , row ^. _dbrOutput . _3
- , row ^. _dbrOutput . _2 . to (Set.map entityKey)
- , row ^? _dbrOutput . _1 . _entityVal . _studyTermsDefaultDegree . _Just
- , row ^? _dbrOutput . _1 . _entityVal . _studyTermsDefaultType . _Just
- ))
- updateStudyTerms studyTermsKey (name,short,schools,parents,degree,sType) = do
- degreeExists <- fmap (fromMaybe False) . for degree $ fmap (is _Just) . get
- update studyTermsKey [StudyTermsName =. name, StudyTermsShorthand =. short, StudyTermsDefaultDegree =. guard degreeExists *> degree, StudyTermsDefaultType =. sType]
-
- forM_ schools $ \ssh -> void . insertUnique $ SchoolTerms ssh studyTermsKey
- deleteWhere [SchoolTermsTerms ==. studyTermsKey, SchoolTermsSchool /<-. Set.toList schools, SchoolTermsSchool <-. toListOf (folded . _entityKey) userSchools]
-
- forM_ parents $ void . insertUnique . StudySubTerms studyTermsKey
- deleteWhere [StudySubTermsChild ==. studyTermsKey, StudySubTermsParent /<-. Set.toList parents]
- formResult studyTermsResult' $ \res -> do
- void . runDB $ Map.traverseWithKey updateStudyTerms res
- addMessageI Success MsgStudyTermsChangeSuccess
- redirect $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text)
-
- siteLayoutMsg MsgAdminFeaturesHeading $ do
- setTitleI MsgAdminFeaturesHeading
- $(widgetFile "adminFeatures")
- where
- textInputCell :: Ord i
- => Lens' a (Maybe Text)
- -> Getter (DBRow r) (Maybe Text)
- -> Getter (DBRow r) i
- -> DBRow r
- -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
- textInputCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
- (\row _mkUnique -> bimap (fmap $ set lensRes . assertM (not . Text.null)) fvWidget
- <$> mopt (textField & cfStrip) "" (Just $ row ^. lensDefault)
- )
-
- checkboxCell :: Ord i
- => Lens' a Bool
- -> Getter (DBRow r) Bool
- -> Getter (DBRow r) i
- -> DBRow r
- -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
- checkboxCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
- ( \row _mkUnique -> bimap (fmap $ set lensRes) fvWidget
- <$> mpopt checkBoxField "" (Just $ row ^. lensDefault)
- )
-
- -- termKeyCell :: Ord i
- -- => Lens' a (Maybe StudyTermsId)
- -- -> Getter (DBRow r) (Maybe StudyTermsId)
- -- -> Getter (DBRow r) i
- -- -> DBRow r
- -- -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
- -- termKeyCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
- -- ( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvWidget fieldView))
- -- <$> mopt (intField & isoField (from _StudyTermsId)) "" (Just $ row ^. lensDefault)
- -- )
-
- parentsCell :: Ord i
- => Lens' a (Set StudyTermsId)
- -> Getter (DBRow r) (Set StudyTermsId)
- -> Getter (DBRow r) i
- -> DBRow r
- -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
- parentsCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
- ( \row mkUnique -> bimap (fmap $ set lensRes . Set.fromList) fvWidget
- <$> massInputList
- (intField & isoField (from _StudyTermsId))
- (const "")
- MsgStudyTermsParentMissing
- (Just . SomeRoute . (AdminFeaturesR :#:))
- (mkUnique ("parents" :: Text))
- ""
- False
- (Just . Set.toList $ row ^. lensDefault)
- mempty
- )
-
- degreeCell :: Ord i
- => Lens' a (Maybe StudyDegreeId)
- -> Getter (DBRow r) (Maybe StudyDegreeId)
- -> Getter (DBRow r) i
- -> DBRow r
- -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
- degreeCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
- ( \row _mkUnique -> bimap (fmap $ set lensRes) fvWidget
- <$> mopt degreeField "" (Just $ row ^. lensDefault)
- )
-
- fieldTypeCell :: Ord i
- => Lens' a (Maybe StudyFieldType)
- -> Getter (DBRow r) (Maybe StudyFieldType)
- -> Getter (DBRow r) i
- -> DBRow r
- -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
- fieldTypeCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
- ( \row _mkUnique -> bimap (fmap $ set lensRes) fvWidget
- <$> mopt (selectField optionsFinite) "" (Just $ row ^. lensDefault)
- )
-
-
- mkDegreeTable :: DB (FormResult (DBFormResult (Key StudyDegree) (Maybe Text, Maybe Text) (DBRow (Entity StudyDegree))), Widget)
- mkDegreeTable =
- let dbtIdent = "admin-studydegrees" :: Text
- dbtStyle = def
- dbtSQLQuery :: E.SqlExpr (Entity StudyDegree) -> E.SqlQuery (E.SqlExpr (Entity StudyDegree))
- dbtSQLQuery = return
- dbtRowKey = (E.^. StudyDegreeKey)
- dbtProj = dbtProjId
- dbtColonnade = formColonnade $ mconcat
- [ sortable (Just "key") (i18nCell MsgGenericKey) (numCell . view (_dbrOutput . _entityVal . _studyDegreeKey))
- , sortable (Just "name") (i18nCell MsgTableDegreeName) (textInputCell _1 (_dbrOutput . _entityVal . _studyDegreeName) (_dbrOutput . _entityKey))
- , sortable (Just "short") (i18nCell MsgTableDegreeShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyDegreeShorthand) (_dbrOutput . _entityKey))
- ]
- dbtSorting = Map.fromList
- [ ("key" , SortColumn (E.^. StudyDegreeKey))
- , ("name" , SortColumn (E.^. StudyDegreeName))
- , ("short", SortColumn (E.^. StudyDegreeShorthand))
- ]
- dbtFilter = mempty
- dbtFilterUI = mempty
- dbtParams = def { dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studydegrees-table-wrapper" :: Text)
- }
- psValidator = def -- & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
- & defaultPagesize PagesizeAll
- & defaultSorting [SortAscBy "key"]
- dbtCsvEncode = noCsvEncode
- dbtCsvDecode = Nothing
- dbtExtraReps = []
- in dbTable psValidator DBTable{..}
-
- mkStudytermsTable :: Set StudyTermsId -> Set StudyTermsId -> Set (Entity School) -> DB (FormResult (DBFormResult StudyTermsId (Maybe Text, Maybe Text, Set SchoolId, Set StudyTermsId, Maybe StudyDegreeId, Maybe StudyFieldType) (DBRow (Entity StudyTerms, Set (Entity StudyTerms), Set SchoolId))), Widget)
- mkStudytermsTable newKeys badKeys schools =
- let dbtIdent = "admin-studyterms" :: Text
- dbtStyle = def
- dbtSQLQuery :: E.SqlExpr (Entity StudyTerms) -> E.SqlQuery (E.SqlExpr (Entity StudyTerms))
- dbtSQLQuery = return
- dbtRowKey = (E.^. StudyTermsKey)
- dbtProj = dbtProjSimple $ \field@(Entity fId _) -> do
- fieldSchools <- fmap (setOf $ folded . _Value) . E.select . E.from $ \school -> do
- E.where_ . E.exists . E.from $ \schoolTerms ->
- E.where_ $ schoolTerms E.^. SchoolTermsSchool E.==. school E.^. SchoolId
- E.&&. schoolTerms E.^. SchoolTermsTerms E.==. E.val fId
- E.where_ $ school E.^. SchoolShorthand `E.in_` E.valList (toListOf (folded . _entityKey . _SchoolId) schools)
- return $ school E.^. SchoolId
- fieldParents <- fmap (setOf folded) . E.select . E.from $ \terms -> do
- E.where_ . E.exists . E.from $ \subTerms ->
- E.where_ $ subTerms E.^. StudySubTermsChild E.==. E.val fId
- E.&&. subTerms E.^. StudySubTermsParent E.==. terms E.^. StudyTermsId
- return terms
- return (field, fieldParents, fieldSchools)
- dbtColonnade = formColonnade $ mconcat
- [ sortable (Just "key") (i18nCell MsgGenericKey) (maybe mempty numCell . preview (_dbrOutput . _1 . _entityVal . _studyTermsKey))
- , sortable Nothing (i18nCell MsgStudySubTermsParentKey) (parentsCell _4 (_dbrOutput . _2 . to (Set.map entityKey)) _dbrKey')
- , sortable (Just "isnew") (i18nCell MsgGenericIsNew) (isNewCell . flip Set.member newKeys . view (_dbrOutput . _1 . _entityKey))
- , sortable (Just "isbad") (i18nCell MsgGenericHasConflict) (isBadCell . flip Set.member badKeys . view (_dbrOutput . _1 . _entityKey))
- , sortable (Just "name") (i18nCell MsgStudyTermsName) (textInputCell _1 (_dbrOutput . _1 . _entityVal . _studyTermsName) _dbrKey')
- , sortable (Just "short") (i18nCell MsgStudyTermsShort) (textInputCell _2 (_dbrOutput . _1 . _entityVal . _studyTermsShorthand) _dbrKey')
- , sortable (Just "degree") (i18nCell MsgStudyTermsDefaultDegree) (degreeCell _5 (_dbrOutput . _1 . _entityVal . _studyTermsDefaultDegree) _dbrKey')
- , sortable (Just "field-type") (i18nCell MsgStudyTermsDefaultFieldType) (fieldTypeCell _6 (_dbrOutput . _1 . _entityVal . _studyTermsDefaultType) _dbrKey')
- , flip foldMap schools $ \(Entity ssh School{schoolName}) ->
- sortable Nothing (cell $ toWidget schoolName) (checkboxCell (_3 . at ssh . _Maybe) (_dbrOutput . _3 . at ssh . _Maybe) _dbrKey')
- ]
- dbtSorting = Map.fromList
- [ ("key" , SortColumn $ queryField >>> (E.^. StudyTermsKey))
- -- , ("parent", SortColumn $ \t -> querySubField t E.?. StudySubTermsParent)
- , ("isnew" , SortColumn $ queryField >>> (E.^. StudyTermsKey) >>> (`E.in_` E.valList (unStudyTermsKey <$> Set.toList newKeys))
- )
- , ("isbad" , SortColumn $ queryField >>> (E.^. StudyTermsKey) >>> (`E.in_` E.valList (unStudyTermsKey <$> Set.toList badKeys))
- )
- , ("name" , SortColumn $ queryField >>> (E.^. StudyTermsName))
- , ("short" , SortColumn $ queryField >>> (E.^. StudyTermsShorthand))
- , ("degree" , SortColumn $ queryField >>> (E.^. StudyTermsDefaultDegree))
- , ("field-type" , SortColumn $ queryField >>> (E.^. StudyTermsDefaultType))
- ]
- dbtFilter = mempty
- dbtFilterUI = mempty
- dbtParams = def { dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text)
- }
- psValidator = def
- & defaultPagesize PagesizeAll
- & defaultSorting [SortAscBy "isnew", SortAscBy "isbad", SortAscBy "key"]
- dbtCsvEncode = noCsvEncode
- dbtCsvDecode = Nothing
-
- dbtExtraReps = []
-
- queryField = id
- _dbrKey' :: Getter (DBRow (Entity StudyTerms, _, _)) StudyTermsId
- _dbrKey' = _dbrOutput . _1 . _entityKey
- in dbTable psValidator DBTable{..}
-
- mkCandidateTable =
- let dbtIdent = "admin-termcandidate" :: Text
- dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
- dbtSQLQuery :: E.SqlExpr (Entity StudyTermNameCandidate) -> E.SqlQuery ( E.SqlExpr (Entity StudyTermNameCandidate))
- dbtSQLQuery = return
- dbtRowKey = (E.^. StudyTermNameCandidateId)
- dbtProj = dbtProjId
- dbtColonnade = dbColonnade $ mconcat
- [ sortable (Just "key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _entityVal . _studyTermNameCandidateKey))
- , sortable (Just "name") (i18nCell MsgStudyTermsName) (textCell . view (_dbrOutput . _entityVal . _studyTermNameCandidateName))
- , sortable (Just "incidence") (i18nCell MsgStudyCandidateIncidence) (pathPieceCell . view (_dbrOutput . _entityVal . _studyTermNameCandidateIncidence))
- ]
- dbtSorting = Map.fromList
- [ ("key" , SortColumn (E.^. StudyTermNameCandidateKey))
- , ("name" , SortColumn (E.^. StudyTermNameCandidateName))
- , ("incidence", SortColumn (E.^. StudyTermNameCandidateIncidence))
- ]
- dbtFilter = Map.fromList
- [ ("key", FilterColumn $ mkExactFilter (E.^. StudyTermNameCandidateKey))
- , ("name", FilterColumn $ mkContainsFilter (E.^. StudyTermNameCandidateName))
- , ("incidence", FilterColumn $ mkExactFilter (E.^. StudyTermNameCandidateIncidence)) -- contains filter desired, but impossible here
- ]
- dbtFilterUI mPrev = mconcat
- [ prismAForm (singletonFilter "key" . maybePrism _PathPiece) mPrev $ aopt (intField :: Field _ Int) (fslI MsgStudyTermsKey)
- , prismAForm (singletonFilter "name") mPrev $ aopt textField (fslI MsgStudyTermsName)
- , prismAForm (singletonFilter "incidence") mPrev $ aopt textField (fslI MsgStudyCandidateIncidence)
- ]
- dbtParams = def
- psValidator = def & defaultSorting [SortAscBy "incidence", SortAscBy "key", SortAscBy "name"]
- dbtCsvEncode = noCsvEncode
- dbtCsvDecode = Nothing
- dbtExtraReps = []
- in dbTable psValidator DBTable{..}
-
- mkParentCandidateTable =
- let dbtIdent = "admin-termparentcandidate" :: Text
- dbtStyle = def
- dbtSQLQuery :: E.SqlExpr (Entity StudySubTermParentCandidate)
- `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity StudyTerms))
- `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity StudyTerms))
- -> E.SqlQuery ( E.SqlExpr (Entity StudySubTermParentCandidate)
- , E.SqlExpr (Maybe (Entity StudyTerms))
- , E.SqlExpr (Maybe (Entity StudyTerms))
- )
- dbtSQLQuery (candidate `E.LeftOuterJoin` parent `E.LeftOuterJoin` child) = do
- E.on $ child E.?. StudyTermsKey E.==. E.just (candidate E.^. StudySubTermParentCandidateKey)
- E.on $ parent E.?. StudyTermsKey E.==. E.just (candidate E.^. StudySubTermParentCandidateParent)
- return (candidate, parent, child)
- dbtRowKey = queryCandidate >>> (E.^. StudySubTermParentCandidateId)
- dbtProj = dbtProjId
- dbtColonnade = dbColonnade $ mconcat
- [ sortable (Just "child") (i18nCell MsgStudySubTermsChildKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studySubTermParentCandidateKey))
- , sortable (Just "child-name") (i18nCell MsgStudySubTermsChildName) (maybe mempty i18nCell . preview (_dbrOutput . _3 . _Just . _entityVal . _studyTermsName . _Just))
- , sortable (Just "parent") (i18nCell MsgStudySubTermsParentKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studySubTermParentCandidateParent))
- , sortable (Just "parent-name") (i18nCell MsgStudySubTermsParentName) (maybe mempty i18nCell . preview (_dbrOutput . _2 . _Just . _entityVal . _studyTermsName . _Just))
- , sortable (Just "incidence") (i18nCell MsgStudyCandidateIncidence) (pathPieceCell . view (_dbrOutput . _1 . _entityVal . _studySubTermParentCandidateIncidence))
- ]
- dbtSorting = Map.fromList
- [ ("child" , SortColumn $ queryCandidate >>> (E.^. StudySubTermParentCandidateKey))
- , ("child-name", SortColumn $ queryChild >>> (E.?. StudyTermsName) >>> E.joinV)
- , ("parent" , SortColumn $ queryCandidate >>> (E.^. StudySubTermParentCandidateParent))
- , ("parent-name", SortColumn $ queryParent >>> (E.?. StudyTermsName) >>> E.joinV)
- , ("incidence", SortColumn $ queryCandidate >>> (E.^. StudySubTermParentCandidateIncidence))
- ]
- dbtFilter = mempty
- dbtFilterUI = mempty
- dbtParams = def
- psValidator = def
- & defaultSorting [SortAscBy "child", SortAscBy "incidence", SortAscBy "parent"]
- dbtCsvEncode = noCsvEncode
- dbtCsvDecode = Nothing
-
- dbtExtraReps = []
-
- queryCandidate (c `E.LeftOuterJoin` _ `E.LeftOuterJoin` _) = c
- queryParent (_ `E.LeftOuterJoin` p `E.LeftOuterJoin` _) = p
- queryChild (_ `E.LeftOuterJoin` _ `E.LeftOuterJoin` c) = c
- in dbTable psValidator DBTable{..}
-
- mkStandaloneCandidateTable :: DB (FormResult (DBFormResult StudyTermStandaloneCandidateId (Maybe StudyDegreeId, Maybe StudyFieldType) (DBRow (Entity StudyTermStandaloneCandidate, Maybe (Entity StudyTerms)))), Widget)
- mkStandaloneCandidateTable =
- let dbtIdent = "admin-termstandalonecandidate" :: Text
- dbtStyle = def
- dbtSQLQuery :: E.SqlExpr (Entity StudyTermStandaloneCandidate)
- `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity StudyTerms))
- -> E.SqlQuery ( E.SqlExpr (Entity StudyTermStandaloneCandidate)
- , E.SqlExpr (Maybe (Entity StudyTerms))
- )
- dbtSQLQuery (candidate `E.LeftOuterJoin` sterm) = do
- E.on $ sterm E.?. StudyTermsKey E.==. E.just (candidate E.^. StudyTermStandaloneCandidateKey)
- return (candidate, sterm)
- dbtRowKey = queryCandidate >>> (E.^. StudyTermStandaloneCandidateId)
- dbtProj = dbtProjId
- dbtColonnade = formColonnade $ mconcat
- [ sortable (Just "key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studyTermStandaloneCandidateKey))
- , sortable (Just "name") (i18nCell MsgStudyTermsName) (maybe mempty i18nCell . preview (_dbrOutput . _2 . _Just . _entityVal . _studyTermsName . _Just))
- , sortable (Just "incidence") (i18nCell MsgStudyCandidateIncidence) (pathPieceCell . view (_dbrOutput . _1 . _entityVal . _studyTermStandaloneCandidateIncidence))
- , sortable Nothing (i18nCell MsgStudyTermsDefaultDegree) (degreeCell _1 (pre $ _dbrOutput . _2 . _Just . _studyTermsDefaultDegree . _Just) _dbrKey')
- , sortable Nothing (i18nCell MsgStudyTermsDefaultFieldType) (fieldTypeCell _2 (pre $ _dbrOutput . _2 . _Just . _studyTermsDefaultType . _Just) _dbrKey')
- ]
- dbtSorting = Map.fromList
- [ ("key" , SortColumn $ queryCandidate >>> (E.^. StudyTermStandaloneCandidateKey))
- , ("name" , SortColumn $ queryTerm >>> (E.?. StudyTermsName) >>> E.joinV)
- , ("incidence", SortColumn $ queryCandidate >>> (E.^. StudyTermStandaloneCandidateIncidence))
- ]
- dbtFilter = mempty
- dbtFilterUI = mempty
- dbtParams = def { dbParamsFormAction = Just . SomeRoute $ AdminFeaturesR :#: ("admin-studyterms-table-wrapper" :: Text)
- }
- psValidator = def
- & defaultSorting [SortAscBy "key", SortAscBy "incidence"]
- dbtCsvEncode = noCsvEncode
- dbtCsvDecode = Nothing
-
- dbtExtraReps = []
-
- queryCandidate (c `E.LeftOuterJoin` _) = c
- queryTerm (_ `E.LeftOuterJoin` t) = t
- _dbrKey' :: Getter (DBRow (Entity StudyTermStandaloneCandidate, _)) StudyTermStandaloneCandidateId
- _dbrKey' = _dbrOutput . _1 . _entityKey
- in dbTable psValidator DBTable{..}
diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs
index ed31be102..d4c7194cd 100644
--- a/src/Handler/Health.hs
+++ b/src/Handler/Health.hs
@@ -113,7 +113,7 @@ getStatusR = do
Current Time #{show currtime}
- Compile Time #{show comptime}
+ Compile Time #{comptime}
$maybe ctime <- readMay comptime
Build is #{show $ ddays ctime currtime} days old
diff --git a/src/Handler/Users/Add.hs b/src/Handler/Users/Add.hs
index 01196e7ec..3ef62f811 100644
--- a/src/Handler/Users/Add.hs
+++ b/src/Handler/Users/Add.hs
@@ -19,9 +19,13 @@ data AdminUserForm = AdminUserForm
, aufDisplayEmail :: UserEmail
, aufMatriculation :: Maybe UserMatriculation
, aufSex :: Maybe Sex
+ , aufMobile :: Maybe Text
+ , aufTelephone :: Maybe Text
+ , aufFPersonalNumber :: Maybe Text
+ , aufFDepartment :: Maybe Text
, aufEmail :: UserEmail
, aufIdent :: UserIdent
- , aufAuth :: AuthenticationKind
+ , aufAuth :: AuthenticationKind
}
data AuthenticationKind = AuthKindLDAP | AuthKindPWHash
@@ -49,6 +53,10 @@ adminUserForm template = renderAForm FormStandard
<*> areq (emailField & cfCI) (fslI MsgAdminUserDisplayEmail) (aufDisplayEmail <$> template)
<*> aopt (textField & cfStrip) (fslI MsgAdminUserMatriculation) (aufMatriculation <$> template)
<*> aopt (selectField optionsFinite) (fslI MsgAdminUserSex) (aufSex <$> template)
+ <*> aopt (textField & cfStrip) (fslI MsgAdminUserMobile) (aufMobile <$> template)
+ <*> aopt (textField & cfStrip) (fslI MsgAdminUserTelephone) (aufTelephone <$> template)
+ <*> aopt (textField & cfStrip) (fslI MsgAdminUserFPersonalNumber) (aufFPersonalNumber <$> template)
+ <*> aopt (textField & cfStrip) (fslI MsgAdminUserFDepartment) (aufFDepartment <$> template)
<*> areq (emailField & cfCI) (fslI MsgAdminUserEmail) (aufEmail <$> template)
<*> areq (textField & cfStrip & cfCI) (fslI MsgAdminUserIdent) (aufIdent <$> template)
<*> areq (selectField optionsFinite) (fslI MsgAdminUserAuth) (aufAuth <$> template <|> Just AuthKindLDAP)
@@ -89,7 +97,11 @@ postAdminUserAddR = do
, userFirstName = aufFirstName
, userSurname = aufSurname
, userTitle = aufTitle
- , userSex = aufSex
+ , userSex = aufSex
+ , userMobile = aufMobile
+ , userTelephone = aufTelephone
+ , userCompanyPersonalNumber = aufFPersonalNumber
+ , userCompanyDepartment = aufFDepartment
, userMatrikelnummer = aufMatriculation
, userAuthentication = mkAuthMode aufAuth
}
diff --git a/src/Handler/Utils/LdapSystemFunctions.hs b/src/Handler/Utils/LdapSystemFunctions.hs
index 8bd2d6c97..913ddb503 100644
--- a/src/Handler/Utils/LdapSystemFunctions.hs
+++ b/src/Handler/Utils/LdapSystemFunctions.hs
@@ -10,5 +10,6 @@ import qualified Data.Set as Set
determineSystemFunctions :: Set (CI Text) -> (SystemFunction -> Bool)
determineSystemFunctions ldapFuncs = \case
SystemExamOffice -> False
- SystemFaculty -> "faculty" `Set.member` ldapFuncs
- SystemStudent -> "student" `Set.member` ldapFuncs
+ SystemFaculty -> "CN=PROJ-Fahrerausbildung Admin_rw,OU=Projekte,OU=Sicherheitsgruppen,DC=fra,DC=fraport,DC=de" `Set.member` ldapFuncs -- Fahrerausbildungadmins are lecturers
+ -- SJ: not sure this LDAP-specific key belongs here?
+ SystemStudent -> False -- "student" `Set.member` ldapFuncs -- no such key identified at FraPort
diff --git a/src/Handler/Utils/SchoolLdap.hs b/src/Handler/Utils/SchoolLdap.hs
index b8e9bcbf8..2bfc991f3 100644
--- a/src/Handler/Utils/SchoolLdap.hs
+++ b/src/Handler/Utils/SchoolLdap.hs
@@ -11,7 +11,7 @@ import qualified Data.CaseInsensitive as CI
import qualified Data.Set as Set
-
+{- PROBALY DEPRECATED -}
parseLdapSchools :: Text -> Either ParseError (Set (CI Text))
parseLdapSchools = parse pLdapSchools ""
diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs
index ef0d0a2e6..992334b2c 100644
--- a/src/Handler/Utils/StudyFeatures.hs
+++ b/src/Handler/Utils/StudyFeatures.hs
@@ -1,6 +1,5 @@
module Handler.Utils.StudyFeatures
- ( module Handler.Utils.StudyFeatures.Parse
- , UserTableStudyFeature(..)
+ ( UserTableStudyFeature(..)
, _userTableField, _userTableDegree, _userTableSemester, _userTableFieldType
, UserTableStudyFeatures(..)
, _UserTableStudyFeatures
@@ -18,8 +17,6 @@ import Foundation.I18n
import Utils.Term
-import Handler.Utils.StudyFeatures.Parse
-
import qualified Data.Csv as Csv
import qualified Data.Set as Set
diff --git a/src/Handler/Utils/StudyFeatures/Parse.hs b/src/Handler/Utils/StudyFeatures/Parse.hs
deleted file mode 100644
index 516dd1b95..000000000
--- a/src/Handler/Utils/StudyFeatures/Parse.hs
+++ /dev/null
@@ -1,71 +0,0 @@
-module Handler.Utils.StudyFeatures.Parse
- ( parseStudyFeatures
- , parseSubTermsSemester
- ) where
-
-import Import.NoFoundation hiding (try, (<|>))
-
-import Text.Parsec
-import Text.Parsec.Text
-
-import Auth.LDAP (ldapUserSubTermsSemester, ldapUserStudyFeatures)
-import qualified Ldap.Client as Ldap
-
-
-parseStudyFeatures :: UserId -> UTCTime -> Text -> Either ParseError [StudyFeatures]
-parseStudyFeatures uId now = parse (pStudyFeatures uId now <* eof) (unpack key)
- where
- Ldap.Attr key = ldapUserStudyFeatures
-
-parseSubTermsSemester :: Text -> Either ParseError (StudyTermsId, Int)
-parseSubTermsSemester = parse (pLMUTermsSemester <* eof) (unpack key)
- where
- Ldap.Attr key = ldapUserSubTermsSemester
-
-
-pStudyFeatures :: UserId -> UTCTime -> Parser [StudyFeatures]
-pStudyFeatures studyFeaturesUser now = do
- studyFeaturesDegree <- StudyDegreeKey' <$> pKey
- void $ string "$$"
-
- let
- pStudyFeature = do
- _ <- pKey -- "Fächergruppe"
- void $ char '!'
- _ <- pKey -- "Studienbereich"
- void $ char '!'
- studyFeaturesField <- StudyTermsKey' <$> pKey
- void $ char '!'
- studyFeaturesType <- pType
- void $ char '!'
- studyFeaturesSemester <- decimal
- let studyFeaturesValid = True
- studyFeaturesSuperField = Nothing
- studyFeaturesFirstObserved = Just now
- studyFeaturesLastObserved = now
- studyFeaturesRelevanceCached = Nothing
- 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'
-
-
-pLMUTermsSemester :: Parser (StudyTermsId, Int)
-pLMUTermsSemester = do
- subTermsKey <- StudyTermsKey' <$> pKey
- void $ char '$'
- semester <- decimal
-
- return (subTermsKey, semester)
diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs
index b2a839e1c..5d87e8989 100644
--- a/test/Database/Fill.hs
+++ b/test/Database/Fill.hs
@@ -105,6 +105,10 @@ fillDb = do
, userCsvOptions = def { csvFormat = csvPreset # CsvPresetRFC }
, userSex = Just SexMale
, userShowSex = userDefaultShowSex
+ , userTelephone = Nothing
+ , userMobile = Nothing
+ , userCompanyPersonalNumber = Nothing
+ , userCompanyDepartment = Nothing
}
fhamann <- insert User
{ userIdent = "felix.hamann@campus.lmu.de"
@@ -134,6 +138,10 @@ fillDb = do
, userCsvOptions = def { csvFormat = csvPreset # CsvPresetExcel }
, userSex = Just SexMale
, userShowSex = userDefaultShowSex
+ , userMobile = Nothing
+ , userTelephone = Nothing
+ , userCompanyPersonalNumber = Nothing
+ , userCompanyDepartment = Nothing
}
pwSimple <- do
let pw = "123.456"
@@ -169,6 +177,10 @@ fillDb = do
, userSex = Just SexMale
, userCsvOptions = def
, userShowSex = userDefaultShowSex
+ , userTelephone = Just "+49 69 690-71706"
+ , userMobile = Just "0173 69 99 646"
+ , userCompanyPersonalNumber = Just "57138"
+ , userCompanyDepartment = Just "AVN-AR2"
}
maxMuster <- insert User
{ userIdent = "max@campus.lmu.de"
@@ -198,6 +210,10 @@ fillDb = do
, userCsvOptions = def
, userSex = Just SexMale
, userShowSex = userDefaultShowSex
+ , userTelephone = Nothing
+ , userMobile = Nothing
+ , userCompanyPersonalNumber = Nothing
+ , userCompanyDepartment = Nothing
}
tinaTester <- insert $ User
{ userIdent = "tester@campus.lmu.de"
@@ -227,6 +243,10 @@ fillDb = do
, userCsvOptions = def
, userSex = Just SexNotApplicable
, userShowSex = userDefaultShowSex
+ , userTelephone = Nothing
+ , userMobile = Nothing
+ , userCompanyPersonalNumber = Nothing
+ , userCompanyDepartment = Nothing
}
svaupel <- insert User
{ userIdent = "vaupel.sarah@campus.lmu.de"
@@ -256,6 +276,10 @@ fillDb = do
, userCsvOptions = def
, userSex = Just SexFemale
, userShowSex = userDefaultShowSex
+ , userTelephone = Nothing
+ , userMobile = Nothing
+ , userCompanyPersonalNumber = Nothing
+ , userCompanyDepartment = Nothing
}
sbarth <- insert User
{ userIdent = "Stephan.Barth@campus.lmu.de"
@@ -285,6 +309,10 @@ fillDb = do
, userCsvOptions = def
, userSex = Just SexMale
, userShowSex = userDefaultShowSex
+ , userTelephone = Nothing
+ , userMobile = Nothing
+ , userCompanyPersonalNumber = Nothing
+ , userCompanyDepartment = Nothing
}
let
@@ -344,6 +372,10 @@ fillDb = do
, userCsvOptions = def
, userSex = Nothing
, userShowSex = userDefaultShowSex
+ , userTelephone = Nothing
+ , userMobile = Nothing
+ , userCompanyPersonalNumber = Nothing
+ , userCompanyDepartment = Nothing
}
where
userIdent :: IsString t => t
diff --git a/test/ModelSpec.hs b/test/ModelSpec.hs
index 66b90b480..314acd80a 100644
--- a/test/ModelSpec.hs
+++ b/test/ModelSpec.hs
@@ -128,6 +128,10 @@ instance Arbitrary User where
userNotificationSettings <- arbitrary
userCsvOptions <- arbitrary
userShowSex <- arbitrary
+ userMobile <- fmap pack . assertM' (not . null) <$> listOf (elements $ [' ', '+', '-', '/', '_'] ++ ['0'..'9'])
+ userTelephone <- fmap pack . assertM' (not . null) <$> listOf (elements $ [' ', '+', '-', '/', '_'] ++ ['0'..'9'])
+ userCompanyPersonalNumber <- fmap pack . assertM' (not . null) <$> listOf (elements ['0'..'9'])
+ userCompanyDepartment <- arbitrary
userCreated <- arbitrary
userLastLdapSynchronisation <- arbitrary
diff --git a/test/User.hs b/test/User.hs
index 35ba6a848..35c195870 100644
--- a/test/User.hs
+++ b/test/User.hs
@@ -43,3 +43,7 @@ fakeUser adjUser = adjUser User{..}
userCreated = unsafePerformIO getCurrentTime
userLastLdapSynchronisation = Nothing
userLdapPrimaryKey = Nothing
+ userMobile = Nothing
+ userTelephone = Nothing
+ userCompanyPersonalNumber = Nothing
+ userCompanyDepartment = Nothing