Merge branch 'master' into feat/feste-abgabegruppen

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)
 
 

config/settings.yml

@@ -92,19 +92,21 @@ database:
 auto-db-migrate: '_env:AUTO_DB_MIGRATE:true'
 
 ldap:
-  host:    "_env:LDAPHOST:"
+  - host:    "_env:LDAPHOST:"
-  tls:     "_env:LDAPTLS:"
+    tls:     "_env:LDAPTLS:"
-  port:    "_env:LDAPPORT:389"
+    port:    "_env:LDAPPORT:389"
-  user:    "_env:LDAPUSER:"
+    user:    "_env:LDAPUSER:"
-  pass:    "_env:LDAPPASS:"
+    pass:    "_env:LDAPPASS:"
-  baseDN:  "_env:LDAPBASE:"
+    baseDN:  "_env:LDAPBASE:"
-  scope:   "_env:LDAPSCOPE:WholeSubtree"
+    scope:   "_env:LDAPSCOPE:WholeSubtree"
-  timeout: "_env:LDAPTIMEOUT:5"
+    timeout: "_env:LDAPTIMEOUT:5"
-  search-timeout: "_env:LDAPSEARCHTIME:5"
+    search-timeout: "_env:LDAPSEARCHTIME:5"
-  pool:
+    pool:
-    stripes: "_env:LDAPSTRIPES:1"
+      stripes: "_env:LDAPSTRIPES:1"
-    timeout: "_env:LDAPTIMEOUT:20"
+      timeout: "_env:LDAPTIMEOUT:20"
-    limit:   "_env:LDAPLIMIT:10"
+      limit:   "_env:LDAPLIMIT:10"
+
+ldap-re-test-failover: 60
 
 smtp:
   host:    "_env:SMTPHOST:"

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.

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

package-lock.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "15.3.0",
+  "version": "15.5.0",
   "lockfileVersion": 1,
   "requires": true,
   "dependencies": {

package.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "15.3.0",
+  "version": "15.5.0",
   "description": "",
   "keywords": [],
   "author": "",

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

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

src/Application.hs

@@ -209,9 +209,9 @@ makeFoundation appSettings'@AppSettings{..} = do
         (pgConnStr  appDatabaseConf)
         (pgPoolSize appDatabaseConf)
 
-      ldapPool <- for appLdapConf $ \LdapConf{..} -> do
+      ldapPool <- traverse mkFailover <=< forOf (traverse . traverse) appLdapConf $ \conf@LdapConf{..} -> do
-        $logDebugS "setup" "LDAP-Pool"
+        $logDebugS "setup" $ "LDAP-Pool " <> tshow ldapHost
-        createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool)
+        (conf,) <$> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool)
 
       -- Perform database migration using our application's logging settings.
       if

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 [])
+campusUserWith :: MonadUnliftIO m
-campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do
+               => (    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 []))
+campusUserReTest  :: MonadUnliftIO m => Failover (LdapConf, LdapPool) -> (Nano -> Bool) -> FailoverMode -> Creds site -> m (Ldap.AttrList [])
-campusUser' conf pool User{userIdent}
+campusUserReTest pool doTest = campusUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool
-  = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser conf pool (Creds apLdap (CI.original userIdent) [])
+
+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 :: MonadUnliftIO m => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Ldap.AttrList [])
-campusUserMatr conf@LdapConf{..} pool userMatr = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do
+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' :: (MonadCatch m, MonadUnliftIO m) => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Maybe (Ldap.AttrList []))
-campusUserMatr' conf pool
+campusUserMatr' pool mode
-  = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) . campusUserMatr conf pool
+  = 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
+               ) => Failover (LdapConf, LdapPool) -> FailoverMode -> AuthPlugin site
-campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
+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

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

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
+      flip catches excHandlers $ case appLdapPool of
-        Just (ldapConf, ldapPool)
+        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
 
   

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)

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

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

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
+                Just pool <- getsYesod $ view _appLdapPool
-                void . lift . Auth.campusUser conf pool $ Creds Auth.apLdap (CI.original userIdent) []
+                void . lift . Auth.campusUser pool FailoverUnlimited $ Creds Auth.apLdap (CI.original userIdent) []
             case campusResult of
               Nothing -> addMessageI Error MsgAuthLDAPInvalidLookup
               _other

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
+    inputs = Binary.encode (users'', capacities, preferences, gradeScale, gradeOrdinalPlaces)
-    fingerprint = Crypto.hash . toStrict $ 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))

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.

