Merge branch 'master' into feat/feste-abgabegruppen
This commit is contained in:
Gregor Kleen
commit
6d00410682
47
CHANGELOG.md
47
CHANGELOG.md
@ -2,6 +2,53 @@
|
||||
|
||||
All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
|
||||
|
||||
## [15.5.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v15.4.1...v15.5.0) (2020-04-27)
|
||||
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* **auth:** tutors may see sheet list ([e0c05f3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e0c05f3))
|
||||
* **campus:** fix corner case with study features ([76098cc](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/76098cc))
|
||||
|
||||
|
||||
### Features
|
||||
|
||||
* **allocations:** switch to csprng ([3ea7371](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3ea7371))
|
||||
* **ldap:** failover ([0e68b6c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/0e68b6c))
|
||||
* **news:** timeout sheets after a month ([31aa25a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/31aa25a))
|
||||
|
||||
|
||||
|
||||
### [15.4.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v15.4.0...v15.4.1) (2020-04-26)
|
||||
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* **allocation:** don't restart cloneCount when allocating successors ([e1c6fd4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e1c6fd4))
|
||||
|
||||
|
||||
|
||||
## [15.4.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v15.3.0...v15.4.0) (2020-04-24)
|
||||
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* typo ([c06a472](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c06a472))
|
||||
* **faqs:** mention mail to set password ([32097d1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/32097d1))
|
||||
* **faqs:** wording ([02d284f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/02d284f))
|
||||
* **navbar:** restore border to language buttons ([a2e9a9c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a2e9a9c))
|
||||
|
||||
|
||||
### Features
|
||||
|
||||
* **faqs:** i18n ([a1a0fa3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a1a0fa3))
|
||||
* **faqs:** initial ([7b53377](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7b53377))
|
||||
* **faqs:** more faqs ([18766ed](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/18766ed))
|
||||
* **faqs:** more links to faq ([10d44d1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/10d44d1))
|
||||
* **help:** attach last error message ([fdd6b1a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fdd6b1a))
|
||||
|
||||
|
||||
|
||||
## [15.3.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v15.2.0...v15.3.0) (2020-04-23)
|
||||
|
||||
|
||||
|
||||
@ -92,19 +92,21 @@ database:
|
||||
auto-db-migrate: '_env:AUTO_DB_MIGRATE:true'
|
||||
|
||||
ldap:
|
||||
host: "_env:LDAPHOST:"
|
||||
tls: "_env:LDAPTLS:"
|
||||
port: "_env:LDAPPORT:389"
|
||||
user: "_env:LDAPUSER:"
|
||||
pass: "_env:LDAPPASS:"
|
||||
baseDN: "_env:LDAPBASE:"
|
||||
scope: "_env:LDAPSCOPE:WholeSubtree"
|
||||
timeout: "_env:LDAPTIMEOUT:5"
|
||||
search-timeout: "_env:LDAPSEARCHTIME:5"
|
||||
pool:
|
||||
stripes: "_env:LDAPSTRIPES:1"
|
||||
timeout: "_env:LDAPTIMEOUT:20"
|
||||
limit: "_env:LDAPLIMIT:10"
|
||||
- host: "_env:LDAPHOST:"
|
||||
tls: "_env:LDAPTLS:"
|
||||
port: "_env:LDAPPORT:389"
|
||||
user: "_env:LDAPUSER:"
|
||||
pass: "_env:LDAPPASS:"
|
||||
baseDN: "_env:LDAPBASE:"
|
||||
scope: "_env:LDAPSCOPE:WholeSubtree"
|
||||
timeout: "_env:LDAPTIMEOUT:5"
|
||||
search-timeout: "_env:LDAPSEARCHTIME:5"
|
||||
pool:
|
||||
stripes: "_env:LDAPSTRIPES:1"
|
||||
timeout: "_env:LDAPTIMEOUT:20"
|
||||
limit: "_env:LDAPLIMIT:10"
|
||||
|
||||
ldap-re-test-failover: 60
|
||||
|
||||
smtp:
|
||||
host: "_env:SMTPHOST:"
|
||||
|
||||
@ -971,7 +971,7 @@ SheetGradingPassBinary': Bestanden/Nicht bestanden
|
||||
|
||||
SheetTypeBonus grading@SheetGrading: Bonus
|
||||
SheetTypeNormal grading@SheetGrading: Normal
|
||||
SheetTypeInformational grading@SheetGrading: Ohne Anrechung
|
||||
SheetTypeInformational grading@SheetGrading: Ohne Anrechnung
|
||||
SheetTypeNotGraded: Keine Korrektur
|
||||
SheetTypeInfoNotGraded: Keine Korrektur bedeutet, dass es gar kein Feedback gibt.
|
||||
SheetTypeInfoBonus: Bonus Blätter zählen normal, erhöhen aber nicht die maximal erreichbare Punktzahl bzw. Anzahl zu bestehender Blätter.
|
||||
|
||||
@ -21,6 +21,7 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis
|
||||
registerByCourse UTCTime Maybe -- course registration dates are ignored until this day has passed or always prohibited
|
||||
overrideDeregister UTCTime Maybe -- course deregistration enforced to be this date, i.e. students may disenrol from course after or never
|
||||
-- overrideVisible not needed, since courses are always visible
|
||||
matchingSeed ByteString default=''
|
||||
TermSchoolAllocationShort term school shorthand -- shorthand must be unique within school and semester
|
||||
TermSchoolAllocationName term school name -- name must be unique within school and semester
|
||||
deriving Show Eq Ord Generic
|
||||
|
||||
2
package-lock.json
generated
2
package-lock.json
generated
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "15.3.0",
|
||||
"version": "15.5.0",
|
||||
"lockfileVersion": 1,
|
||||
"requires": true,
|
||||
"dependencies": {
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
{
|
||||
"name": "uni2work",
|
||||
"version": "15.3.0",
|
||||
"version": "15.5.0",
|
||||
"description": "",
|
||||
"keywords": [],
|
||||
"author": "",
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: uniworx
|
||||
version: 15.3.0
|
||||
version: 15.5.0
|
||||
|
||||
dependencies:
|
||||
- base
|
||||
@ -145,6 +145,8 @@ dependencies:
|
||||
- pandoc
|
||||
- token-bucket
|
||||
- async
|
||||
- pointedlist
|
||||
- clock
|
||||
|
||||
other-extensions:
|
||||
- GeneralizedNewtypeDeriving
|
||||
|
||||
4
routes
4
routes
@ -141,9 +141,9 @@
|
||||
/exam-office CExamOfficeR GET POST !course-registered
|
||||
/subs CCorrectionsR GET POST
|
||||
/subs/assigned CAssignR GET POST
|
||||
/sheet SheetListR GET !course-registered !materials !corrector
|
||||
/sheet SheetListR GET !course-registered !materials !corrector !tutor
|
||||
/sheet/new SheetNewR GET POST
|
||||
/sheet/current SheetCurrentR GET !course-registered !materials !corrector
|
||||
/sheet/current SheetCurrentR GET !course-registered !materials !corrector !tutor
|
||||
/sheet/unassigned SheetOldUnassignedR GET
|
||||
/sheet/#SheetName SheetR:
|
||||
/show SShowR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor
|
||||
|
||||
@ -209,9 +209,9 @@ makeFoundation appSettings'@AppSettings{..} = do
|
||||
(pgConnStr appDatabaseConf)
|
||||
(pgPoolSize appDatabaseConf)
|
||||
|
||||
ldapPool <- for appLdapConf $ \LdapConf{..} -> do
|
||||
$logDebugS "setup" "LDAP-Pool"
|
||||
createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool)
|
||||
ldapPool <- traverse mkFailover <=< forOf (traverse . traverse) appLdapConf $ \conf@LdapConf{..} -> do
|
||||
$logDebugS "setup" $ "LDAP-Pool " <> tshow ldapHost
|
||||
(conf,) <$> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool)
|
||||
|
||||
-- Perform database migration using our application's logging settings.
|
||||
if
|
||||
|
||||
@ -3,6 +3,7 @@ module Auth.LDAP
|
||||
, campusLogin
|
||||
, CampusUserException(..)
|
||||
, campusUser, campusUser'
|
||||
, campusUserReTest, campusUserReTest'
|
||||
, campusUserMatr, campusUserMatr'
|
||||
, CampusMessage(..)
|
||||
, ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName
|
||||
@ -102,8 +103,18 @@ instance Exception CampusUserException
|
||||
|
||||
makePrisms ''CampusUserException
|
||||
|
||||
campusUser :: MonadUnliftIO m => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList [])
|
||||
campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do
|
||||
campusUserWith :: MonadUnliftIO m
|
||||
=> ( Lens (LdapConf, LdapPool) (LdapConf, Ldap) LdapPool Ldap
|
||||
-> Failover (LdapConf, LdapPool)
|
||||
-> FailoverMode
|
||||
-> ((LdapConf, Ldap) -> IO (Ldap.AttrList []))
|
||||
-> IO (Either LdapPoolError (Ldap.AttrList []))
|
||||
)
|
||||
-> Failover (LdapConf, LdapPool)
|
||||
-> FailoverMode
|
||||
-> Creds site
|
||||
-> m (Ldap.AttrList [])
|
||||
campusUserWith withLdap' pool mode Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap' _2 pool mode $ \(conf@LdapConf{..}, ldap) -> do
|
||||
Ldap.bind ldap ldapDn ldapPassword
|
||||
results <- case lookup "DN" credsExtra of
|
||||
Just userDN -> do
|
||||
@ -121,13 +132,23 @@ campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $
|
||||
, Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs
|
||||
]
|
||||
|
||||
campusUser' :: (MonadCatch m, MonadUnliftIO m) => LdapConf -> LdapPool -> User -> m (Maybe (Ldap.AttrList []))
|
||||
campusUser' conf pool User{userIdent}
|
||||
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser conf pool (Creds apLdap (CI.original userIdent) [])
|
||||
campusUserReTest :: MonadUnliftIO m => Failover (LdapConf, LdapPool) -> (Nano -> Bool) -> FailoverMode -> Creds site -> m (Ldap.AttrList [])
|
||||
campusUserReTest pool doTest = campusUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool
|
||||
|
||||
campusUserReTest' :: (MonadCatch m, MonadUnliftIO m) => Failover (LdapConf, LdapPool) -> (Nano -> Bool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList []))
|
||||
campusUserReTest' pool doTest mode User{userIdent}
|
||||
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUserReTest pool doTest mode (Creds apLdap (CI.original userIdent) [])
|
||||
|
||||
campusUser :: MonadUnliftIO m => Failover (LdapConf, LdapPool) -> FailoverMode -> Creds site -> m (Ldap.AttrList [])
|
||||
campusUser = campusUserWith withLdapFailover
|
||||
|
||||
campusUser' :: (MonadCatch m, MonadUnliftIO m) => Failover (LdapConf, LdapPool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList []))
|
||||
campusUser' pool mode User{userIdent}
|
||||
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser pool mode (Creds apLdap (CI.original userIdent) [])
|
||||
|
||||
|
||||
campusUserMatr :: MonadUnliftIO m => LdapConf -> LdapPool -> UserMatriculation -> m (Ldap.AttrList [])
|
||||
campusUserMatr conf@LdapConf{..} pool userMatr = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do
|
||||
campusUserMatr :: MonadUnliftIO m => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Ldap.AttrList [])
|
||||
campusUserMatr pool mode userMatr = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> do
|
||||
Ldap.bind ldap ldapDn ldapPassword
|
||||
results <- findUserMatr conf ldap userMatr []
|
||||
case results of
|
||||
@ -140,9 +161,9 @@ campusUserMatr conf@LdapConf{..} pool userMatr = liftIO . (`catches` errHandlers
|
||||
, Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs
|
||||
]
|
||||
|
||||
campusUserMatr' :: (MonadCatch m, MonadUnliftIO m) => LdapConf -> LdapPool -> UserMatriculation -> m (Maybe (Ldap.AttrList []))
|
||||
campusUserMatr' conf pool
|
||||
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) . campusUserMatr conf pool
|
||||
campusUserMatr' :: (MonadCatch m, MonadUnliftIO m) => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Maybe (Ldap.AttrList []))
|
||||
campusUserMatr' pool mode
|
||||
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) . campusUserMatr pool mode
|
||||
|
||||
|
||||
|
||||
@ -168,8 +189,8 @@ campusLogin :: forall site.
|
||||
, RenderMessage site CampusMessage
|
||||
, RenderMessage site AFormMessage
|
||||
, Button site ButtonSubmit
|
||||
) => LdapConf -> LdapPool -> AuthPlugin site
|
||||
campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
|
||||
) => Failover (LdapConf, LdapPool) -> FailoverMode -> AuthPlugin site
|
||||
campusLogin pool mode = AuthPlugin{..}
|
||||
where
|
||||
apName :: Text
|
||||
apName = apLdap
|
||||
@ -184,7 +205,7 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
|
||||
redirect $ tp LoginR
|
||||
FormMissing -> redirect $ tp LoginR
|
||||
FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do
|
||||
ldapResult <- withLdap pool $ \ldap -> liftIO $ do
|
||||
ldapResult <- withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO $ do
|
||||
Ldap.bind ldap ldapDn ldapPassword
|
||||
searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName]
|
||||
case searchResults of
|
||||
|
||||
19
src/Crypto/Random/Instances.hs
Normal file
19
src/Crypto/Random/Instances.hs
Normal file
@ -0,0 +1,19 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Crypto.Random.Instances
|
||||
(
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
|
||||
import Crypto.Random
|
||||
import System.Random (RandomGen(..))
|
||||
|
||||
import qualified Data.ByteArray as BA
|
||||
|
||||
import Data.Bits
|
||||
|
||||
|
||||
instance RandomGen ChaChaDRG where
|
||||
next g = withRandomBytes g (finiteBitSize (maxBound :: Int) `div` 8) (foldr (\x acc -> acc `shiftL` 8 .|. fromIntegral x) zeroBits . BA.unpack @BA.Bytes)
|
||||
split g = withDRG g drgNew
|
||||
@ -4716,18 +4716,11 @@ upsertCampusUser plugin ldapData = do
|
||||
oldFs <- selectKeysList
|
||||
([ StudyFeaturesUser ==. studyFeaturesUser
|
||||
, StudyFeaturesDegree ==. studyFeaturesDegree
|
||||
, StudyFeaturesField ==. studyFeaturesField
|
||||
, StudyFeaturesType ==. studyFeaturesType
|
||||
, StudyFeaturesSemester ==. studyFeaturesSemester
|
||||
] ++
|
||||
[ StudyFeaturesField ==. studyFeaturesField
|
||||
, StudyFeaturesSuperField ==. studyFeaturesSuperField
|
||||
] ||. case studyFeaturesSuperField of
|
||||
Just sField ->
|
||||
[ StudyFeaturesField ==. sField
|
||||
, StudyFeaturesSuperField ==. Nothing
|
||||
]
|
||||
Nothing -> []
|
||||
) []
|
||||
])
|
||||
[]
|
||||
case oldFs of
|
||||
[oldF] -> update oldF
|
||||
[ StudyFeaturesUpdated =. now
|
||||
@ -4893,17 +4886,17 @@ instance YesodAuth UniWorX where
|
||||
$logDebugS "auth" $ tshow Creds{..}
|
||||
UniWorX{ appSettings' = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod
|
||||
|
||||
flip catches excHandlers $ case (,) <$> appLdapConf <*> appLdapPool of
|
||||
Just (ldapConf, ldapPool)
|
||||
flip catches excHandlers $ case appLdapPool of
|
||||
Just ldapPool
|
||||
| Just upsertMode' <- upsertMode -> do
|
||||
ldapData <- campusUser ldapConf ldapPool Creds{..}
|
||||
ldapData <- campusUser ldapPool campusUserFailoverMode Creds{..}
|
||||
$logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
|
||||
Authenticated . entityKey <$> upsertCampusUser upsertMode' ldapData
|
||||
_other
|
||||
-> acceptExisting
|
||||
|
||||
authPlugins (UniWorX{ appSettings' = AppSettings{..}, appLdapPool }) = catMaybes
|
||||
[ campusLogin <$> appLdapConf <*> appLdapPool
|
||||
[ flip campusLogin campusUserFailoverMode <$> appLdapPool
|
||||
, Just . hashLogin $ pwHashAlgorithm appAuthPWHash
|
||||
, dummyLogin <$ guard appAuthDummyLogin
|
||||
]
|
||||
@ -4926,6 +4919,9 @@ instance YesodAuth UniWorX where
|
||||
_other -> Auth.germanMessage
|
||||
where lang = Text.splitOn "-" $ selectLanguage' appLanguages ls
|
||||
|
||||
campusUserFailoverMode :: FailoverMode
|
||||
campusUserFailoverMode = FailoverUnlimited
|
||||
|
||||
instance YesodAuthPersist UniWorX
|
||||
|
||||
|
||||
|
||||
@ -37,7 +37,7 @@ data UniWorX = UniWorX
|
||||
, appStatic :: EmbeddedStatic -- ^ Settings for static file serving.
|
||||
, appConnPool :: ConnectionPool -- ^ Database connection pool.
|
||||
, appSmtpPool :: Maybe SMTPPool
|
||||
, appLdapPool :: Maybe LdapPool
|
||||
, appLdapPool :: Maybe (Failover (LdapConf, LdapPool))
|
||||
, appWidgetMemcached :: Maybe Memcached.Connection -- ^ Actually a proper pool
|
||||
, appHttpManager :: Manager
|
||||
, appLogger :: (ReleaseKey, TVar Logger)
|
||||
|
||||
@ -115,7 +115,7 @@ postAComputeR tid ssh ash = do
|
||||
|
||||
formResult computeFormRes $ \AllocationComputeForm{..} -> do
|
||||
now <- liftIO getCurrentTime
|
||||
(allocFp, allocMatching, allocLog) <- computeAllocation aId acfRestrictCourses
|
||||
(allocFp, allocMatching, allocLog) <- computeAllocation aEnt acfRestrictCourses
|
||||
tellSessionJson SessionAllocationResults . SessionDataAllocationResults $
|
||||
Map.singleton (tid, ssh, ash) (now, allocFp, allocMatching, allocLog)
|
||||
addMessageI Success MsgAllocationComputed
|
||||
|
||||
@ -86,6 +86,8 @@ newsSystemMessages = do
|
||||
newsUpcomingSheets :: UserId -> Widget
|
||||
newsUpcomingSheets uid = do
|
||||
cTime <- liftIO getCurrentTime
|
||||
let noActiveToCutoff = toMidnight . addGregorianDurationRollOver (scaleCalendarDiffDays (-1) calendarMonth) $ utctDay cTime
|
||||
|
||||
let tableData :: E.LeftOuterJoin
|
||||
(E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity CourseParticipant)) (E.SqlExpr (Entity Course))) (E.SqlExpr (Entity Sheet)))
|
||||
(E.InnerJoin (E.SqlExpr (Maybe (Entity Submission))) (E.SqlExpr (Maybe (Entity SubmissionUser))))
|
||||
@ -101,8 +103,16 @@ newsUpcomingSheets uid = do
|
||||
E.on $ submission E.?. SubmissionSheet E.==. E.just(sheet E.^. SheetId)
|
||||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||||
E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
|
||||
|
||||
let showSheetNoActiveTo =
|
||||
E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetActiveFrom)
|
||||
E.||. E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetVisibleFrom)
|
||||
E.||. E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetHintFrom)
|
||||
E.||. E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetSolutionFrom)
|
||||
|
||||
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
|
||||
E.&&. E.maybe E.true (E.>=. E.val cTime) (sheet E.^. SheetActiveTo)
|
||||
E.&&. E.maybe showSheetNoActiveTo (E.>=. E.val cTime) (sheet E.^. SheetActiveTo)
|
||||
|
||||
return
|
||||
( course E.^. CourseTerm
|
||||
, course E.^. CourseSchool
|
||||
|
||||
@ -337,8 +337,8 @@ postAdminUserR uuid = do
|
||||
campusHandler :: MonadPlus m => Auth.CampusUserException -> m a
|
||||
campusHandler _ = mzero
|
||||
campusResult <- runMaybeT . handle campusHandler $ do
|
||||
(Just pool, Just conf) <- getsYesod $ (,) <$> view _appLdapPool <*> view _appLdapConf
|
||||
void . lift . Auth.campusUser conf pool $ Creds Auth.apLdap (CI.original userIdent) []
|
||||
Just pool <- getsYesod $ view _appLdapPool
|
||||
void . lift . Auth.campusUser pool FailoverUnlimited $ Creds Auth.apLdap (CI.original userIdent) []
|
||||
case campusResult of
|
||||
Nothing -> addMessageI Error MsgAuthLDAPInvalidLookup
|
||||
_other
|
||||
|
||||
@ -24,7 +24,10 @@ import qualified Data.Vector as Vector
|
||||
import Data.Vector.Lens (vector)
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import System.Random (mkStdGen)
|
||||
import qualified Data.Binary as Binary
|
||||
import Crypto.Hash.Algorithms (SHAKE256)
|
||||
import Crypto.Random (drgNewSeed, seedFromBinary)
|
||||
import Crypto.Error (onCryptoFailure)
|
||||
|
||||
import Utils.Allocation
|
||||
|
||||
@ -33,7 +36,8 @@ import qualified Data.Conduit.List as C
|
||||
import Data.Generics.Product.Param
|
||||
|
||||
import qualified Crypto.Hash as Crypto
|
||||
import qualified Data.Binary as Binary
|
||||
|
||||
import Language.Haskell.TH (nameBase)
|
||||
|
||||
|
||||
data MatchingExcludedReason
|
||||
@ -81,13 +85,13 @@ sinkAllocationPriorities allocId = fmap getSum . C.foldMapM . ifoldMapM $ \matr
|
||||
E.&&. user E.^. UserMatrikelnummer E.==. E.val (Just matr)
|
||||
|
||||
|
||||
computeAllocation :: AllocationId
|
||||
computeAllocation :: Entity Allocation
|
||||
-> Maybe (Set CourseId) -- ^ Optionally restrict allocation to only consider the given courses
|
||||
-> DB ( AllocationFingerprint
|
||||
, Set (UserId, CourseId)
|
||||
, Seq MatchingLogRun
|
||||
)
|
||||
computeAllocation allocId cRestr = do
|
||||
computeAllocation (Entity allocId Allocation{allocationMatchingSeed}) cRestr = do
|
||||
allocations <- selectList [ CourseParticipantAllocated ==. Just allocId ] []
|
||||
let allocations' = allocations
|
||||
& map ((, Sum 1) . courseParticipantUser . entityVal)
|
||||
@ -105,7 +109,7 @@ computeAllocation allocId cRestr = do
|
||||
|
||||
guard $ totalCourses > allocated
|
||||
|
||||
return (user, (totalCourses - allocated, priority))
|
||||
return (user, ((allocated, totalCourses - allocated), priority))
|
||||
)
|
||||
& Map.fromList
|
||||
cloneCounts = Map.map (view _1) users''
|
||||
@ -193,10 +197,12 @@ computeAllocation allocId cRestr = do
|
||||
= id
|
||||
|
||||
let
|
||||
fingerprint :: AllocationFingerprint
|
||||
fingerprint = Crypto.hash . toStrict $ Binary.encode (users'', capacities, preferences, gradeScale, gradeOrdinalPlaces)
|
||||
inputs = Binary.encode (users'', capacities, preferences, gradeScale, gradeOrdinalPlaces)
|
||||
|
||||
g = mkStdGen $ hash fingerprint
|
||||
fingerprint :: AllocationFingerprint
|
||||
fingerprint = Crypto.hashlazy inputs
|
||||
|
||||
g = onCryptoFailure (\_ -> error "Could not create DRG") id . fmap drgNewSeed . seedFromBinary $ kmaclazy @(SHAKE256 320) (encodeUtf8 . (pack :: String -> Text) $ nameBase 'computeAllocation) allocationMatchingSeed inputs
|
||||
|
||||
let
|
||||
doAllocationWithout :: Set CourseId -> Writer (Seq (MatchingLog UserId CourseId Natural)) (Set (UserId, CourseId))
|
||||
|
||||
@ -26,10 +26,8 @@ import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime)
|
||||
|
||||
import qualified Data.Binary as Binary
|
||||
|
||||
import qualified Crypto.MAC.KMAC as KMAC
|
||||
import Crypto.Hash.Algorithms (SHAKE256)
|
||||
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import qualified Data.ByteArray as BA
|
||||
|
||||
import Language.Haskell.TH
|
||||
@ -94,7 +92,7 @@ memcachedKey :: ( Typeable a
|
||||
)
|
||||
=> AEAD.Key -> Proxy a -> k -> ByteString
|
||||
memcachedKey (Saltine.encode -> kmacKey) p k = Binary.encode k
|
||||
& KMAC.finalize . KMAC.updates (KMAC.initialize @(SHAKE256 256) (encodeUtf8 . tshow $ typeRep p) kmacKey) . LBS.toChunks
|
||||
& kmaclazy @(SHAKE256 256) (encodeUtf8 . tshow $ typeRep p) kmacKey
|
||||
& BA.convert
|
||||
|
||||
memcachedByGet :: forall a k m.
|
||||
|
||||
@ -100,10 +100,9 @@ guessUser (Set.toList -> criteria) = $cachedHereBinary criteria $ go False
|
||||
]
|
||||
|
||||
doLdap userMatr = do
|
||||
app <- getYesod
|
||||
let ldap = (,) <$> app ^. _appLdapConf <*> app ^. _appLdapPool
|
||||
fmap (fmap entityKey . join) . for ldap $ \(ldapConf, ldapPool) -> do
|
||||
ldapData <- campusUserMatr' ldapConf ldapPool userMatr
|
||||
ldapPool' <- getsYesod $ view _appLdapPool
|
||||
fmap (fmap entityKey . join) . for ldapPool' $ \ldapPool -> do
|
||||
ldapData <- campusUserMatr' ldapPool FailoverUnlimited userMatr
|
||||
for ldapData $ upsertCampusUser UpsertCampusUser
|
||||
|
||||
if
|
||||
|
||||
@ -12,6 +12,7 @@ import Utils.Tokens as Import
|
||||
import Utils.Frontend.Modal as Import
|
||||
import Utils.Frontend.Notification as Import
|
||||
import Utils.Lens as Import
|
||||
import Utils.Failover as Import
|
||||
|
||||
import Settings as Import
|
||||
import Settings.StaticFiles as Import
|
||||
|
||||
@ -118,6 +118,8 @@ import Algebra.Lattice as Import
|
||||
|
||||
import Data.Proxy as Import (Proxy(..))
|
||||
|
||||
import Data.List.PointedList as Import (PointedList)
|
||||
|
||||
import Language.Haskell.TH.Instances as Import ()
|
||||
import Data.NonNull.Instances as Import ()
|
||||
import Data.Monoid.Instances as Import ()
|
||||
@ -156,8 +158,10 @@ import Yesod.Form.Fields.Instances as Import ()
|
||||
import Data.MonoTraversable.Instances as Import ()
|
||||
import Web.Cookie.Instances as Import ()
|
||||
import Network.HTTP.Types.Method.Instances as Import ()
|
||||
import Crypto.Random.Instances as Import ()
|
||||
|
||||
import Crypto.Hash as Import (Digest, SHA3_256)
|
||||
import Crypto.Random as Import (ChaChaDRG, Seed)
|
||||
|
||||
import Control.Lens as Import
|
||||
hiding ( (<.>)
|
||||
|
||||
@ -39,14 +39,15 @@ dispatchJobSynchroniseLdap numIterations epoch iteration
|
||||
dispatchJobSynchroniseLdapUser :: UserId -> Handler ()
|
||||
dispatchJobSynchroniseLdapUser jUser = do
|
||||
UniWorX{ appSettings' = AppSettings{..}, .. } <- getYesod
|
||||
case (,) <$> appLdapConf <*> appLdapPool of
|
||||
Just (ldapConf, ldapPool) ->
|
||||
case appLdapPool of
|
||||
Just ldapPool ->
|
||||
runDB . void . runMaybeT . handleExc $ do
|
||||
user@User{userIdent} <- MaybeT $ get jUser
|
||||
|
||||
$logInfoS "SynchroniseLdap" [st|Synchronising #{userIdent}|]
|
||||
|
||||
ldapAttrs <- MaybeT $ campusUser' ldapConf ldapPool user
|
||||
reTestAfter <- getsYesod $ view _appLdapReTestFailover
|
||||
ldapAttrs <- MaybeT $ campusUserReTest' ldapPool ((>= reTestAfter) . realToFrac) FailoverUnlimited user
|
||||
void . lift $ upsertCampusUser UpsertCampusUser ldapAttrs
|
||||
Nothing ->
|
||||
throwM SynchroniseLdapNoLdap
|
||||
|
||||
@ -93,21 +93,20 @@ dispatchHealthCheckHTTPReachable = fmap HealthHTTPReachable . yesodTimeout (^. _
|
||||
dispatchHealthCheckLDAPAdmins :: Handler HealthReport
|
||||
dispatchHealthCheckLDAPAdmins = fmap HealthLDAPAdmins . yesodTimeout (^. _appHealthCheckLDAPAdminsTimeout) (Just 0) $ do
|
||||
ldapPool' <- getsYesod appLdapPool
|
||||
ldapConf' <- getsYesod $ view _appLdapConf
|
||||
ldapAdminUsers <- fmap (map E.unValue) . runDB . E.select . E.from $ \(user `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
|
||||
E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
|
||||
E.where_ $ user E.^. UserAuthentication E.==. E.val AuthLDAP
|
||||
return $ user E.^. UserIdent
|
||||
case (,) <$> ldapPool' <*> ldapConf' of
|
||||
Just (ldapPool, ldapConf)
|
||||
| not $ null ldapAdminUsers
|
||||
-> do
|
||||
let numAdmins = genericLength ldapAdminUsers
|
||||
hCampusExc :: CampusUserException -> Handler (Sum Integer)
|
||||
hCampusExc _ = return $ Sum 0
|
||||
Sum numResolved <- fmap fold . forM ldapAdminUsers $
|
||||
\(CI.original -> adminIdent) -> handle hCampusExc $ Sum 1 <$ campusUser ldapConf ldapPool (Creds "LDAP" adminIdent [])
|
||||
return . Just $ numResolved % numAdmins
|
||||
reTestAfter <- getsYesod $ view _appLdapReTestFailover
|
||||
case ldapPool' of
|
||||
Just ldapPool -> do
|
||||
ldapAdminUsers' <- fmap (map E.unValue) . runDB . E.select . E.from $ \(user `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
|
||||
E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
|
||||
E.where_ $ user E.^. UserAuthentication E.==. E.val AuthLDAP
|
||||
return $ user E.^. UserIdent
|
||||
for (assertM' (not . null) ldapAdminUsers') $ \ldapAdminUsers -> do
|
||||
let numAdmins = genericLength ldapAdminUsers
|
||||
hCampusExc :: CampusUserException -> Handler (Sum Integer)
|
||||
hCampusExc _ = return $ Sum 0
|
||||
Sum numResolved <- fmap fold . forM ldapAdminUsers $
|
||||
\(CI.original -> adminIdent) -> handle hCampusExc $ Sum 1 <$ campusUserReTest ldapPool ((>= reTestAfter) . realToFrac) FailoverUnlimited (Creds "LDAP" adminIdent [])
|
||||
return $ numResolved % numAdmins
|
||||
_other -> return Nothing
|
||||
|
||||
|
||||
|
||||
@ -4,12 +4,14 @@ module Ldap.Client.Pool
|
||||
( LdapPool
|
||||
, LdapExecutor, Ldap, LdapError
|
||||
, LdapPoolError(..)
|
||||
, withLdap
|
||||
, withLdap, withLdapFailover, withLdapFailoverReTest
|
||||
, createLdapPool
|
||||
) where
|
||||
|
||||
import ClassyPrelude hiding (Handler, catches, try)
|
||||
|
||||
import Utils.Failover
|
||||
|
||||
import Control.Lens
|
||||
|
||||
import Ldap.Client (Ldap, LdapError)
|
||||
@ -27,6 +29,9 @@ import Control.Monad.Trans.Resource (MonadResource)
|
||||
import qualified Control.Monad.Trans.Resource as Resource
|
||||
import Control.Monad.Catch
|
||||
|
||||
import Control.Monad.Trans.Except (throwE)
|
||||
import Data.Fixed (Nano)
|
||||
|
||||
|
||||
type LdapPool = Pool LdapExecutor
|
||||
data LdapExecutor = LdapExecutor
|
||||
@ -41,8 +46,14 @@ data LdapPoolError = LdapPoolTimeout | LdapError LdapError
|
||||
instance Exception LdapPoolError
|
||||
|
||||
|
||||
withLdap :: (MonadUnliftIO m, Typeable a) => LdapPool -> (Ldap -> m a) -> m (Either LdapPoolError a)
|
||||
withLdap pool act = withResource pool $ \LdapExecutor{..} -> ldapExec act
|
||||
withLdap :: (MonadUnliftIO m, MonadCatch m, Typeable a) => LdapPool -> (Ldap -> m a) -> m (Either LdapPoolError a)
|
||||
withLdap pool act = fmap join . try . withResource pool $ \LdapExecutor{..} -> ldapExec act
|
||||
|
||||
withLdapFailover :: (MonadUnliftIO m, MonadCatch m, Typeable a) => Lens p p' LdapPool Ldap -> Failover p -> FailoverMode -> (p' -> m a) -> m (Either LdapPoolError a)
|
||||
withLdapFailover l@(flip withLens const -> proj) pool' mode act = try . withFailover pool' mode (either throwE return) $ \x -> withLdap (proj x) (\c -> act $ x & l .~ c)
|
||||
|
||||
withLdapFailoverReTest :: (MonadUnliftIO m, MonadCatch m, Typeable a) => Lens p p' LdapPool Ldap -> Failover p -> (Nano -> Bool) -> FailoverMode -> (p' -> m a) -> m (Either LdapPoolError a)
|
||||
withLdapFailoverReTest l@(flip withLens const -> proj) pool' doTest mode act = try . withFailoverReTest pool' doTest mode (either throwE return) $ \x -> withLdap (proj x) (\c -> act $ x & l .~ c)
|
||||
|
||||
|
||||
createLdapPool :: ( MonadLoggerIO m, MonadResource m )
|
||||
|
||||
@ -65,6 +65,8 @@ import qualified Web.ServerSession.Core as ServerSession
|
||||
|
||||
import Text.Show (showParen, showString)
|
||||
|
||||
import qualified Data.List.PointedList as P
|
||||
|
||||
|
||||
-- | Runtime settings to configure this application. These settings can be
|
||||
-- loaded from various sources: defaults, environment variables, config files,
|
||||
@ -78,7 +80,7 @@ data AppSettings = AppSettings
|
||||
, appDatabaseConf :: PostgresConf
|
||||
-- ^ Configuration settings for accessing the database.
|
||||
, appAutoDbMigrate :: Bool
|
||||
, appLdapConf :: Maybe LdapConf
|
||||
, appLdapConf :: Maybe (PointedList LdapConf)
|
||||
-- ^ Configuration settings for accessing the LDAP-directory
|
||||
, appSmtpConf :: Maybe SmtpConf
|
||||
-- ^ Configuration settings for accessing a SMTP Mailserver
|
||||
@ -131,6 +133,8 @@ data AppSettings = AppSettings
|
||||
, appSynchroniseLdapUsersWithin :: Maybe NominalDiffTime
|
||||
, appSynchroniseLdapUsersInterval :: NominalDiffTime
|
||||
|
||||
, appLdapReTestFailover :: DiffTime
|
||||
|
||||
, appSessionFilesExpire :: NominalDiffTime
|
||||
, appPruneUnreferencedFiles :: Maybe NominalDiffTime
|
||||
|
||||
@ -412,7 +416,7 @@ instance FromJSON AppSettings where
|
||||
let nonEmptyHost LdapConf{..} = case ldapHost of
|
||||
Ldap.Tls host _ -> not $ null host
|
||||
Ldap.Plain host -> not $ null host
|
||||
appLdapConf <- assertM nonEmptyHost <$> o .:? "ldap"
|
||||
appLdapConf <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "ldap" .!= []
|
||||
appSmtpConf <- assertM (not . null . smtpHost) <$> o .:? "smtp"
|
||||
let validMemcachedConf MemcachedConf{memcachedConnectInfo = Memcached.ConnectInfo{..}, ..} = and
|
||||
[ not $ null connectHost
|
||||
@ -462,6 +466,8 @@ instance FromJSON AppSettings where
|
||||
appSynchroniseLdapUsersWithin <- o .:? "synchronise-ldap-users-within"
|
||||
appSynchroniseLdapUsersInterval <- o .: "synchronise-ldap-users-interval"
|
||||
|
||||
appLdapReTestFailover <- o .: "ldap-re-test-failover"
|
||||
|
||||
appSessionFilesExpire <- o .: "session-files-expire"
|
||||
appPruneUnreferencedFiles <- o .:? "prune-unreferenced-files"
|
||||
|
||||
|
||||
18
src/Utils.hs
18
src/Utils.hs
@ -78,6 +78,10 @@ import qualified Data.ByteString.Base64.URL as Base64
|
||||
import qualified Crypto.Saltine.Core.SecretBox as SecretBox
|
||||
import qualified Crypto.Saltine.Class as Saltine
|
||||
import qualified Crypto.Data.PKCS7 as PKCS7
|
||||
import Crypto.MAC.KMAC (KMAC, HashSHAKE)
|
||||
import qualified Crypto.MAC.KMAC as KMAC
|
||||
|
||||
import Data.ByteArray (ByteArrayAccess)
|
||||
|
||||
import Data.Fixed
|
||||
-- import Data.Ratio ((%))
|
||||
@ -963,6 +967,20 @@ encodedSecretBoxOpen ciphertext = do
|
||||
sKey <- secretBoxKey
|
||||
encodedSecretBoxOpen' sKey ciphertext
|
||||
|
||||
|
||||
kmaclazy :: forall a string key ba chunk.
|
||||
( HashSHAKE a
|
||||
, ByteArrayAccess string
|
||||
, ByteArrayAccess key
|
||||
, ByteArrayAccess chunk
|
||||
, LazySequence ba chunk
|
||||
)
|
||||
=> string
|
||||
-> key
|
||||
-> ba
|
||||
-> KMAC a
|
||||
kmaclazy str k = KMAC.finalize . KMAC.updates (KMAC.initialize @a str k) . toChunks
|
||||
|
||||
-------------
|
||||
-- Caching --
|
||||
-------------
|
||||
|
||||
@ -50,10 +50,10 @@ computeMatching :: forall randomGen student course cloneCount cloneIndex capacit
|
||||
, NFData student
|
||||
, Ord studentRatingCourse
|
||||
, Ord courseRatingStudent'
|
||||
, Integral cloneCount, Integral capacity, Num cloneIndex
|
||||
, Integral cloneCount, Integral capacity, Integral cloneIndex
|
||||
)
|
||||
=> randomGen -- ^ Source of randomness
|
||||
-> Map student cloneCount -- ^ requested number of placements per student
|
||||
-> Map student (cloneIndex, cloneCount) -- ^ requested number of placements per student
|
||||
-> Map course (Maybe capacity) -- ^ capacity of courses
|
||||
-> Map (student, course) (studentRatingCourse, courseRatingStudent) -- ^ Mutual preference ordering @(studentRatingCourse, courseRatingStudent)@
|
||||
-> (student -> cloneIndex -> courseRatingStudent -> courseRatingStudent') -- ^ Adjust preference ordering of courses (incorporate central priority)
|
||||
@ -67,10 +67,10 @@ computeMatchingLog :: forall randomGen student course cloneCount cloneIndex capa
|
||||
, NFData student
|
||||
, Ord studentRatingCourse
|
||||
, Ord courseRatingStudent'
|
||||
, Integral cloneCount, Integral capacity, Num cloneIndex
|
||||
, Integral cloneCount, Integral capacity, Integral cloneIndex
|
||||
)
|
||||
=> randomGen -- ^ Source of randomness
|
||||
-> Map student cloneCount -- ^ requested number of placements per student
|
||||
-> Map student (cloneIndex, cloneCount) -- ^ requested number of placements and first cloneIndex per student
|
||||
-> Map course (Maybe capacity) -- ^ capacity of courses
|
||||
-> Map (student, course) (studentRatingCourse, courseRatingStudent) -- ^ Mutual preference ordering @(studentRatingCourse, courseRatingStudent)@
|
||||
-> (student -> cloneIndex -> courseRatingStudent -> courseRatingStudent') -- ^ Adjust preference ordering of courses (incorporate central priority)
|
||||
@ -236,11 +236,14 @@ computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $
|
||||
courseRating c (st, cn) = do
|
||||
(_, courseRating') <- preferences Map.!? (st, c)
|
||||
return $ centralNudge st (fromIntegral cn) courseRating'
|
||||
|
||||
cloneIndices :: cloneIndex -> cloneCount -> Set CloneIndex
|
||||
cloneIndices firstClone clones = Set.fromList $ map fromIntegral [firstClone, pred $ firstClone + fromIntegral clones]
|
||||
|
||||
clonedStudents :: Set (student, CloneIndex)
|
||||
clonedStudents = Set.fromDistinctAscList $ do
|
||||
(student, clones) <- Map.toAscList cloneCounts
|
||||
clone <- [0,1..pred $ fromIntegral clones]
|
||||
(student, (firstClone, clones)) <- Map.toAscList cloneCounts
|
||||
clone <- Set.toAscList $ cloneIndices firstClone clones
|
||||
return (student, clone)
|
||||
|
||||
contStudents :: Iso' student StudentIndex
|
||||
@ -252,7 +255,7 @@ computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $
|
||||
fromInt = (!!) students'
|
||||
|
||||
studentBounds :: ((StudentIndex, CloneIndex), (StudentIndex, CloneIndex))
|
||||
studentBounds = ((0, 0), (pred $ Map.size cloneCounts, maybe 0 maximum . fromNullable $ pred . fromIntegral <$> cloneCounts))
|
||||
studentBounds = ((0, 0), (pred $ Map.size cloneCounts, fromMaybe 0 $ maximumOf (folded . to (uncurry cloneIndices) . folded) cloneCounts))
|
||||
|
||||
courses :: Set course
|
||||
courses = Set.fromDistinctAscList . map (view _1) . filter (maybe True (> 0) . view _2) $ Map.toAscList capacities
|
||||
|
||||
131
src/Utils/Failover.hs
Normal file
131
src/Utils/Failover.hs
Normal file
@ -0,0 +1,131 @@
|
||||
module Utils.Failover
|
||||
( Failover
|
||||
, mkFailover
|
||||
, FailoverMode(..)
|
||||
, withFailover, withFailoverReTest
|
||||
) where
|
||||
|
||||
import ClassyPrelude hiding (try)
|
||||
import Utils (foldMapM)
|
||||
|
||||
import Data.List.PointedList (PointedList)
|
||||
import qualified Data.List.PointedList as P
|
||||
|
||||
import Numeric.Natural
|
||||
|
||||
import System.Clock
|
||||
|
||||
import Control.Lens hiding (failover)
|
||||
import Utils.Lens.TH
|
||||
|
||||
import Data.List (unfoldr, genericTake)
|
||||
|
||||
import Control.Monad.Catch
|
||||
import Control.Monad.Trans.Except (ExceptT, runExceptT)
|
||||
import Control.Monad.Trans.Cont (runContT)
|
||||
import Control.Monad.Cont.Class (MonadCont(..))
|
||||
|
||||
import Control.Concurrent.STM.TVar (stateTVar)
|
||||
|
||||
import Data.Void (vacuous)
|
||||
|
||||
import Data.Fixed
|
||||
|
||||
|
||||
data FailoverItem a = FailoverItem
|
||||
{ failoverValue :: a
|
||||
, failoverLastTest :: Maybe TimeSpec
|
||||
}
|
||||
makeLenses_ ''FailoverItem
|
||||
|
||||
newtype Failover a = Failover { failover :: TVar (PointedList (FailoverItem a)) }
|
||||
deriving (Eq)
|
||||
|
||||
data FailoverMode
|
||||
= FailoverUnlimited
|
||||
| FailoverLimited Natural
|
||||
| FailoverNone
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
|
||||
mkFailover :: MonadIO m
|
||||
=> PointedList a
|
||||
-> m (Failover a)
|
||||
mkFailover opts = fmap Failover . liftIO $ newTVarIO opts'
|
||||
where opts' = opts <&> \failoverValue -> FailoverItem{ failoverLastTest = Nothing, .. }
|
||||
|
||||
|
||||
withFailover :: ( MonadIO m, MonadCatch m
|
||||
, Exception e
|
||||
)
|
||||
=> Failover a
|
||||
-> FailoverMode
|
||||
-> (b -> ExceptT e m c)
|
||||
-> (a -> m b)
|
||||
-> m c
|
||||
withFailover f@Failover{..} mode detAcceptable act = do
|
||||
now <- liftIO $ getTime Monotonic
|
||||
|
||||
FailoverItem{failoverValue} <- fmap (view P.focus) . liftIO $ readTVarIO failover
|
||||
|
||||
res <- act failoverValue
|
||||
res' <- runExceptT $ detAcceptable res
|
||||
|
||||
let
|
||||
recordFailure =
|
||||
atomically . stateTVar failover $ \failover' -> case P.next $ failover' & P.focus . _failoverLastTest ?~ now of
|
||||
Just failover'' -> (True, failover'')
|
||||
Nothing -> (False, failover')
|
||||
doRetry err = do
|
||||
didNext <- recordFailure
|
||||
let newMode = case mode of
|
||||
FailoverLimited n -> FailoverLimited $ pred n
|
||||
other -> other
|
||||
if | didNext -> withFailover f newMode detAcceptable act
|
||||
| otherwise -> throwM err
|
||||
|
||||
case (res', mode) of
|
||||
(Left err, FailoverUnlimited)
|
||||
-> doRetry err
|
||||
(Left err, FailoverLimited n)
|
||||
| n > 0
|
||||
-> doRetry err
|
||||
_other
|
||||
-> void recordFailure >> either throwM return res'
|
||||
|
||||
withFailoverReTest :: ( MonadIO m, MonadCatch m
|
||||
, Exception e
|
||||
)
|
||||
=> Failover a
|
||||
-> (Nano -> Bool)
|
||||
-> FailoverMode
|
||||
-> (b -> ExceptT e m c)
|
||||
-> (a -> m b)
|
||||
-> m c
|
||||
withFailoverReTest f@Failover{..} doTest mode detAcceptable act = do
|
||||
now <- liftIO $ getTime Monotonic
|
||||
|
||||
let filterFailover = filter $ \(view $ _2 . P.focus -> FailoverItem{failoverLastTest}) -> maybe True (\lT -> doTest . MkFixed . toNanoSecs $ now - lT) failoverLastTest
|
||||
|
||||
failover' <- fmap (reverse . filterFailover . unfoldr (\(i, l) -> ((i, ) &&& (succ i, )) <$> P.previous l) . (0,)) . liftIO $ readTVarIO failover
|
||||
|
||||
let failover'' = case mode of
|
||||
FailoverUnlimited -> failover'
|
||||
FailoverLimited n -> genericTake (succ n) failover'
|
||||
FailoverNone -> take 1 failover'
|
||||
|
||||
reTestRes <- flip runContT return . callCC $ \((. Just) -> retRes) -> fmap vacuous . flip foldMapM failover'' $ \failover'''@(over _2 (view P.focus) -> (i, FailoverItem{failoverValue})) -> do
|
||||
res <- lift $ act failoverValue
|
||||
res' <- lift . runExceptT $ detAcceptable res
|
||||
|
||||
case res' of
|
||||
Left _ -> do
|
||||
atomically . modifyTVar failover $ P.reversedPrefix . ix i . _failoverLastTest ?~ now
|
||||
return Nothing
|
||||
Right res'' -> do
|
||||
atomically . writeTVar failover $ view _2 failover''' & P.focus . _failoverLastTest ?~ now
|
||||
retRes res''
|
||||
|
||||
case reTestRes of
|
||||
Nothing -> withFailover f mode detAcceptable act
|
||||
Just r -> return r
|
||||
@ -31,18 +31,23 @@ import Control.Monad.Morph (MFunctor, MMonad)
|
||||
|
||||
|
||||
deriving via (ReaderT (HandlerData site site) IO) instance MonadFix (HandlerFor site)
|
||||
deriving via (ReaderT (HandlerData sub site) IO) instance MonadFix (SubHandlerFor sub site)
|
||||
deriving via (ReaderT (WidgetData site) IO) instance MonadFix (WidgetFor site)
|
||||
|
||||
deriving via (ReaderT (HandlerData site site) IO) instance MonadCatch (HandlerFor site)
|
||||
deriving via (ReaderT (HandlerData sub site) IO) instance MonadCatch (SubHandlerFor sub site)
|
||||
deriving via (ReaderT (WidgetData site) IO) instance MonadCatch (WidgetFor site)
|
||||
|
||||
deriving via (ReaderT (HandlerData site site) IO) instance MonadMask (HandlerFor site)
|
||||
deriving via (ReaderT (HandlerData sub site) IO) instance MonadMask (SubHandlerFor sub site)
|
||||
deriving via (ReaderT (WidgetData site) IO) instance MonadMask (WidgetFor site)
|
||||
|
||||
deriving via (ReaderT (HandlerData site site) IO) instance MonadBase IO (HandlerFor site)
|
||||
deriving via (ReaderT (HandlerData sub site) IO) instance MonadBase IO (SubHandlerFor sub site)
|
||||
deriving via (ReaderT (WidgetData site) IO) instance MonadBase IO (WidgetFor site)
|
||||
|
||||
deriving via (ReaderT (HandlerData site site) IO) instance MonadRandom (HandlerFor site)
|
||||
deriving via (ReaderT (HandlerData sub site) IO) instance MonadRandom (SubHandlerFor sub site)
|
||||
deriving via (ReaderT (WidgetData site) IO) instance MonadRandom (WidgetFor site)
|
||||
|
||||
|
||||
|
||||
@ -17,10 +17,15 @@ $newline never
|
||||
Beim Passwort ist zudem Groß- und Kleinschreibung relevant.
|
||||
|
||||
<p>
|
||||
Uni2work bietet zwei Login-Formulare.<br />
|
||||
|
||||
Uni2work bietet zwei Login-Formulare.
|
||||
<br>
|
||||
Für die Anmeldung mit der LMU-Benutzerkennung (ehem. Campus-Kennung) #
|
||||
müssen Sie das Formular „Campus-Login“ verwenden.
|
||||
<br>
|
||||
Geben Sie unter „Campus-Kennung“ ihre vollständige #
|
||||
LMU-Benutzerkennung an.
|
||||
Diese ist identisch mit ihrer <code>@campus.lmu.de</code> E-Mail #
|
||||
Adresse.
|
||||
|
||||
<p>
|
||||
Falls Sie sich #
|
||||
|
||||
@ -1,31 +1,32 @@
|
||||
$newline never
|
||||
|
||||
<p>
|
||||
|
||||
Can you log in to #
|
||||
the <a href="https://www.portal.uni-muenchen.de">Campus-Portal</a> #
|
||||
using the <i>exact same</i> (ideally copied & pasted) login data?
|
||||
<br>
|
||||
|
||||
If you cannot you can assume that you are entering your login data #
|
||||
wrong or do that you <a href=^{faqLink FAQNoCampusAccount}>do not #
|
||||
have a LMU user ID (formerly Campus-ID)</a>.
|
||||
If you cannot (“Invalid Login”), this means that you are entering #
|
||||
your login data wrong or that you #
|
||||
<a href=^{faqLink FAQNoCampusAccount}>do not have a LMU user ID #
|
||||
(formerly Campus-ID)</a>.
|
||||
|
||||
<p>
|
||||
|
||||
Please consider that for Uni2work both your user ID and password are #
|
||||
sensitive to whitespace characters.
|
||||
<br>
|
||||
Your password is also case-sensitive.
|
||||
|
||||
<p>
|
||||
Uni2work offers to login forms.
|
||||
Uni2work offers two login forms.
|
||||
<br>
|
||||
To log in using your LMU user ID (formerly Campus-ID) you need to #
|
||||
use the form titled “Campus login”.
|
||||
<br>
|
||||
Under “Campus account” please enter either your entire LMU user ID, #
|
||||
which is identical to your <code>@campus.lmu.de<code> email address.
|
||||
|
||||
<p>
|
||||
|
||||
If you can log in to #
|
||||
the <a href="https://www.portal.uni-muenchen.de">Campus-Portal</a> #
|
||||
but can't log in to Uni2work, please contact a #
|
||||
|
||||
@ -26,6 +26,7 @@ $newline never
|
||||
<dd>Der vollständige Name kann zudem beliebige Teile der Vornamen und des akademischen Titels enthalten
|
||||
<dd>So wird der Name anderen Benutzern angezeigt
|
||||
<dt>Matrikelnummer
|
||||
<dd>Auch jene einer externen Institution (z.B. TUM)
|
||||
<dt>Geschlecht
|
||||
<dd>„Unbekannt“, „Männlich“, „Weiblich“ oder „Keine Angabe“
|
||||
$# <dd>Nach <a href="https://en.wikipedia.org/wiki/ISO/IEC_5218">ISO 5218</a>
|
||||
@ -36,3 +37,7 @@ $# <dd>Nach <a href="https://en.wikipedia.org/wiki/ISO/IEC_5218">ISO 5218</a>
|
||||
<dd>An diese Adresse werden Mitteilungen von Uni2work versandt
|
||||
<dd>Die zuverlässige Zustellung muss gewährleistet sein, daher keine Emails von freien Mailanbietern wie GMail, Hotmail, GMX, etc.
|
||||
<dd>Bei externen Studierenden sollte die E-Mail Adresse der externen Institution verwendet werden, z.B. <code>@mytum.de</code> für TUM-Studierende
|
||||
|
||||
<p>
|
||||
Nach Bearbeitung Ihres Anliegens erhalten Sie eine E-Mail, die Sie #
|
||||
auffordern wird ein Passwort zur Anmeldung festzulegen.
|
||||
|
||||
@ -24,6 +24,7 @@ $newline never
|
||||
<dd>The full name must contain the complete surname
|
||||
<dd>The full name may also contain arbitrary components of the given name(s) and academic title
|
||||
<dt>Matriculation number
|
||||
<dd>Matriculations of external instutions (e.g. TUM) are also accepted
|
||||
<dt>Sex
|
||||
<dd>“Not known”, “Male”, “Female”, or “Not specified”
|
||||
<dt>Email address for display
|
||||
@ -33,3 +34,7 @@ $newline never
|
||||
<dd>Uni2work sends notifications to this address
|
||||
<dd>Reliable delivery of email must be ensured. Therefore free mail hosters like GMail, Hotmail, GMX, etc. are not permitted
|
||||
<dd>For external students the email address provided by their institution should be used, e.g. <code>@mytum.de</code> for TUM-students
|
||||
|
||||
<p>
|
||||
After your request has been processed you will receive an email #
|
||||
asking you to set a password to login.
|
||||
|
||||
@ -24,6 +24,8 @@ import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Data.Csv as Csv
|
||||
|
||||
import Crypto.Random (getRandomBytes)
|
||||
|
||||
|
||||
testdataDir :: FilePath
|
||||
testdataDir = "testdata"
|
||||
@ -969,6 +971,7 @@ fillDb = do
|
||||
}
|
||||
|
||||
|
||||
aSeedFunc <- liftIO $ getRandomBytes 40
|
||||
funAlloc <- insert' Allocation
|
||||
{ allocationName = "Funktionale Zentralanmeldung"
|
||||
, allocationShorthand = "fun"
|
||||
@ -986,6 +989,7 @@ fillDb = do
|
||||
, allocationRegisterByStaffTo = Nothing
|
||||
, allocationRegisterByCourse = Nothing
|
||||
, allocationOverrideDeregister = Just $ termTime True Summer 1 False Monday toMidnight
|
||||
, allocationMatchingSeed = aSeedFunc
|
||||
}
|
||||
insert_ $ AllocationCourse funAlloc pmo 100
|
||||
insert_ $ AllocationCourse funAlloc ffp 2
|
||||
@ -1088,6 +1092,7 @@ fillDb = do
|
||||
forM_ (take participants manyUsers') $ \uid ->
|
||||
void . insert $ CourseParticipant cid uid now Nothing Nothing
|
||||
|
||||
aSeedBig <- liftIO $ getRandomBytes 40
|
||||
bigAlloc <- insert' Allocation
|
||||
{ allocationName = "Große Zentralanmeldung"
|
||||
, allocationShorthand = "big"
|
||||
@ -1105,6 +1110,7 @@ fillDb = do
|
||||
, allocationRegisterByStaffTo = Nothing
|
||||
, allocationRegisterByCourse = Nothing
|
||||
, allocationOverrideDeregister = Just $ termTime True Summer 1 False Monday toMidnight
|
||||
, allocationMatchingSeed = aSeedBig
|
||||
}
|
||||
bigAllocCourses <- forM ([1..40] :: [Int]) $ \n -> do
|
||||
csh <- pack . take 3 <$> getRandomRs ('A', 'Z')
|
||||
|
||||
@ -22,7 +22,7 @@ spec :: Spec
|
||||
spec = describe "computeMatching" $
|
||||
it "produces some expected known matchings" $ do
|
||||
example $ do
|
||||
let men = Map.fromList $ (, 1) <$> [Alpha .. Gamma]
|
||||
let men = Map.fromList $ (, (0, 1)) <$> [Alpha .. Gamma]
|
||||
women = Map.fromList $ (, Just 1) <$> [Alef .. Gimel]
|
||||
preferences = fmap ((3 -) *** (3 -)) $ Map.fromList
|
||||
[ ((Alpha, Alef ), (1, 3))
|
||||
@ -43,7 +43,7 @@ spec = describe "computeMatching" $
|
||||
ourResult `shouldBe` expectedResult
|
||||
|
||||
example $ do
|
||||
let men = Map.fromList $ (, 2) <$> [Alpha,Beta,Delta]
|
||||
let men = Map.fromList $ (, (0, 2)) <$> [Alpha,Beta,Delta]
|
||||
women = Map.fromList $ (, Just 1) <$> [Alef .. Gimel]
|
||||
preferences = fmap ((3 -) *** (3 -)) $ Map.fromList
|
||||
[ ((Alpha, Alef ), (1, 3))
|
||||
@ -64,7 +64,7 @@ spec = describe "computeMatching" $
|
||||
ourResult `shouldBe` expectedResult
|
||||
|
||||
example $ do
|
||||
let men = Map.fromList $ (, 2) <$> [Alpha .. Gamma]
|
||||
let men = Map.fromList $ (, (0, 2)) <$> [Alpha .. Gamma]
|
||||
women = Map.fromList $ (, Just 2) <$> [Alef .. Gimel]
|
||||
preferences = fmap ((3 -) *** (3 -)) $ Map.fromList
|
||||
[ ((Alpha, Alef ), (1, 3))
|
||||
@ -85,7 +85,7 @@ spec = describe "computeMatching" $
|
||||
ourResult `shouldBe` expectedResult
|
||||
|
||||
example $ do
|
||||
let men = Map.fromList $ (, 1) <$> [Alpha .. Delta]
|
||||
let men = Map.fromList $ (, (0, 1)) <$> [Alpha .. Delta]
|
||||
women = Map.fromList $ (, Just 1) <$> [Alef .. Dalet]
|
||||
preferences = fmap ((4 -) *** (4 -)) $ Map.fromList
|
||||
[ ((Alpha, Alef ), (1, 3))
|
||||
@ -113,7 +113,7 @@ spec = describe "computeMatching" $
|
||||
ourResult `shouldBe` expectedResult
|
||||
|
||||
example $ do
|
||||
let men = Map.fromList $ (, 1) <$> [Alpha .. Delta]
|
||||
let men = Map.fromList $ (, (0, 1)) <$> [Alpha .. Delta]
|
||||
women = Map.fromList $ (, Just 1) <$> [Alef .. Dalet]
|
||||
preferences = fmap ((4 -) *** (4 -)) $ Map.fromList
|
||||
[ ((Alpha, Alef ), (1, 3))
|
||||
@ -141,7 +141,7 @@ spec = describe "computeMatching" $
|
||||
ourResult `shouldBe` expectedResult
|
||||
|
||||
example $ do
|
||||
let students = Map.fromList $ (, 1) <$> ([1..6] :: [Int])
|
||||
let students = Map.fromList $ (, (0, 1)) <$> ([1..6] :: [Int])
|
||||
colleges = Map.fromList $ (, Just 2) <$> (['A', 'Z', 'C'] :: [Char])
|
||||
student_preferences = Map.fromList
|
||||
[ ((1, 'A'), 3), ((1, 'Z'), 2), ((1, 'C'), 1)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user