diff --git a/CHANGELOG.md b/CHANGELOG.md
index 6fa38a48e..49c2c4813 100644
--- a/CHANGELOG.md
+++ b/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)
diff --git a/config/settings.yml b/config/settings.yml
index 85cd909e6..47c517a15 100644
--- a/config/settings.yml
+++ b/config/settings.yml
@@ -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:"
diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg
index 11772317c..e18996e77 100644
--- a/messages/uniworx/de-de-formal.msg
+++ b/messages/uniworx/de-de-formal.msg
@@ -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.
diff --git a/models/allocations.model b/models/allocations.model
index a382269cb..db56d37cd 100644
--- a/models/allocations.model
+++ b/models/allocations.model
@@ -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
diff --git a/package-lock.json b/package-lock.json
index 6e0d5a5b6..af0305054 100644
--- a/package-lock.json
+++ b/package-lock.json
@@ -1,6 +1,6 @@
{
"name": "uni2work",
- "version": "15.3.0",
+ "version": "15.5.0",
"lockfileVersion": 1,
"requires": true,
"dependencies": {
diff --git a/package.json b/package.json
index 5fe2612d4..1bd6ee2d2 100644
--- a/package.json
+++ b/package.json
@@ -1,6 +1,6 @@
{
"name": "uni2work",
- "version": "15.3.0",
+ "version": "15.5.0",
"description": "",
"keywords": [],
"author": "",
diff --git a/package.yaml b/package.yaml
index 14f2ea467..fac4befcd 100644
--- a/package.yaml
+++ b/package.yaml
@@ -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
diff --git a/routes b/routes
index f065074cf..14a99926e 100644
--- a/routes
+++ b/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
diff --git a/src/Application.hs b/src/Application.hs
index fa6992621..51bef9a21 100644
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -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
diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs
index feaa31c44..8f0a40f98 100644
--- a/src/Auth/LDAP.hs
+++ b/src/Auth/LDAP.hs
@@ -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
diff --git a/src/Crypto/Random/Instances.hs b/src/Crypto/Random/Instances.hs
new file mode 100644
index 000000000..068760c2b
--- /dev/null
+++ b/src/Crypto/Random/Instances.hs
@@ -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
diff --git a/src/Foundation.hs b/src/Foundation.hs
index 77f0828d8..73a223407 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -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
diff --git a/src/Foundation/Type.hs b/src/Foundation/Type.hs
index 235b46c20..6dd5305f6 100644
--- a/src/Foundation/Type.hs
+++ b/src/Foundation/Type.hs
@@ -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)
diff --git a/src/Handler/Allocation/Compute.hs b/src/Handler/Allocation/Compute.hs
index b579c056e..9c8b300e6 100644
--- a/src/Handler/Allocation/Compute.hs
+++ b/src/Handler/Allocation/Compute.hs
@@ -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
diff --git a/src/Handler/News.hs b/src/Handler/News.hs
index f6d91519e..d2cd1f9a0 100644
--- a/src/Handler/News.hs
+++ b/src/Handler/News.hs
@@ -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
diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs
index ee0d67d85..bcc916a16 100644
--- a/src/Handler/Users.hs
+++ b/src/Handler/Users.hs
@@ -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
diff --git a/src/Handler/Utils/Allocation.hs b/src/Handler/Utils/Allocation.hs
index 1b7d90e63..6381f8f61 100644
--- a/src/Handler/Utils/Allocation.hs
+++ b/src/Handler/Utils/Allocation.hs
@@ -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))
diff --git a/src/Handler/Utils/Memcached.hs b/src/Handler/Utils/Memcached.hs
index be68f2d63..8a9efb46d 100644
--- a/src/Handler/Utils/Memcached.hs
+++ b/src/Handler/Utils/Memcached.hs
@@ -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.
diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs
index bd95b8be3..be010ee94 100644
--- a/src/Handler/Utils/Users.hs
+++ b/src/Handler/Utils/Users.hs
@@ -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
diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs
index 7212ff285..1e3925395 100644
--- a/src/Import/NoFoundation.hs
+++ b/src/Import/NoFoundation.hs
@@ -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
diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs
index 43b7d09d1..3a5365c57 100644
--- a/src/Import/NoModel.hs
+++ b/src/Import/NoModel.hs
@@ -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 ( (<.>)
diff --git a/src/Jobs/Handler/SynchroniseLdap.hs b/src/Jobs/Handler/SynchroniseLdap.hs
index 1c82569ed..42c40db87 100644
--- a/src/Jobs/Handler/SynchroniseLdap.hs
+++ b/src/Jobs/Handler/SynchroniseLdap.hs
@@ -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
diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs
index 90ddf8966..fb8e67ae1 100644
--- a/src/Jobs/HealthReport.hs
+++ b/src/Jobs/HealthReport.hs
@@ -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
diff --git a/src/Ldap/Client/Pool.hs b/src/Ldap/Client/Pool.hs
index 9a33e9e0f..d85028187 100644
--- a/src/Ldap/Client/Pool.hs
+++ b/src/Ldap/Client/Pool.hs
@@ -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 )
diff --git a/src/Settings.hs b/src/Settings.hs
index ce756983e..22454a0df 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -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"
diff --git a/src/Utils.hs b/src/Utils.hs
index ffc77197e..e9d75dd61 100644
--- a/src/Utils.hs
+++ b/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 --
-------------
diff --git a/src/Utils/Allocation.hs b/src/Utils/Allocation.hs
index 0fc994407..323985f6a 100644
--- a/src/Utils/Allocation.hs
+++ b/src/Utils/Allocation.hs
@@ -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
diff --git a/src/Utils/Failover.hs b/src/Utils/Failover.hs
new file mode 100644
index 000000000..112ceab53
--- /dev/null
+++ b/src/Utils/Failover.hs
@@ -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
diff --git a/src/Yesod/Core/Types/Instances.hs b/src/Yesod/Core/Types/Instances.hs
index 042255544..62ffbdb4c 100644
--- a/src/Yesod/Core/Types/Instances.hs
+++ b/src/Yesod/Core/Types/Instances.hs
@@ -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)
diff --git a/templates/i18n/faq/campus-cant-login.de-de-formal.hamlet b/templates/i18n/faq/campus-cant-login.de-de-formal.hamlet
index 1a4666f48..17d7e6768 100644
--- a/templates/i18n/faq/campus-cant-login.de-de-formal.hamlet
+++ b/templates/i18n/faq/campus-cant-login.de-de-formal.hamlet
@@ -17,10 +17,15 @@ $newline never
Beim Passwort ist zudem Groß- und Kleinschreibung relevant.
- Uni2work bietet zwei Login-Formulare.
-
+ Uni2work bietet zwei Login-Formulare.
+
Für die Anmeldung mit der LMU-Benutzerkennung (ehem. Campus-Kennung) #
müssen Sie das Formular „Campus-Login“ verwenden.
+
+ Geben Sie unter „Campus-Kennung“ ihre vollständige #
+ LMU-Benutzerkennung an.
+ Diese ist identisch mit ihrer @campus.lmu.de E-Mail #
+ Adresse.
Falls Sie sich #
diff --git a/templates/i18n/faq/campus-cant-login.en-eu.hamlet b/templates/i18n/faq/campus-cant-login.en-eu.hamlet
index 6ab25f1eb..a9d7ead40 100644
--- a/templates/i18n/faq/campus-cant-login.en-eu.hamlet
+++ b/templates/i18n/faq/campus-cant-login.en-eu.hamlet
@@ -1,31 +1,32 @@
$newline never
-
Can you log in to #
the Campus-Portal #
using the exact same (ideally copied & pasted) login data?
- If you cannot you can assume that you are entering your login data #
- wrong or do that you do not #
- have a LMU user ID (formerly Campus-ID).
+ If you cannot (“Invalid Login”), this means that you are entering #
+ your login data wrong or that you #
+ do not have a LMU user ID #
+ (formerly Campus-ID).
-
Please consider that for Uni2work both your user ID and password are #
sensitive to whitespace characters.
Your password is also case-sensitive.
- Uni2work offers to login forms.
+ Uni2work offers two login forms.
To log in using your LMU user ID (formerly Campus-ID) you need to #
use the form titled “Campus login”.
+
+ Under “Campus account” please enter either your entire LMU user ID, #
+ which is identical to your @campus.lmu.de email address.
-
If you can log in to #
the Campus-Portal #
but can't log in to Uni2work, please contact a #
diff --git a/templates/i18n/faq/no-campus-account.de-de-formal.hamlet b/templates/i18n/faq/no-campus-account.de-de-formal.hamlet
index 97e2c91d8..c27772266 100644
--- a/templates/i18n/faq/no-campus-account.de-de-formal.hamlet
+++ b/templates/i18n/faq/no-campus-account.de-de-formal.hamlet
@@ -26,6 +26,7 @@ $newline never
Der vollständige Name kann zudem beliebige Teile der Vornamen und des akademischen Titels enthalten
So wird der Name anderen Benutzern angezeigt
Matrikelnummer
+ Auch jene einer externen Institution (z.B. TUM)
Geschlecht
„Unbekannt“, „Männlich“, „Weiblich“ oder „Keine Angabe“
$# Nach ISO 5218
@@ -36,3 +37,7 @@ $# Nach ISO 5218
An diese Adresse werden Mitteilungen von Uni2work versandt
Die zuverlässige Zustellung muss gewährleistet sein, daher keine Emails von freien Mailanbietern wie GMail, Hotmail, GMX, etc.
Bei externen Studierenden sollte die E-Mail Adresse der externen Institution verwendet werden, z.B. @mytum.de für TUM-Studierende
+
+
+ Nach Bearbeitung Ihres Anliegens erhalten Sie eine E-Mail, die Sie #
+ auffordern wird ein Passwort zur Anmeldung festzulegen.
diff --git a/templates/i18n/faq/no-campus-account.en-eu.hamlet b/templates/i18n/faq/no-campus-account.en-eu.hamlet
index 27f0ac830..1daaf4814 100644
--- a/templates/i18n/faq/no-campus-account.en-eu.hamlet
+++ b/templates/i18n/faq/no-campus-account.en-eu.hamlet
@@ -24,6 +24,7 @@ $newline never
The full name must contain the complete surname
The full name may also contain arbitrary components of the given name(s) and academic title
Matriculation number
+ Matriculations of external instutions (e.g. TUM) are also accepted
Sex
“Not known”, “Male”, “Female”, or “Not specified”
Email address for display
@@ -33,3 +34,7 @@ $newline never
Uni2work sends notifications to this address
Reliable delivery of email must be ensured. Therefore free mail hosters like GMail, Hotmail, GMX, etc. are not permitted
For external students the email address provided by their institution should be used, e.g. @mytum.de for TUM-students
+
+
+ After your request has been processed you will receive an email #
+ asking you to set a password to login.
diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs
index 3d829a35d..135d222e4 100644
--- a/test/Database/Fill.hs
+++ b/test/Database/Fill.hs
@@ -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')
diff --git a/test/Utils/AllocationSpec.hs b/test/Utils/AllocationSpec.hs
index 361763b4d..93aed0e2c 100644
--- a/test/Utils/AllocationSpec.hs
+++ b/test/Utils/AllocationSpec.hs
@@ -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)