Merge branch 'fix/ldap' into 'master'
Fix/ldap See merge request FraDrive/fradrive!6
This commit is contained in:
Steffen Jost
commit
c54bacbee0
@ -8,6 +8,10 @@ AdminUserIdent: Identifikation
|
|||||||
AdminUserAuth: Authentifizierung
|
AdminUserAuth: Authentifizierung
|
||||||
AdminUserMatriculation: Matrikelnummer
|
AdminUserMatriculation: Matrikelnummer
|
||||||
AdminUserSex: Geschlecht
|
AdminUserSex: Geschlecht
|
||||||
|
AdminUserTelephone: Telefonnummer
|
||||||
|
AdminUserMobile: Mobiltelefonmummer
|
||||||
|
AdminUserFPersonalNumber: Personalnummer (nur Fraport AG)
|
||||||
|
AdminUserFDepartment: Abteilung
|
||||||
AdminUserAssimilate: Benutzer assimilieren
|
AdminUserAssimilate: Benutzer assimilieren
|
||||||
UserAdded: Benutzer erfolgreich angelegt
|
UserAdded: Benutzer erfolgreich angelegt
|
||||||
UserCollision: Benutzer konnte wegen Eindeutigkeit nicht angelegt werden
|
UserCollision: Benutzer konnte wegen Eindeutigkeit nicht angelegt werden
|
||||||
|
|||||||
@ -8,6 +8,10 @@ AdminUserIdent: Identification
|
|||||||
AdminUserAuth: Authentication
|
AdminUserAuth: Authentication
|
||||||
AdminUserMatriculation: Matriculation
|
AdminUserMatriculation: Matriculation
|
||||||
AdminUserSex: Sex
|
AdminUserSex: Sex
|
||||||
|
AdminUserTelephone: Phone
|
||||||
|
AdminUserMobile: Mobile
|
||||||
|
AdminUserFPersonalNumber: Personalnumber (Fraport AG only)
|
||||||
|
AdminUserFDepartment: Department
|
||||||
AdminUserAssimilate: Assimilate user
|
AdminUserAssimilate: Assimilate user
|
||||||
UserAdded: Successfully added user
|
UserAdded: Successfully added user
|
||||||
UserCollision: Could not create user due to uniqueness constraint
|
UserCollision: Could not create user due to uniqueness constraint
|
||||||
|
|||||||
@ -19,7 +19,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create
|
|||||||
lastLdapSynchronisation UTCTime Maybe
|
lastLdapSynchronisation UTCTime Maybe
|
||||||
ldapPrimaryKey Text Maybe
|
ldapPrimaryKey Text Maybe
|
||||||
tokensIssuedAfter UTCTime Maybe -- do not accept bearer tokens issued before this time (accept all tokens if null)
|
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
|
firstName Text -- For export in tables, pre-split firstName from displayName
|
||||||
title Text Maybe -- For upcoming name customisation
|
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)
|
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"
|
csvOptions CsvOptions "default='{}'::jsonb"
|
||||||
sex Sex Maybe
|
sex Sex Maybe
|
||||||
showSex Bool default=false
|
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
|
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
|
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
|
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
|
isOptOut Bool -- true if this a marker, that the user manually deleted this entry; it should not be recreated automatically
|
||||||
UniqueUserSchool user school
|
UniqueUserSchool user school
|
||||||
deriving Generic
|
deriving Generic
|
||||||
|
|
||||||
UserGroupMember
|
UserGroupMember
|
||||||
group UserGroupName
|
group UserGroupName
|
||||||
user UserId
|
user UserId
|
||||||
|
|||||||
1
routes
1
routes
@ -54,7 +54,6 @@
|
|||||||
!/users/functionary-invite AdminFunctionaryInviteR GET POST
|
!/users/functionary-invite AdminFunctionaryInviteR GET POST
|
||||||
!/users/add AdminUserAddR GET POST
|
!/users/add AdminUserAddR GET POST
|
||||||
/admin AdminR GET
|
/admin AdminR GET
|
||||||
/admin/features AdminFeaturesR GET POST
|
|
||||||
/admin/test AdminTestR GET POST
|
/admin/test AdminTestR GET POST
|
||||||
/admin/errMsg AdminErrMsgR GET POST
|
/admin/errMsg AdminErrMsgR GET POST
|
||||||
/admin/tokens AdminTokensR GET POST
|
/admin/tokens AdminTokensR GET POST
|
||||||
|
|||||||
@ -7,11 +7,12 @@ module Auth.LDAP
|
|||||||
, campusUserReTest, campusUserReTest'
|
, campusUserReTest, campusUserReTest'
|
||||||
, campusUserMatr, campusUserMatr'
|
, campusUserMatr, campusUserMatr'
|
||||||
, CampusMessage(..)
|
, CampusMessage(..)
|
||||||
|
, ldapPrimaryKey
|
||||||
, ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName
|
, ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName
|
||||||
, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname
|
, ldapUserFirstName, ldapUserSurname
|
||||||
, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName
|
, ldapAffiliation
|
||||||
, ldapUserSchoolAssociation, ldapUserSubTermsSemester, ldapSex
|
, ldapUserMobile, ldapUserTelephone
|
||||||
, ldapAffiliation, ldapPrimaryKey
|
, ldapUserFraportPersonalnummer, ldapUserFraportAbteilung
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Import.NoFoundation
|
import Import.NoFoundation
|
||||||
@ -47,21 +48,20 @@ findUser conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM
|
|||||||
where
|
where
|
||||||
userFilters =
|
userFilters =
|
||||||
[ ldapUserPrincipalName Ldap.:= Text.encodeUtf8 ident
|
[ 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'
|
[ 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
|
, ldapUserEmail' <- toList ldapUserEmail
|
||||||
] ++
|
] ++
|
||||||
[ ldapUserDisplayName Ldap.:= Text.encodeUtf8 ident
|
[ ldapUserDisplayName Ldap.:= Text.encodeUtf8 ident
|
||||||
, ldapUserMatriculation Ldap.:= Text.encodeUtf8 ident
|
|
||||||
]
|
]
|
||||||
|
|
||||||
findUserMatr :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
|
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
|
findUserMatr conf@LdapConf{..} ldap userMatr retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase $ userSearchSettings conf) retAttrs) userFilters
|
||||||
where
|
where
|
||||||
userFilters =
|
userFilters =
|
||||||
[ ldapUserMatriculation Ldap.:= Text.encodeUtf8 userMatr
|
[ ldapUserFraportPersonalnummer Ldap.:= Text.encodeUtf8 userMatr
|
||||||
]
|
]
|
||||||
|
|
||||||
userSearchSettings :: LdapConf -> Ldap.Mod Ldap.Search
|
userSearchSettings :: LdapConf -> Ldap.Mod Ldap.Search
|
||||||
@ -72,24 +72,32 @@ userSearchSettings LdapConf{..} = mconcat
|
|||||||
, Ldap.derefAliases Ldap.DerefAlways
|
, 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"
|
ldapUserPrincipalName = Ldap.Attr "userPrincipalName"
|
||||||
ldapUserDisplayName = Ldap.Attr "displayName"
|
ldapUserDisplayName = Ldap.Attr "displayName"
|
||||||
ldapUserMatriculation = Ldap.Attr "LMU-Stud-Matrikelnummer"
|
|
||||||
ldapUserFirstName = Ldap.Attr "givenName"
|
ldapUserFirstName = Ldap.Attr "givenName"
|
||||||
ldapUserSurname = Ldap.Attr "sn"
|
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"
|
ldapUserTitle = Ldap.Attr "title"
|
||||||
ldapUserStudyFeatures = Ldap.Attr "dfnEduPersonFeaturesOfStudy"
|
ldapUserStudyFeatures = Ldap.Attr "dfnEduPersonFeaturesOfStudy"
|
||||||
ldapUserFieldName = Ldap.Attr "LMU-Stg-Fach"
|
ldapUserFieldName = Ldap.Attr "LMU-Stg-Fach"
|
||||||
ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString"
|
ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString"
|
||||||
ldapSex = Ldap.Attr "schacGender"
|
ldapSex = Ldap.Attr "schacGender"
|
||||||
ldapUserSubTermsSemester = Ldap.Attr "LMU-Stg-FachundFS"
|
ldapUserSubTermsSemester = Ldap.Attr "LMU-Stg-FachundFS"
|
||||||
ldapAffiliation = Ldap.Attr "eduPersonAffiliation"
|
-}
|
||||||
ldapPrimaryKey = Ldap.Attr "eduPersonPrincipalName"
|
|
||||||
|
|
||||||
ldapUserEmail :: NonEmpty Ldap.Attr
|
ldapUserEmail :: NonEmpty Ldap.Attr
|
||||||
ldapUserEmail = Ldap.Attr "mail" :|
|
ldapUserEmail = Ldap.Attr "mail" :|
|
||||||
[ Ldap.Attr "name"
|
[ Ldap.Attr "userPrincipalName"
|
||||||
]
|
]
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@ -99,7 +99,6 @@ breadcrumb AdminNewFunctionaryInviteR = i18nCrumb MsgMenuLecturerInvite $ Just U
|
|||||||
breadcrumb AdminFunctionaryInviteR = i18nCrumb MsgBreadcrumbFunctionaryInvite Nothing
|
breadcrumb AdminFunctionaryInviteR = i18nCrumb MsgBreadcrumbFunctionaryInvite Nothing
|
||||||
|
|
||||||
breadcrumb AdminR = i18nCrumb MsgAdminHeading Nothing
|
breadcrumb AdminR = i18nCrumb MsgAdminHeading Nothing
|
||||||
breadcrumb AdminFeaturesR = i18nCrumb MsgAdminFeaturesHeading $ Just AdminR
|
|
||||||
breadcrumb AdminTestR = i18nCrumb MsgMenuAdminTest $ Just AdminR
|
breadcrumb AdminTestR = i18nCrumb MsgMenuAdminTest $ Just AdminR
|
||||||
breadcrumb AdminErrMsgR = i18nCrumb MsgMenuAdminErrMsg $ Just AdminR
|
breadcrumb AdminErrMsgR = i18nCrumb MsgMenuAdminErrMsg $ Just AdminR
|
||||||
breadcrumb AdminTokensR = i18nCrumb MsgMenuAdminTokens $ 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
|
, navQuick' = mempty
|
||||||
, navForceActive = False
|
, navForceActive = False
|
||||||
}
|
}
|
||||||
, NavLink
|
|
||||||
{ navLabel = MsgMenuAdminFeaturesHeading
|
|
||||||
, navRoute = AdminFeaturesR
|
|
||||||
, navAccess' = NavAccessTrue
|
|
||||||
, navType = NavTypeLink { navModal = False }
|
|
||||||
, navQuick' = mempty
|
|
||||||
, navForceActive = False
|
|
||||||
}
|
|
||||||
, NavLink
|
, NavLink
|
||||||
{ navLabel = MsgMenuMessageList
|
{ navLabel = MsgMenuMessageList
|
||||||
, navRoute = MessageListR
|
, navRoute = MessageListR
|
||||||
|
|||||||
@ -12,8 +12,7 @@ import Foundation.Types
|
|||||||
import Foundation.I18n
|
import Foundation.I18n
|
||||||
|
|
||||||
import Handler.Utils.Profile
|
import Handler.Utils.Profile
|
||||||
import Handler.Utils.StudyFeatures
|
-- import Handler.Utils.SchoolLdap -- Delete this module?
|
||||||
import Handler.Utils.SchoolLdap
|
|
||||||
import Handler.Utils.LdapSystemFunctions
|
import Handler.Utils.LdapSystemFunctions
|
||||||
import Handler.Utils.Memcached
|
import Handler.Utils.Memcached
|
||||||
import Foundation.Authorization (AuthorizationCacheKey(..))
|
import Foundation.Authorization (AuthorizationCacheKey(..))
|
||||||
@ -28,21 +27,21 @@ import qualified Control.Monad.Catch as C (Handler(..))
|
|||||||
import qualified Ldap.Client as Ldap
|
import qualified Ldap.Client as Ldap
|
||||||
import qualified Data.Text as Text
|
import qualified Data.Text as Text
|
||||||
import qualified Data.Text.Encoding 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.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 qualified Data.UUID as UUID
|
||||||
import Data.ByteArray (convert)
|
-- import Data.ByteArray (convert)
|
||||||
import Crypto.Hash (SHAKE128)
|
-- import Crypto.Hash (SHAKE128)
|
||||||
import qualified Data.Binary as Binary
|
-- import qualified Data.Binary as Binary
|
||||||
|
|
||||||
import qualified Database.Esqueleto.Legacy as E
|
-- import qualified Database.Esqueleto.Legacy as E
|
||||||
import qualified Database.Esqueleto.Utils 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
|
authenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX
|
||||||
@ -158,20 +157,22 @@ upsertCampusUser upsertMode ldapData = do
|
|||||||
now <- liftIO getCurrentTime
|
now <- liftIO getCurrentTime
|
||||||
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
|
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
|
||||||
|
|
||||||
let
|
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 ]
|
|
||||||
userEmail' = fold $ do
|
userEmail' = fold $ do
|
||||||
k' <- toList ldapUserEmail
|
k' <- toList ldapUserEmail
|
||||||
(k, v) <- ldapData
|
(k, v) <- ldapData
|
||||||
guard $ k' == k
|
guard $ k' == k
|
||||||
return v
|
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 ]
|
userDisplayName'' = fold [ v | (k, v) <- ldapData, k == ldapUserDisplayName ]
|
||||||
userFirstName' = fold [ v | (k, v) <- ldapData, k == ldapUserFirstName ]
|
userFirstName' = fold [ v | (k, v) <- ldapData, k == ldapUserFirstName ]
|
||||||
userSurname' = fold [ v | (k, v) <- ldapData, k == ldapUserSurname ]
|
userSurname' = fold [ v | (k, v) <- ldapData, k == ldapUserSurname ]
|
||||||
userTitle' = fold [ v | (k, v) <- ldapData, k == ldapUserTitle ]
|
userTelephone' = fold [ v | (k, v) <- ldapData, k == ldapUserTelephone ]
|
||||||
userSex' = fold [ v | (k, v) <- ldapData, k == ldapSex ]
|
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
|
userAuthentication
|
||||||
| is _UpsertCampusUserLoginOther upsertMode
|
| is _UpsertCampusUserLoginOther upsertMode
|
||||||
@ -212,32 +213,31 @@ upsertCampusUser upsertMode ldapData = do
|
|||||||
-> return userSurname
|
-> return userSurname
|
||||||
| otherwise
|
| otherwise
|
||||||
-> throwM CampusUserInvalidSurname
|
-> throwM CampusUserInvalidSurname
|
||||||
userTitle <- if
|
userTelephone <- if
|
||||||
| all ByteString.null userTitle'
|
| [bs] <- userTelephone'
|
||||||
|
, Right userTelephone <- Text.decodeUtf8' bs
|
||||||
|
-> return $ Just userTelephone
|
||||||
|
| otherwise
|
||||||
-> return Nothing
|
-> return Nothing
|
||||||
| [bs] <- userTitle'
|
userMobile <- if
|
||||||
, Right userTitle <- Text.decodeUtf8' bs
|
| [bs] <- userMobile'
|
||||||
-> return $ Just userTitle
|
, Right userMobile <- Text.decodeUtf8' bs
|
||||||
|
-> return $ Just userMobile
|
||||||
| otherwise
|
| otherwise
|
||||||
-> throwM CampusUserInvalidTitle
|
|
||||||
userMatrikelnummer <- if
|
|
||||||
| [bs] <- userMatrikelnummer'
|
|
||||||
, Right userMatrikelnummer <- Text.decodeUtf8' bs
|
|
||||||
-> return $ Just userMatrikelnummer
|
|
||||||
| [] <- userMatrikelnummer'
|
|
||||||
-> return Nothing
|
-> return Nothing
|
||||||
|
userCompanyPersonalNumber <- if
|
||||||
|
| [bs] <- userFraportPersonalnummer'
|
||||||
|
, Right dt <- Text.decodeUtf8' bs
|
||||||
|
-> return $ Just dt
|
||||||
| otherwise
|
| otherwise
|
||||||
-> throwM CampusUserInvalidMatriculation
|
-> return Nothing
|
||||||
userSex <- if
|
userCompanyDepartment <- if
|
||||||
| [bs] <- userSex'
|
| [bs] <- userFraportAbteilung'
|
||||||
, Right userSex'' <- Text.decodeUtf8' bs
|
, Right dt <- Text.decodeUtf8' bs
|
||||||
, Just userSex''' <- readMay userSex''
|
-> return $ Just dt
|
||||||
, Just userSex <- userSex''' ^? iso5218
|
|
||||||
-> return $ Just userSex
|
|
||||||
| [] <- userSex'
|
|
||||||
-> return Nothing
|
|
||||||
| otherwise
|
| otherwise
|
||||||
-> throwM CampusUserInvalidSex
|
-> return Nothing
|
||||||
|
|
||||||
userLdapPrimaryKey <- if
|
userLdapPrimaryKey <- if
|
||||||
| [bs] <- userLdapPrimaryKey'
|
| [bs] <- userLdapPrimaryKey'
|
||||||
, Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs
|
, Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs
|
||||||
@ -257,6 +257,7 @@ upsertCampusUser upsertMode ldapData = do
|
|||||||
, userDownloadFiles = userDefaultDownloadFiles
|
, userDownloadFiles = userDefaultDownloadFiles
|
||||||
, userWarningDays = userDefaultWarningDays
|
, userWarningDays = userDefaultWarningDays
|
||||||
, userShowSex = userDefaultShowSex
|
, userShowSex = userDefaultShowSex
|
||||||
|
, userSex = Nothing
|
||||||
, userNotificationSettings = def
|
, userNotificationSettings = def
|
||||||
, userLanguages = Nothing
|
, userLanguages = Nothing
|
||||||
, userCsvOptions = def
|
, userCsvOptions = def
|
||||||
@ -265,15 +266,15 @@ upsertCampusUser upsertMode ldapData = do
|
|||||||
, userLastLdapSynchronisation = Just now
|
, userLastLdapSynchronisation = Just now
|
||||||
, userDisplayName = userDisplayName'
|
, userDisplayName = userDisplayName'
|
||||||
, userDisplayEmail = userEmail
|
, userDisplayEmail = userEmail
|
||||||
|
, userMatrikelnummer = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
|
||||||
|
, userTitle = Nothing
|
||||||
, ..
|
, ..
|
||||||
}
|
}
|
||||||
userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
|
userUpdate = [
|
||||||
-- , UserDisplayName =. userDisplayName
|
-- UserDisplayName =. userDisplayName
|
||||||
, UserFirstName =. userFirstName
|
UserFirstName =. userFirstName
|
||||||
, UserSurname =. userSurname
|
, UserSurname =. userSurname
|
||||||
, UserTitle =. userTitle
|
, UserEmail =. userEmail
|
||||||
, UserEmail =. userEmail
|
|
||||||
, UserSex =. userSex
|
|
||||||
, UserLastLdapSynchronisation =. Just now
|
, UserLastLdapSynchronisation =. Just now
|
||||||
, UserLdapPrimaryKey =. userLdapPrimaryKey
|
, UserLdapPrimaryKey =. userLdapPrimaryKey
|
||||||
] ++
|
] ++
|
||||||
@ -284,184 +285,9 @@ upsertCampusUser upsertMode ldapData = do
|
|||||||
user@(Entity userId userRec) <- case oldUsers of
|
user@(Entity userId userRec) <- case oldUsers of
|
||||||
Just [oldUserId] -> updateGetEntity oldUserId userUpdate
|
Just [oldUserId] -> updateGetEntity oldUserId userUpdate
|
||||||
_other -> upsertBy (UniqueAuthentication userIdent) newUser 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' ]
|
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
|
let
|
||||||
userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions'
|
userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions'
|
||||||
userSystemFunctions' = do
|
userSystemFunctions' = do
|
||||||
@ -476,9 +302,7 @@ upsertCampusUser upsertMode ldapData = do
|
|||||||
if | preset -> void $ upsert (UserSystemFunction userId func False False) []
|
if | preset -> void $ upsert (UserSystemFunction userId func False False) []
|
||||||
| otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False]
|
| otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False]
|
||||||
|
|
||||||
return user
|
return user
|
||||||
where
|
|
||||||
insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
|
|
||||||
|
|
||||||
associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m ()
|
associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m ()
|
||||||
associateUserSchoolsByTerms uid = do
|
associateUserSchoolsByTerms uid = do
|
||||||
|
|||||||
@ -6,7 +6,6 @@ import Import
|
|||||||
|
|
||||||
import Handler.Admin.Test as Handler.Admin
|
import Handler.Admin.Test as Handler.Admin
|
||||||
import Handler.Admin.ErrorMessage 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.Tokens as Handler.Admin
|
||||||
import Handler.Admin.Crontab as Handler.Admin
|
import Handler.Admin.Crontab as Handler.Admin
|
||||||
|
|
||||||
|
|||||||
@ -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{..}
|
|
||||||
@ -113,7 +113,7 @@ getStatusR = do
|
|||||||
<p>
|
<p>
|
||||||
Current Time #{show currtime}
|
Current Time #{show currtime}
|
||||||
<p>
|
<p>
|
||||||
Compile Time #{show comptime}
|
Compile Time #{comptime}
|
||||||
$maybe ctime <- readMay comptime
|
$maybe ctime <- readMay comptime
|
||||||
<p>
|
<p>
|
||||||
Build is #{show $ ddays ctime currtime} days old
|
Build is #{show $ ddays ctime currtime} days old
|
||||||
|
|||||||
@ -19,9 +19,13 @@ data AdminUserForm = AdminUserForm
|
|||||||
, aufDisplayEmail :: UserEmail
|
, aufDisplayEmail :: UserEmail
|
||||||
, aufMatriculation :: Maybe UserMatriculation
|
, aufMatriculation :: Maybe UserMatriculation
|
||||||
, aufSex :: Maybe Sex
|
, aufSex :: Maybe Sex
|
||||||
|
, aufMobile :: Maybe Text
|
||||||
|
, aufTelephone :: Maybe Text
|
||||||
|
, aufFPersonalNumber :: Maybe Text
|
||||||
|
, aufFDepartment :: Maybe Text
|
||||||
, aufEmail :: UserEmail
|
, aufEmail :: UserEmail
|
||||||
, aufIdent :: UserIdent
|
, aufIdent :: UserIdent
|
||||||
, aufAuth :: AuthenticationKind
|
, aufAuth :: AuthenticationKind
|
||||||
}
|
}
|
||||||
|
|
||||||
data AuthenticationKind = AuthKindLDAP | AuthKindPWHash
|
data AuthenticationKind = AuthKindLDAP | AuthKindPWHash
|
||||||
@ -49,6 +53,10 @@ adminUserForm template = renderAForm FormStandard
|
|||||||
<*> areq (emailField & cfCI) (fslI MsgAdminUserDisplayEmail) (aufDisplayEmail <$> template)
|
<*> areq (emailField & cfCI) (fslI MsgAdminUserDisplayEmail) (aufDisplayEmail <$> template)
|
||||||
<*> aopt (textField & cfStrip) (fslI MsgAdminUserMatriculation) (aufMatriculation <$> template)
|
<*> aopt (textField & cfStrip) (fslI MsgAdminUserMatriculation) (aufMatriculation <$> template)
|
||||||
<*> aopt (selectField optionsFinite) (fslI MsgAdminUserSex) (aufSex <$> 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 (emailField & cfCI) (fslI MsgAdminUserEmail) (aufEmail <$> template)
|
||||||
<*> areq (textField & cfStrip & cfCI) (fslI MsgAdminUserIdent) (aufIdent <$> template)
|
<*> areq (textField & cfStrip & cfCI) (fslI MsgAdminUserIdent) (aufIdent <$> template)
|
||||||
<*> areq (selectField optionsFinite) (fslI MsgAdminUserAuth) (aufAuth <$> template <|> Just AuthKindLDAP)
|
<*> areq (selectField optionsFinite) (fslI MsgAdminUserAuth) (aufAuth <$> template <|> Just AuthKindLDAP)
|
||||||
@ -89,7 +97,11 @@ postAdminUserAddR = do
|
|||||||
, userFirstName = aufFirstName
|
, userFirstName = aufFirstName
|
||||||
, userSurname = aufSurname
|
, userSurname = aufSurname
|
||||||
, userTitle = aufTitle
|
, userTitle = aufTitle
|
||||||
, userSex = aufSex
|
, userSex = aufSex
|
||||||
|
, userMobile = aufMobile
|
||||||
|
, userTelephone = aufTelephone
|
||||||
|
, userCompanyPersonalNumber = aufFPersonalNumber
|
||||||
|
, userCompanyDepartment = aufFDepartment
|
||||||
, userMatrikelnummer = aufMatriculation
|
, userMatrikelnummer = aufMatriculation
|
||||||
, userAuthentication = mkAuthMode aufAuth
|
, userAuthentication = mkAuthMode aufAuth
|
||||||
}
|
}
|
||||||
|
|||||||
@ -10,5 +10,6 @@ import qualified Data.Set as Set
|
|||||||
determineSystemFunctions :: Set (CI Text) -> (SystemFunction -> Bool)
|
determineSystemFunctions :: Set (CI Text) -> (SystemFunction -> Bool)
|
||||||
determineSystemFunctions ldapFuncs = \case
|
determineSystemFunctions ldapFuncs = \case
|
||||||
SystemExamOffice -> False
|
SystemExamOffice -> False
|
||||||
SystemFaculty -> "faculty" `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
|
||||||
SystemStudent -> "student" `Set.member` ldapFuncs
|
-- SJ: not sure this LDAP-specific key belongs here?
|
||||||
|
SystemStudent -> False -- "student" `Set.member` ldapFuncs -- no such key identified at FraPort
|
||||||
|
|||||||
@ -11,7 +11,7 @@ import qualified Data.CaseInsensitive as CI
|
|||||||
|
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
|
|
||||||
|
{- PROBALY DEPRECATED -}
|
||||||
parseLdapSchools :: Text -> Either ParseError (Set (CI Text))
|
parseLdapSchools :: Text -> Either ParseError (Set (CI Text))
|
||||||
parseLdapSchools = parse pLdapSchools ""
|
parseLdapSchools = parse pLdapSchools ""
|
||||||
|
|
||||||
|
|||||||
@ -1,6 +1,5 @@
|
|||||||
module Handler.Utils.StudyFeatures
|
module Handler.Utils.StudyFeatures
|
||||||
( module Handler.Utils.StudyFeatures.Parse
|
( UserTableStudyFeature(..)
|
||||||
, UserTableStudyFeature(..)
|
|
||||||
, _userTableField, _userTableDegree, _userTableSemester, _userTableFieldType
|
, _userTableField, _userTableDegree, _userTableSemester, _userTableFieldType
|
||||||
, UserTableStudyFeatures(..)
|
, UserTableStudyFeatures(..)
|
||||||
, _UserTableStudyFeatures
|
, _UserTableStudyFeatures
|
||||||
@ -18,8 +17,6 @@ import Foundation.I18n
|
|||||||
|
|
||||||
import Utils.Term
|
import Utils.Term
|
||||||
|
|
||||||
import Handler.Utils.StudyFeatures.Parse
|
|
||||||
|
|
||||||
import qualified Data.Csv as Csv
|
import qualified Data.Csv as Csv
|
||||||
|
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
|
|||||||
@ -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)
|
|
||||||
@ -105,6 +105,10 @@ fillDb = do
|
|||||||
, userCsvOptions = def { csvFormat = csvPreset # CsvPresetRFC }
|
, userCsvOptions = def { csvFormat = csvPreset # CsvPresetRFC }
|
||||||
, userSex = Just SexMale
|
, userSex = Just SexMale
|
||||||
, userShowSex = userDefaultShowSex
|
, userShowSex = userDefaultShowSex
|
||||||
|
, userTelephone = Nothing
|
||||||
|
, userMobile = Nothing
|
||||||
|
, userCompanyPersonalNumber = Nothing
|
||||||
|
, userCompanyDepartment = Nothing
|
||||||
}
|
}
|
||||||
fhamann <- insert User
|
fhamann <- insert User
|
||||||
{ userIdent = "felix.hamann@campus.lmu.de"
|
{ userIdent = "felix.hamann@campus.lmu.de"
|
||||||
@ -134,6 +138,10 @@ fillDb = do
|
|||||||
, userCsvOptions = def { csvFormat = csvPreset # CsvPresetExcel }
|
, userCsvOptions = def { csvFormat = csvPreset # CsvPresetExcel }
|
||||||
, userSex = Just SexMale
|
, userSex = Just SexMale
|
||||||
, userShowSex = userDefaultShowSex
|
, userShowSex = userDefaultShowSex
|
||||||
|
, userMobile = Nothing
|
||||||
|
, userTelephone = Nothing
|
||||||
|
, userCompanyPersonalNumber = Nothing
|
||||||
|
, userCompanyDepartment = Nothing
|
||||||
}
|
}
|
||||||
pwSimple <- do
|
pwSimple <- do
|
||||||
let pw = "123.456"
|
let pw = "123.456"
|
||||||
@ -169,6 +177,10 @@ fillDb = do
|
|||||||
, userSex = Just SexMale
|
, userSex = Just SexMale
|
||||||
, userCsvOptions = def
|
, userCsvOptions = def
|
||||||
, userShowSex = userDefaultShowSex
|
, userShowSex = userDefaultShowSex
|
||||||
|
, userTelephone = Just "+49 69 690-71706"
|
||||||
|
, userMobile = Just "0173 69 99 646"
|
||||||
|
, userCompanyPersonalNumber = Just "57138"
|
||||||
|
, userCompanyDepartment = Just "AVN-AR2"
|
||||||
}
|
}
|
||||||
maxMuster <- insert User
|
maxMuster <- insert User
|
||||||
{ userIdent = "max@campus.lmu.de"
|
{ userIdent = "max@campus.lmu.de"
|
||||||
@ -198,6 +210,10 @@ fillDb = do
|
|||||||
, userCsvOptions = def
|
, userCsvOptions = def
|
||||||
, userSex = Just SexMale
|
, userSex = Just SexMale
|
||||||
, userShowSex = userDefaultShowSex
|
, userShowSex = userDefaultShowSex
|
||||||
|
, userTelephone = Nothing
|
||||||
|
, userMobile = Nothing
|
||||||
|
, userCompanyPersonalNumber = Nothing
|
||||||
|
, userCompanyDepartment = Nothing
|
||||||
}
|
}
|
||||||
tinaTester <- insert $ User
|
tinaTester <- insert $ User
|
||||||
{ userIdent = "tester@campus.lmu.de"
|
{ userIdent = "tester@campus.lmu.de"
|
||||||
@ -227,6 +243,10 @@ fillDb = do
|
|||||||
, userCsvOptions = def
|
, userCsvOptions = def
|
||||||
, userSex = Just SexNotApplicable
|
, userSex = Just SexNotApplicable
|
||||||
, userShowSex = userDefaultShowSex
|
, userShowSex = userDefaultShowSex
|
||||||
|
, userTelephone = Nothing
|
||||||
|
, userMobile = Nothing
|
||||||
|
, userCompanyPersonalNumber = Nothing
|
||||||
|
, userCompanyDepartment = Nothing
|
||||||
}
|
}
|
||||||
svaupel <- insert User
|
svaupel <- insert User
|
||||||
{ userIdent = "vaupel.sarah@campus.lmu.de"
|
{ userIdent = "vaupel.sarah@campus.lmu.de"
|
||||||
@ -256,6 +276,10 @@ fillDb = do
|
|||||||
, userCsvOptions = def
|
, userCsvOptions = def
|
||||||
, userSex = Just SexFemale
|
, userSex = Just SexFemale
|
||||||
, userShowSex = userDefaultShowSex
|
, userShowSex = userDefaultShowSex
|
||||||
|
, userTelephone = Nothing
|
||||||
|
, userMobile = Nothing
|
||||||
|
, userCompanyPersonalNumber = Nothing
|
||||||
|
, userCompanyDepartment = Nothing
|
||||||
}
|
}
|
||||||
sbarth <- insert User
|
sbarth <- insert User
|
||||||
{ userIdent = "Stephan.Barth@campus.lmu.de"
|
{ userIdent = "Stephan.Barth@campus.lmu.de"
|
||||||
@ -285,6 +309,10 @@ fillDb = do
|
|||||||
, userCsvOptions = def
|
, userCsvOptions = def
|
||||||
, userSex = Just SexMale
|
, userSex = Just SexMale
|
||||||
, userShowSex = userDefaultShowSex
|
, userShowSex = userDefaultShowSex
|
||||||
|
, userTelephone = Nothing
|
||||||
|
, userMobile = Nothing
|
||||||
|
, userCompanyPersonalNumber = Nothing
|
||||||
|
, userCompanyDepartment = Nothing
|
||||||
}
|
}
|
||||||
|
|
||||||
let
|
let
|
||||||
@ -344,6 +372,10 @@ fillDb = do
|
|||||||
, userCsvOptions = def
|
, userCsvOptions = def
|
||||||
, userSex = Nothing
|
, userSex = Nothing
|
||||||
, userShowSex = userDefaultShowSex
|
, userShowSex = userDefaultShowSex
|
||||||
|
, userTelephone = Nothing
|
||||||
|
, userMobile = Nothing
|
||||||
|
, userCompanyPersonalNumber = Nothing
|
||||||
|
, userCompanyDepartment = Nothing
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
userIdent :: IsString t => t
|
userIdent :: IsString t => t
|
||||||
|
|||||||
@ -128,6 +128,10 @@ instance Arbitrary User where
|
|||||||
userNotificationSettings <- arbitrary
|
userNotificationSettings <- arbitrary
|
||||||
userCsvOptions <- arbitrary
|
userCsvOptions <- arbitrary
|
||||||
userShowSex <- 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
|
userCreated <- arbitrary
|
||||||
userLastLdapSynchronisation <- arbitrary
|
userLastLdapSynchronisation <- arbitrary
|
||||||
|
|||||||
@ -43,3 +43,7 @@ fakeUser adjUser = adjUser User{..}
|
|||||||
userCreated = unsafePerformIO getCurrentTime
|
userCreated = unsafePerformIO getCurrentTime
|
||||||
userLastLdapSynchronisation = Nothing
|
userLastLdapSynchronisation = Nothing
|
||||||
userLdapPrimaryKey = Nothing
|
userLdapPrimaryKey = Nothing
|
||||||
|
userMobile = Nothing
|
||||||
|
userTelephone = Nothing
|
||||||
|
userCompanyPersonalNumber = Nothing
|
||||||
|
userCompanyDepartment = Nothing
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user