feat(allocations): switch to csprng

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

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

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

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