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