src/Handler/Utils/Users.hs

@@ -100,10 +100,9 @@ guessUser (Set.toList -> criteria) = $cachedHereBinary criteria $ go False
             ]
 
           doLdap userMatr = do
-            app <- getYesod
+            ldapPool' <- getsYesod $ view _appLdapPool
-            let ldap = (,) <$> app ^. _appLdapConf <*> app ^. _appLdapPool
+            fmap (fmap entityKey . join) . for ldapPool' $ \ldapPool -> do
-            fmap (fmap entityKey . join) . for ldap $ \(ldapConf, ldapPool) -> do
+              ldapData <- campusUserMatr' ldapPool FailoverUnlimited userMatr
-              ldapData <- campusUserMatr' ldapConf ldapPool userMatr
               for ldapData $ upsertCampusUser UpsertCampusUser
 
       if

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

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 ( (<.>)

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
+  case appLdapPool of
-    Just (ldapConf, ldapPool) -> 
+    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

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
+  reTestAfter <- getsYesod $ view _appLdapReTestFailover
-  ldapAdminUsers <- fmap (map E.unValue) . runDB . E.select . E.from $ \(user `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
+  case ldapPool' of
-    E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
+    Just ldapPool -> do
-    E.where_ $ user E.^. UserAuthentication E.==. E.val AuthLDAP
+      ldapAdminUsers' <- fmap (map E.unValue) . runDB . E.select . E.from $ \(user `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
-    return $ user E.^. UserIdent
+        E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
-  case (,) <$> ldapPool' <*> ldapConf' of
+        E.where_ $ user E.^. UserAuthentication E.==. E.val AuthLDAP
-    Just (ldapPool, ldapConf)
+        return $ user E.^. UserIdent
-      | not $ null ldapAdminUsers
+      for (assertM' (not . null) ldapAdminUsers') $ \ldapAdminUsers -> do
-        -> do
+        let numAdmins = genericLength ldapAdminUsers
-          let numAdmins = genericLength ldapAdminUsers
+            hCampusExc :: CampusUserException -> Handler (Sum Integer)
-              hCampusExc :: CampusUserException -> Handler (Sum Integer)
+            hCampusExc _ = return $ Sum 0
-              hCampusExc _ = return $ Sum 0
+        Sum numResolved <- fmap fold . forM ldapAdminUsers $
-          Sum numResolved <- fmap fold . forM ldapAdminUsers $
+          \(CI.original -> adminIdent) -> handle hCampusExc $ Sum 1 <$ campusUserReTest ldapPool ((>= reTestAfter) . realToFrac) FailoverUnlimited (Creds "LDAP" adminIdent [])
-            \(CI.original -> adminIdent) -> handle hCampusExc $ Sum 1 <$ campusUser ldapConf ldapPool (Creds "LDAP" adminIdent [])
+        return $ numResolved % numAdmins
-          return . Just $ numResolved % numAdmins
     _other -> return Nothing
 
 

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 :: (MonadUnliftIO m, MonadCatch m, Typeable a) => LdapPool -> (Ldap -> m a) -> m (Either LdapPoolError a)
-withLdap pool act = withResource pool $ \LdapExecutor{..} -> ldapExec act
+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 )

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"
 

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 --
 -------------

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
+      (student, (firstClone, clones)) <- Map.toAscList cloneCounts
-      clone <- [0,1..pred $ fromIntegral clones]
+      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

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

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)
 
 

templates/i18n/faq/campus-cant-login.de-de-formal.hamlet

@@ -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 #

templates/i18n/faq/campus-cant-login.en-eu.hamlet

@@ -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 #
+  If you cannot (“Invalid Login”), this means that you are entering #
-  wrong or do that you <a href=^{faqLink FAQNoCampusAccount}>do not #
+  your login data wrong or that you #
-  have a LMU user ID (formerly Campus-ID)</a>.
+  <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 #

templates/i18n/faq/no-campus-account.de-de-formal.hamlet

@@ -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.

templates/i18n/faq/no-campus-account.en-eu.hamlet

@@ -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.

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')

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)