From 02d284fb876af3256ef2bd82b92c40f3be36c446 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 24 Apr 2020 18:15:00 +0200 Subject: [PATCH 01/12] fix(faqs): wording --- .../faq/campus-cant-login.de-de-formal.hamlet | 9 +++++++-- templates/i18n/faq/campus-cant-login.en-eu.hamlet | 15 ++++++++------- .../faq/no-campus-account.de-de-formal.hamlet | 1 + templates/i18n/faq/no-campus-account.en-eu.hamlet | 1 + 4 files changed, 17 insertions(+), 9 deletions(-) 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..0f6470454 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 diff --git a/templates/i18n/faq/no-campus-account.en-eu.hamlet b/templates/i18n/faq/no-campus-account.en-eu.hamlet index 27f0ac830..d281e8b5d 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 From 32097d18f9d5411e1bf8a3923ad8f04dcc7b4c83 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 24 Apr 2020 18:18:40 +0200 Subject: [PATCH 02/12] fix(faqs): mention mail to set password --- templates/i18n/faq/no-campus-account.de-de-formal.hamlet | 4 ++++ templates/i18n/faq/no-campus-account.en-eu.hamlet | 4 ++++ 2 files changed, 8 insertions(+) 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 0f6470454..c27772266 100644 --- a/templates/i18n/faq/no-campus-account.de-de-formal.hamlet +++ b/templates/i18n/faq/no-campus-account.de-de-formal.hamlet @@ -37,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 d281e8b5d..1daaf4814 100644 --- a/templates/i18n/faq/no-campus-account.en-eu.hamlet +++ b/templates/i18n/faq/no-campus-account.en-eu.hamlet @@ -34,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. From c06a4723591cc3d716b2d6b39f2757e17387ae47 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 24 Apr 2020 18:45:39 +0200 Subject: [PATCH 03/12] fix: typo --- messages/uniworx/de-de-formal.msg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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. From 71559c93020b0c86fc85834e6340c76b3b3fb960 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 24 Apr 2020 18:53:18 +0200 Subject: [PATCH 04/12] chore(release): 15.4.0 --- CHANGELOG.md | 21 +++++++++++++++++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 24 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 6fa38a48e..3c1bc32ce 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,27 @@ 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.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/package-lock.json b/package-lock.json index 6e0d5a5b6..373060466 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "15.3.0", + "version": "15.4.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 5fe2612d4..218a524b3 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "15.3.0", + "version": "15.4.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 14f2ea467..deb0239db 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 15.3.0 +version: 15.4.0 dependencies: - base From e1c6fd43b807abd3126b7ae8b948f585416f883c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 26 Apr 2020 13:21:56 +0200 Subject: [PATCH 05/12] fix(allocation): don't restart cloneCount when allocating successors --- src/Handler/Utils/Allocation.hs | 2 +- src/Utils/Allocation.hs | 17 ++++++++++------- test/Utils/AllocationSpec.hs | 12 ++++++------ 3 files changed, 17 insertions(+), 14 deletions(-) diff --git a/src/Handler/Utils/Allocation.hs b/src/Handler/Utils/Allocation.hs index 1b7d90e63..ee5036802 100644 --- a/src/Handler/Utils/Allocation.hs +++ b/src/Handler/Utils/Allocation.hs @@ -105,7 +105,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'' 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/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) From 11c86bb5fa9a2bc5357ea4e986862acd01a4442f Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 26 Apr 2020 13:23:04 +0200 Subject: [PATCH 06/12] chore(release): 15.4.1 --- CHANGELOG.md | 9 +++++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 12 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 3c1bc32ce..2d4ad76f7 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,15 @@ 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.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) diff --git a/package-lock.json b/package-lock.json index 373060466..0100919bf 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "15.4.0", + "version": "15.4.1", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 218a524b3..bc32cb51f 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "15.4.0", + "version": "15.4.1", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index deb0239db..48e099fc9 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 15.4.0 +version: 15.4.1 dependencies: - base From 3ea7371465194decf072bf038c6d05b4790b6520 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 27 Apr 2020 09:12:32 +0200 Subject: [PATCH 07/12] feat(allocations): switch to csprng --- models/allocations.model | 1 + src/Crypto/Random/Instances.hs | 19 +++++++++++++++++++ src/Handler/Allocation/Compute.hs | 2 +- src/Handler/Utils/Allocation.hs | 20 +++++++++++++------- src/Handler/Utils/Memcached.hs | 4 +--- src/Import/NoModel.hs | 2 ++ src/Utils.hs | 18 ++++++++++++++++++ test/Database/Fill.hs | 6 ++++++ 8 files changed, 61 insertions(+), 11 deletions(-) create mode 100644 src/Crypto/Random/Instances.hs 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/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/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/Utils/Allocation.hs b/src/Handler/Utils/Allocation.hs index ee5036802..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) @@ -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/Import/NoModel.hs b/src/Import/NoModel.hs index 43b7d09d1..65bd3603d 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -156,8 +156,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/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/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') From 31aa25a1fd6acd0994e2af156b4b166b3717de13 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 27 Apr 2020 10:44:04 +0200 Subject: [PATCH 08/12] feat(news): timeout sheets after a month --- src/Handler/News.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) 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 From e0c05f39d4c162dc793745325b69807a59df0c5e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 27 Apr 2020 10:45:31 +0200 Subject: [PATCH 09/12] fix(auth): tutors may see sheet list --- routes | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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 From 0e68b6cf5348bbf5baa5014a86be321a7e5e4b49 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 27 Apr 2020 16:17:00 +0200 Subject: [PATCH 10/12] feat(ldap): failover --- config/settings.yml | 28 +++--- package.yaml | 2 + src/Application.hs | 6 +- src/Auth/LDAP.hs | 47 +++++++--- src/Foundation.hs | 11 ++- src/Foundation/Type.hs | 2 +- src/Handler/Users.hs | 4 +- src/Handler/Utils/Users.hs | 7 +- src/Import/NoFoundation.hs | 1 + src/Import/NoModel.hs | 2 + src/Jobs/Handler/SynchroniseLdap.hs | 7 +- src/Jobs/HealthReport.hs | 29 +++--- src/Ldap/Client/Pool.hs | 17 +++- src/Settings.hs | 10 ++- src/Utils/Failover.hs | 131 ++++++++++++++++++++++++++++ src/Yesod/Core/Types/Instances.hs | 5 ++ 16 files changed, 246 insertions(+), 63 deletions(-) create mode 100644 src/Utils/Failover.hs 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/package.yaml b/package.yaml index 48e099fc9..11a03591f 100644 --- a/package.yaml +++ b/package.yaml @@ -145,6 +145,8 @@ dependencies: - pandoc - token-bucket - async + - pointedlist + - clock other-extensions: - GeneralizedNewtypeDeriving 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/Foundation.hs b/src/Foundation.hs index 77f0828d8..7aee3ddff 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -4893,17 +4893,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 +4926,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/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/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 65bd3603d..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 () 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/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) From 76098cc3c84e1e51cfadc381347aae483d62dbeb Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 27 Apr 2020 16:37:39 +0200 Subject: [PATCH 11/12] fix(campus): fix corner case with study features results in uglier features (more unnecessary inactive features) --- src/Foundation.hs | 13 +++---------- 1 file changed, 3 insertions(+), 10 deletions(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index 7aee3ddff..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 From 4fbed675afab6e8262a1f608c6e11bbf89f330be Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 27 Apr 2020 16:50:23 +0200 Subject: [PATCH 12/12] chore(release): 15.5.0 --- CHANGELOG.md | 17 +++++++++++++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 20 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 2d4ad76f7..49c2c4813 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,23 @@ 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) diff --git a/package-lock.json b/package-lock.json index 0100919bf..af0305054 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "15.4.1", + "version": "15.5.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index bc32cb51f..1bd6ee2d2 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "15.4.1", + "version": "15.5.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 11a03591f..fac4befcd 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 15.4.1 +version: 15.5.0 dependencies: - base