feat(personalised-sheet-files): seeds

messages/uniworx/categories/courses/sheet/de-de-formal.msg

@@ -42,6 +42,8 @@ SheetPersonalisedFilesAllowNonPersonalisedSubmission: Nicht-personalisierte Abga
 SheetPersonalisedFilesAllowNonPersonalisedSubmissionTip: Sollen auch Kursteilnehmer:innen abgeben dürfen, für die keine personalisierten Dateien hinterlegt wurden?
 SheetPersonalisedFilesDownloadTemplateHere: Sie können hier ein Vorlage-Archiv für die vom System erwartete Verzeichnisstruktur für personalisierte Übungsblatt-Dateien herunterladen:
 SheetPersonalisedFilesUsersList: Liste von Teilnehmern mit personalisierten Übungsblatt-Dateien
+SheetPersonalisedFilesMetaYAMLSeedComment: Dieser String wird in einem kryptographischen Verfahren aus Daten generiert, die Benutzer:in und Übungsblatt eindeutig identifizieren. Er ist geeignet als Seed für einen Pseudozufallsgenerator verwendet zu werden um personalisierte Dateien (teil-)zufällig zu erzeugen.
+SheetPersonalisedFilesMetaYAMLNoSeedComment: Damit genügend Informationen vorhanden sind um Anhand von Daten des/der Benutzer/Benutzerin an dieser Stelle einen String zu erzeugen, der als Seed für einen Pseudozufallsgenerator geeignet ist, muss das Übungsblatt zunächst in Uni2work angelegt werden.
 SheetActiveFromTip: Download der Aufgabenstellung und Abgabe erst ab diesem Datum möglich. Ohne Datum keine Abgabe und keine Herausgabe der Aufgabenstellung
 SheetActiveToTip: Abgabe nur bis zu diesem Datum möglich. Ohne Datum unbeschränkte Abgabe möglich (soweit gefordert).
 SheetHintFrom: Hinweis ab

messages/uniworx/categories/courses/sheet/en-eu.msg

@@ -42,6 +42,8 @@ SheetPersonalisedFilesAllowNonPersonalisedSubmission: Allow non-personalised sub
 SheetPersonalisedFilesAllowNonPersonalisedSubmissionTip: Should course participants with no assigned personalised files be allowed to submit anyway?
 SheetPersonalisedFilesDownloadTemplateHere: You can download a template for a ZIP-archive of personalised sheet files with the structure that Uni2work expects here:
 SheetPersonalisedFilesUsersList: List of course participants who have personalised sheet files
+SheetPersonalisedFilesMetaYAMLSeedComment: This string was generated cryptographically from data uniquely identifying the user and exercise sheet. You can use it as a seed for a pseudorandom generator for generating (parts of) the personalised files.
+SheetPersonalisedFilesMetaYAMLNoSeedComment: There is not enough information available to generate a seed. You will have to create the exercise sheet in Uni2work first. Once seeds can be generated they will be generated cryptographically and you may use them to generate (parts of) the personalised files.
 SheetActiveFromTip: The exercise sheet's assignment will only be available for download and submission starting at this time. If left empty no submission or download of assignment is ever allowed
 SheetActiveToTip: Submission will only be possible until this time. If left empty submissions are allowed forever (if at all possible)
 SheetHintFrom: Hint from

models/sheets.model

@@ -59,9 +59,9 @@ PersonalisedSheetFile
     deriving Eq Ord Read Show Typeable Generic
 
 FallbackPersonalisedSheetFilesKey
-    course    CourseId OnDeleteCascade OnUpdateCascade
+    course     CourseId OnDeleteCascade OnUpdateCascade
-    index     Word24
+    index      Word24
-    secret    ByteString
+    secret     ByteString
-    generated UTCTime
+    generated  UTCTime
     UniqueFallbackPersonalisedSheetFilesKey course index
     deriving Generic

shell.nix

@@ -252,8 +252,14 @@ let
       sleep 1
     done
   '';
+
+  diffRunning = pkgs.writeScriptBin "diff-running" ''
+    #!${pkgs.zsh}/bin/zsh
+
+    git diff $(cut -d '-' -f 1 <(curl -sH 'Accept: text/plain' https://uni2work.ifi.lmu.de/version))
+  '';
 in pkgs.mkShell {
   name = "uni2work";
   
-  nativeBuildInputs = [develop inDevelop killallUni2work] ++ (with pkgs; [ nodejs-14_x postgresql_12 openldap google-chrome exiftool memcached minio minio-client gup ]) ++ (with pkgs.haskellPackages; [ stack yesod-bin hlint cabal-install weeder profiteur ]);
+  nativeBuildInputs = [develop inDevelop killallUni2work diffRunning] ++ (with pkgs; [ nodejs-14_x postgresql_12 openldap google-chrome exiftool memcached minio minio-client gup ]) ++ (with pkgs.haskellPackages; [ stack yesod-bin hlint cabal-install weeder profiteur ]);
 }

src/Application.hs

@@ -213,7 +213,7 @@ makeFoundation appSettings''@AppSettings{..} = do
     -- from there, and then create the real foundation.
     let
       mkFoundation :: _ -> (forall m. MonadIO m => Custom.Pool' m DBConnLabel DBConnUseState SqlBackend) -> _
-      mkFoundation appSettings' appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey = UniWorX {..}
+      mkFoundation appSettings' appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey = UniWorX {..}
       -- The UniWorX {..} syntax is an example of record wild cards. For more
       -- information, see:
       -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
@@ -233,6 +233,7 @@ makeFoundation appSettings''@AppSettings{..} = do
         (error "MinioConn forced in tempFoundation")
         (error "VerpSecret forced in tempFoundation")
         (error "AuthKey forced in tempFoundation")
+        (error "PersonalisedSheetFilesSeedKey forced in tempFoundation")
 
     runAppLoggingT tempFoundation $ do
       $logInfoS "InstanceID" $ UUID.toText appInstanceID
@@ -293,6 +294,7 @@ makeFoundation appSettings''@AppSettings{..} = do
       appClusterID <- clusterSetting (Proxy :: Proxy 'ClusterId) `customRunSqlPool` sqlPool
       appVerpSecret <- clusterSetting (Proxy :: Proxy 'ClusterVerpSecret) `customRunSqlPool` sqlPool
       appAuthKey <- clusterSetting (Proxy :: Proxy 'ClusterAuthKey) `customRunSqlPool` sqlPool
+      appPersonalisedSheetFilesSeedKey <- clusterSetting (Proxy :: Proxy 'ClusterPersonalisedSheetFilesSeedKey) `customRunSqlPool` sqlPool
 
       needsRechunk <- exists [FileContentChunkContentBased !=. True] `customRunSqlPool` sqlPool
       let appSettings' = appSettings''
@@ -326,7 +328,7 @@ makeFoundation appSettings''@AppSettings{..} = do
 
       $logDebugS "Runtime configuration" $ tshow appSettings'
 
-      let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey
+      let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey
 
       -- Return the foundation
       $logDebugS "setup" "Done"

src/Audit/Types.hs

@@ -169,9 +169,13 @@ data Transaction
     }
 
   | TransactionUserAssimilated
-    { transactionUser            :: UserId
+    { transactionUser
     , transactionAssimilatedUser :: UserId
     }
+  | TransactionUserIdentChanged
+    { transactionOldUserIdent
+    , transactionNewUserIdent    :: UserIdent
+    }
 
   | TransactionAllocationUserEdited
     { transactionUser       :: UserId

src/Foundation/Type.hs

@@ -10,7 +10,7 @@ module Foundation.Type
   , AppMemcachedLocal(..)
   , _memcachedLocalARC
   , SMTPPool
-  , _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport, _appMemcached, _appUploadCache, _appVerpSecret, _appAuthKey
+  , _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport, _appMemcached, _appUploadCache, _appVerpSecret, _appAuthKey, _appPersonalisedSheetFilesSeedKey
   , DB, Form, MsgRenderer, MailM, DBFile
   ) where
 
@@ -37,6 +37,7 @@ import Utils.Metrics (DBConnUseState)
 import qualified Data.ByteString.Lazy as Lazy
 import Data.Time.Clock.POSIX (POSIXTime)
 import GHC.Fingerprint (Fingerprint)
+import Handler.Sheet.PersonalisedFiles.Types (PersonalisedSheetFilesSeedKey)
 
 
 type SMTPPool = Pool SMTPConnection
@@ -93,6 +94,7 @@ data UniWorX = UniWorX
     , appFileSourceARC     :: Maybe (ARCHandle (FileContentChunkReference, (Int, Int)) Int ByteString)
     , appFileSourcePrewarm :: Maybe (LRUHandle (FileContentChunkReference, (Int, Int)) UTCTime Int ByteString)
     , appFileInjectInhibit :: TVar (IntervalMap UTCTime (Set FileContentReference))
+    , appPersonalisedSheetFilesSeedKey :: PersonalisedSheetFilesSeedKey
     } deriving (Typeable)
 
 makeLenses_ ''UniWorX

src/Handler/Sheet/PersonalisedFiles.hs

@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
 module Handler.Sheet.PersonalisedFiles
   ( sinkPersonalisedSheetFiles
   , getSPersonalFilesR, getCPersonalFilesR
@@ -74,6 +76,9 @@ data PersonalisedSheetFilesForm = PersonalisedSheetFilesForm
   } deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 
+embedRenderMessage ''UniWorX ''PersonalisedSheetFilesDownloadAnonymous id
+
+
 personalisedSheetFileTypes :: [SheetFileType]
 personalisedSheetFileTypes = filter (/= SheetMarking) universeF
 
@@ -103,8 +108,8 @@ resolvePersonalisedSheetFiles fpL isDir cid sid = do
                   let
                     getUid :: _ -> _ -> MemoStateT _ _ _ (SqlPersistT m) (Maybe UserId)
                     getUid mbIdx' cID' = runMaybeT $ do
-                      cIDKey <- catchMPlus (Proxy @PersonalisedSheetFilesKeyException) . lift . lift $ getPersonalisedFilesKey cid (Just sid) mbIdx'
+                      kSet <- catchMPlus (Proxy @PersonalisedSheetFilesKeyException) . lift . lift $ getPersonalisedFilesKey cid (Just sid) mbIdx'
-                      uid <- either (const mzero) return . (runReaderT ?? cIDKey) $ I.decrypt cID'
+                      uid <- either (const mzero) return . (runReaderT ?? psfksCryptoID kSet) $ I.decrypt cID'
                       guardM . lift . lift $ exists [CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid]
                       return uid
                         
@@ -213,7 +218,7 @@ sourcePersonalisedSheetFiles :: forall m.
                              -> Set PersonalisedSheetFilesRestriction
                              -> ConduitT () (Either PersonalisedSheetFile DBFile) (SqlPersistT m) ()
 sourcePersonalisedSheetFiles cId mbsid mbuids anonMode restrs = do
-  (mbIdx, cIDKey) <- lift . newPersonalisedFilesKey $ maybe (Left cId) Right mbsid
+  (mbIdx, kSet) <- lift . newPersonalisedFilesKey $ maybe (Left cId) Right mbsid
   let
     genSuffixes uid = case anonMode of
       PersonalisedSheetFilesDownloadGroups -> do
@@ -260,7 +265,7 @@ sourcePersonalisedSheetFiles cId mbsid mbuids anonMode restrs = do
             suf <- lift . lift $ genSuffixes courseParticipantUser
             _sufCache %= Map.insert courseParticipantUser suf
             return suf
-      cID <- throwLeft . (runReaderT ?? cIDKey) $ I.encrypt courseParticipantUser
+      cID <- throwLeft . (runReaderT ?? psfksCryptoID kSet) $ I.encrypt courseParticipantUser
       let dirName = unpack . Text.intercalate "_" . map pack $ suffix `snoc` mkPersonalisedFilesDirectory mbIdx cID
       unlessM (uses _dirCache $ Set.member dirName) $ do
         yield $ Right File
@@ -275,7 +280,8 @@ sourcePersonalisedSheetFiles cId mbsid mbuids anonMode restrs = do
             , fileModified = courseParticipantRegistration
             }
         yieldM . fmap Right $ do
-          fileContent' <- lift $ formatPersonalisedSheetFilesMeta anonMode cPart cID
+          mr' <- getMsgRenderer
+          fileContent' <- lift $ formatPersonalisedSheetFilesMeta mr' anonMode cPart cID (mkPersonalisedSheetFilesSeed <$> psfksSeed kSet)
           let fileTitle = (dirName <//>) . ensureExtension "yaml" . unpack . mr $ MsgPersonalisedSheetFilesMetaFilename cID
               fileModified = courseParticipantRegistration
               fileContent = Just $ C.sourceLazy fileContent'
@@ -307,21 +313,24 @@ newPersonalisedFilesKey :: forall m.
                            , HandlerSite m ~ UniWorX
                            , MonadThrow m, MonadRandom m
                            )
-                        => Either CourseId SheetId -> SqlPersistT m (Maybe Word24, CryptoIDKey)
+                        => Either CourseId SheetId -> SqlPersistT m (Maybe Word24, PersonalisedSheetFilesKeySet)
-newPersonalisedFilesKey (Right shId) = cryptoIDKey $ \cIDKey -> fmap (Nothing,) $
+newPersonalisedFilesKey (Right shId) = (Nothing, ) <$> do
-  either (const $ throwM PersonalisedSheetFilesKeyCouldNotDecodeRandom) (views _3 return) . Binary.decodeOrFail . fromStrict . BA.convert $
+  psfksCryptoID <- cryptoIDKey $ \cIDKey ->
-  Crypto.kmac @(SHAKE256 CryptoIDCipherKeySize) (encodeUtf8 . (pack :: String -> Text) $ nameBase 'newPersonalisedFilesKey) (toStrict $ Binary.encode shId) cIDKey
+    either (const $ throwM PersonalisedSheetFilesKeyCouldNotDecodeRandom) (views _3 return) . Binary.decodeOrFail . fromStrict . BA.convert $
+      Crypto.kmac @(SHAKE256 CryptoIDCipherKeySize) (encodeUtf8 . (pack :: String -> Text) $ nameBase 'newPersonalisedFilesKey) (toStrict $ Binary.encode shId) cIDKey
+  psfksSeed <- fmap Just . getsYesod . views _appPersonalisedSheetFilesSeedKey . flip derivePersonalisedSheetFilesSeedKey . toStrict $ Binary.encode (nameBase 'newPersonalisedFilesKey, shId)
+  return PersonalisedSheetFilesKeySet{..} 
 newPersonalisedFilesKey (Left cId) = do
   now <- liftIO getCurrentTime
   secret <- CryptoID.genKey
   let secret' = toStrict $ Binary.encode secret
   firstN <- getRandom
 
-  let loop :: Word24 -> SqlPersistT m (Maybe Word24, CryptoIDKey)
+  let loop :: Word24 -> SqlPersistT m (Maybe Word24, PersonalisedSheetFilesKeySet)
       loop n = do
         didInsert <- is _Just <$> insertUnique (FallbackPersonalisedSheetFilesKey cId n secret' now)
         if | didInsert
-             -> return (Just n, secret)
+             -> return (Just n, PersonalisedSheetFilesKeySet secret Nothing)
            |    (firstN == minBound && n == maxBound)
              || n == pred firstN
              -> throwM FallbackPersonalisedSheetFilesKeysExhausted
@@ -336,12 +345,13 @@ getPersonalisedFilesKey :: forall m.
                            , HandlerSite m ~ UniWorX
                            , MonadThrow m, MonadRandom m
                            )
-                        => CourseId -> Maybe SheetId -> Maybe Word24 -> SqlPersistT m CryptoIDKey
+                        => CourseId -> Maybe SheetId -> Maybe Word24 -> SqlPersistT m PersonalisedSheetFilesKeySet
 getPersonalisedFilesKey _    Nothing     Nothing   = throwM PersonalisedSheetFilesKeyInsufficientContext
 getPersonalisedFilesKey _   (Just shId)  Nothing   = view _2 <$> newPersonalisedFilesKey (Right shId)
 getPersonalisedFilesKey cId  _          (Just idx) = maybeT (throwM PersonalisedSheetFilesKeyNotFound) $ do
   Entity _ FallbackPersonalisedSheetFilesKey{..} <- MaybeT . getBy $ UniqueFallbackPersonalisedSheetFilesKey cId idx
-  either (const $ throwM PersonalisedSheetFilesKeyCouldNotDecodeRandom) (views _3 return) . Binary.decodeOrFail . fromStrict $ BA.convert fallbackPersonalisedSheetFilesKeySecret
+  psfksCryptoID <- either (const $ throwM PersonalisedSheetFilesKeyCouldNotDecodeRandom) (views _3 return) . Binary.decodeOrFail $ fromStrict fallbackPersonalisedSheetFilesKeySecret
+  return $ PersonalisedSheetFilesKeySet{ psfksSeed = Nothing, .. }
 
 mkPersonalisedFilesDirectory :: Maybe Word24 -> CryptoFileNameUser -> FilePath
 mkPersonalisedFilesDirectory  Nothing cID = unpack $ toPathPiece cID

src/Handler/Sheet/PersonalisedFiles/Meta.hs

@@ -27,16 +27,20 @@ data PrettifyState
   = PrettifyInitial
   | PrettifyFlowSequence PrettifyState
   | PrettifyBlockSequence PrettifyState
+  | PrettifySeed | PrettifySeedDone
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 
+  
 formatPersonalisedSheetFilesMeta
   :: MonadIO m
-  => PersonalisedSheetFilesDownloadAnonymous
+  => MsgRendererS UniWorX
+  -> PersonalisedSheetFilesDownloadAnonymous
   -> CourseParticipant
   -> CryptoFileNameUser
+  -> Maybe (UserIdent -> PersonalisedSheetFilesSeed)
   -> SqlPersistT m Lazy.ByteString
-formatPersonalisedSheetFilesMeta anonMode CourseParticipant{..} cID = do
+formatPersonalisedSheetFilesMeta (MsgRenderer mr) anonMode CourseParticipant{..} cID mkSeed = do
   User{..} <- getJust courseParticipantUser
   exams <- E.select . E.from $ \(exam `E.InnerJoin` examRegistration) -> E.distinctOnOrderBy [E.asc $ exam E.^. ExamName] $ do
     E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
@@ -50,6 +54,7 @@ formatPersonalisedSheetFilesMeta anonMode CourseParticipant{..} cID = do
           , YAML.Event.MappingStart Nothing YAML.untagged YAML.Event.Block
           ]
         , mapEvents (str' "user") (str $ toPathPiece cID)
+        , mapEvents (str' "seed") (maybe (YAML.Scalar () YAML.SNull) (str . toPathPiece . ($ userIdent)) mkSeed)
         , guardOnM (isn't _PersonalisedSheetFilesDownloadAnonymous anonMode) $ concat
           [ mapEvents (str' "display_name") (str userDisplayName)
           , mapEvents (str' "surname") (str userSurname)
@@ -113,6 +118,11 @@ formatPersonalisedSheetFilesMeta anonMode CourseParticipant{..} cID = do
                        in (before <> ann1 <> fromStrict (encodeUtf8 $ ann3 event'') <> fromStrict (encodeUtf8 $ ann2 ws) <> after, pos1')
 
           transduce :: PrettifyState -> YAML.Event.Event -> ((Text, Text -> Text, Text -> Text), PrettifyState)
+          transduce PrettifyInitial (YAML.Event.Scalar _ _ _ k)
+            | k == "seed", is _Just mkSeed = (("\n# " <> mr MsgSheetPersonalisedFilesMetaYAMLSeedComment <> "\n", id, id), PrettifySeed)
+            | k == "seed" = (("\n# " <> mr MsgSheetPersonalisedFilesMetaYAMLNoSeedComment <> "\n", id, id), PrettifySeed)
+          transduce PrettifySeed YAML.Event.Scalar{}
+            = ((mempty, id, beforeBreak "\n"), PrettifySeedDone)
           transduce cState (YAML.Event.SequenceStart _ _ YAML.Event.Flow) = ((mempty, id, bool " " mempty . null), PrettifyFlowSequence cState)
           transduce (PrettifyFlowSequence pState) YAML.Event.SequenceEnd = ((mempty, id, id), pState)
           transduce cState@(PrettifyFlowSequence _) _ = ((mempty, f, bool " " mempty . null), cState)
@@ -124,4 +134,11 @@ formatPersonalisedSheetFilesMeta anonMode CourseParticipant{..} cID = do
           transduce cState@(PrettifyBlockSequence _) _ = ((mempty, Text.replace "\n-" "\n  -", id), cState)
           transduce cState _ = ((mempty, id, id), cState)
           -- transduce cState _ = (("<", id, \ws -> "|" <> ws <> ">"), cState) -- TODO
+
+          beforeBreak :: Text -> Text -> Text
+          beforeBreak ins ws = before <> ins <> break' <> after
+            where (before', after) = Text.breakOnEnd "\n" ws
+                  before = Text.dropWhileEnd (== '\n') before'
+                  break' = Text.takeWhileEnd (== '\n') before'
+
   return prettyYAML

src/Handler/Sheet/PersonalisedFiles/Types.hs

@@ -1,9 +1,33 @@
 module Handler.Sheet.PersonalisedFiles.Types
   ( PersonalisedSheetFilesDownloadAnonymous(..)
   , _PersonalisedSheetFilesDownloadAnonymous, _PersonalisedSheetFilesDownloadSurnames, _PersonalisedSheetFilesDownloadMatriculations, _PersonalisedSheetFilesDownloadGroups
+  , PersonalisedSheetFilesSeed(..)
+  , mkPersonalisedSheetFilesSeed
+  , PersonalisedSheetFilesSeedKey
+  , derivePersonalisedSheetFilesSeedKey, newPersonalisedSheetFilesSeedKey
+  , PersonalisedSheetFilesKeySet(..)
   ) where
 
-import Import
+import Import.NoModel
+import Model.Types.Common (UserIdent)
+
+import Web.HttpApiData (ToHttpApiData, FromHttpApiData)
+import Data.ByteArray (ByteArrayAccess)
+import qualified Data.ByteArray as BA
+
+import Crypto.Hash.Algorithms (SHAKE256)
+import qualified Crypto.MAC.KMAC as Crypto
+import qualified Crypto.Random as Crypto
+import qualified Data.Binary as Binary
+
+import qualified Data.CaseInsensitive as CI
+
+import Data.CryptoID.ByteString (CryptoIDKey)
+
+import Data.Typeable (typeOf)
+  
+import Data.Binary.Put (putByteString)
+import Data.Binary.Get (getByteString)
 
 
 data PersonalisedSheetFilesDownloadAnonymous
@@ -14,6 +38,56 @@ data PersonalisedSheetFilesDownloadAnonymous
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
   deriving anyclass (Universe, Finite)
 nullaryPathPiece ''PersonalisedSheetFilesDownloadAnonymous $ camelToPathPiece' 4
-embedRenderMessage ''UniWorX ''PersonalisedSheetFilesDownloadAnonymous id
 
 makePrisms ''PersonalisedSheetFilesDownloadAnonymous
+
+
+newtype PersonalisedSheetFilesSeed = PersonalisedSheetFilesSeed (Digest (SHAKE256 144))
+  deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable)
+  deriving newtype ( PersistField
+                   , PathPiece, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON
+                   , Hashable, NFData
+                   , ByteArrayAccess
+                   , Binary
+                   )
+
+newtype PersonalisedSheetFilesSeedKey = PersonalisedSheetFilesSeedKey { psfskKeyMaterial :: ByteString }
+  deriving (Typeable)
+  deriving newtype (ByteArrayAccess)
+  
+-- | Does not actually show any key material
+instance Show PersonalisedSheetFilesSeedKey where
+  show = show . typeOf
+
+instance Binary PersonalisedSheetFilesSeedKey where
+  put = putByteString . psfskKeyMaterial
+  get = PersonalisedSheetFilesSeedKey <$> getByteString 16
+  
+instance Eq PersonalisedSheetFilesSeedKey where
+  (==) = BA.constEq
+
+derivePersistFieldBinary ''PersonalisedSheetFilesSeedKey
+deriveJSONBinary ''PersonalisedSheetFilesSeedKey
+
+
+derivePersonalisedSheetFilesSeedKey :: ByteArrayAccess ba => PersonalisedSheetFilesSeedKey -> ba -> PersonalisedSheetFilesSeedKey
+derivePersonalisedSheetFilesSeedKey k = PersonalisedSheetFilesSeedKey . BA.convert . Crypto.kmac @(SHAKE256 128) (enc 'derivePersonalisedSheetFilesSeedKey) k
+  where
+    enc :: forall a. Binary a => a -> ByteString
+    enc = toStrict . Binary.encode
+
+newPersonalisedSheetFilesSeedKey :: Crypto.MonadRandom m => m PersonalisedSheetFilesSeedKey
+newPersonalisedSheetFilesSeedKey = PersonalisedSheetFilesSeedKey <$> Crypto.getRandomBytes 16
+  
+mkPersonalisedSheetFilesSeed :: PersonalisedSheetFilesSeedKey
+                             -> UserIdent
+                             -> PersonalisedSheetFilesSeed
+mkPersonalisedSheetFilesSeed k u = PersonalisedSheetFilesSeed . Crypto.kmacGetDigest $ Crypto.kmac (enc 'mkPersonalisedSheetFilesSeed) k (enc $ CI.foldedCase u)
+  where
+    enc :: forall a. Binary a => a -> ByteString
+    enc = toStrict . Binary.encode
+
+data PersonalisedSheetFilesKeySet = PersonalisedSheetFilesKeySet
+  { psfksCryptoID :: CryptoIDKey
+  , psfksSeed :: Maybe PersonalisedSheetFilesSeedKey 
+  } deriving (Show, Typeable)

src/Handler/Utils/Users.hs

@@ -24,6 +24,7 @@ import qualified Data.Aeson as JSON
 import qualified Data.Aeson.Types as JSON
 
 import qualified Data.Set as Set
+import qualified Data.List as List
 import qualified Data.CaseInsensitive as CI
 
 import qualified Database.Esqueleto.Legacy as E
@@ -200,6 +201,7 @@ data UserAssimilateExceptionReason
   | UserAssimilateExamResultDifferentResult (Entity ExamResult) (Entity ExamResult)
   | UserAssimilatePersonalisedSheetFileDifferentContent (Entity PersonalisedSheetFile) (Entity PersonalisedSheetFile)
   | UserAssimilateTutorialParticipantCollidingRegGroups (Entity TutorialParticipant) (Entity TutorialParticipant)
+  | UserAssimilateCouldNotDetermineUserIdents
   deriving (Eq, Ord, Show, Generic, Typeable)
 
 assimilateUser :: UserId -- ^ @newUserId@
@@ -773,6 +775,17 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
             delete oldSFId
    in runConduit $ getStudyFeatures .| C.mapM_ upsertStudyFeatures
 
+  userIdents <- E.select . E.from $ \user -> do
+    E.where_ $ user E.^. UserId `E.in_` E.valList [newUserId, oldUserId]
+    return ( user E.^. UserId
+           , user E.^. UserIdent
+           )
+  case (,) <$> List.lookup (E.Value oldUserId) userIdents <*> List.lookup (E.Value newUserId) userIdents of
+    Just (E.Value oldIdent, E.Value newIdent')
+      | oldIdent /= newIdent' -> audit $ TransactionUserIdentChanged oldIdent newIdent'
+      | otherwise -> return ()
+    _other -> tellError UserAssimilateCouldNotDetermineUserIdents
+
   delete oldUserId
   audit $ TransactionUserAssimilated newUserId oldUserId
   where

src/Import/NoModel.hs

@@ -30,6 +30,7 @@ import UnliftIO.Async.Utils as Import
 
 import Model.Types.TH.JSON as Import
 import Model.Types.TH.Wordlist as Import
+import Model.Types.TH.Binary as Import
 
 import Mail                   as Import
 

src/Jobs/HealthReport.hs

@@ -71,6 +71,10 @@ dispatchHealthCheckMatchingClusterConfig
       ourSetting <- getsYesod appAuthKey
       dbSetting <- clusterSetting @'ClusterAuthKey
       return $ Just ourSetting == dbSetting
+    clusterSettingMatches ClusterPersonalisedSheetFilesSeedKey = do
+      ourSetting <- getsYesod appPersonalisedSheetFilesSeedKey
+      dbSetting <- clusterSetting @'ClusterPersonalisedSheetFilesSeedKey
+      return $ Just ourSetting == dbSetting
 
 
     clusterSetting :: forall key.

src/Model/Types/TH/Binary.hs

@@ -0,0 +1,103 @@
+module Model.Types.TH.Binary where
+
+import ClassyPrelude.Yesod hiding (Proxy(..))
+import Database.Persist.Sql
+
+import qualified Data.ByteString.Lazy as LBS
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Datatype
+import qualified Language.Haskell.TH.Syntax as TH
+
+import Utils.Persist
+import Data.Proxy
+
+import Data.Binary (Binary)
+import qualified Data.Binary as Binary
+
+import Data.List (foldl)
+
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Types as Aeson
+
+import qualified Data.ByteString.Base64.URL as Base64
+
+import Control.Monad.Fail
+
+
+toPersistValueBinary :: Binary a => a -> PersistValue
+toPersistValueBinary = PersistByteString . LBS.toStrict . Binary.encode
+
+fromPersistValueBinary :: forall a. (Binary a, PersistFieldSql a, Typeable a) => PersistValue -> Either Text a
+fromPersistValueBinary = \case
+  PersistByteString bs
+    | Right (rest, _, v) <- Binary.decodeOrFail $ fromStrict bs
+    , null rest
+      -> Right v
+  x -> Left $ fromPersistValueErrorSql (Proxy @a) x
+
+sqlTypeBinary :: SqlType
+sqlTypeBinary = SqlBlob
+
+
+derivePersistFieldBinary :: Name -> DecsQ
+derivePersistFieldBinary tName = do
+  DatatypeInfo{..} <- reifyDatatype tName
+  vars <- forM datatypeVars (const $ newName "a")
+  let t = foldl (\t' n' -> t' `appT` varT n') (conT tName) vars
+      iCxt
+        | null vars = cxt []
+        | otherwise = cxt [[t|Binary|] `appT` t, [t|Typeable|] `appT` t]
+      sqlCxt
+        | null vars = cxt []
+        | otherwise = cxt [[t|PersistField|] `appT` t]
+  sequence
+    [ instanceD iCxt ([t|PersistField|] `appT` t)
+      [ funD 'toPersistValue
+        [ clause [] (normalB [e|toPersistValueBinary|]) []
+        ]
+      , funD 'fromPersistValue
+        [ clause [] (normalB [e|fromPersistValueBinary|]) []
+        ]
+      ]
+    , instanceD sqlCxt ([t|PersistFieldSql|] `appT` t)
+      [ funD 'sqlType
+        [ clause [wildP] (normalB [e|sqlTypeBinary|]) []
+        ]
+      ]
+    ]
+
+
+toJSONBinary :: Binary a => a -> Aeson.Value
+toJSONBinary = Aeson.String . decodeUtf8 . Base64.encode . toStrict . Binary.encode
+
+parseJSONBinary :: Binary a => Name -> Aeson.Value -> Aeson.Parser a
+parseJSONBinary n = Aeson.withText (nameBase n) $ \t -> do
+  bytes <- either fail (return . fromStrict) . Base64.decode $ encodeUtf8 t
+  case Binary.decodeOrFail bytes of
+    Left (_, _, err) -> fail err
+    Right (bs, _, ret)
+      | null bs -> return ret
+      | otherwise -> fail $ show (length bs) ++ " extra bytes"
+
+  
+deriveJSONBinary :: Name -> DecsQ
+deriveJSONBinary tName = do
+  DatatypeInfo{..} <- reifyDatatype tName
+  vars <- forM datatypeVars (const $ newName "a")
+  let t = foldl (\t' n' -> t' `appT` varT n') (conT tName) vars
+      iCxt
+        | null vars = cxt []
+        | otherwise = cxt [[t|Binary|] `appT` t, [t|Typeable|] `appT` t]
+  sequence
+    [ instanceD iCxt ([t|ToJSON|] `appT` t)
+      [ funD 'toJSON
+        [ clause [] (normalB [e|toJSONBinary|]) []
+        ]
+      ]
+    , instanceD iCxt ([t|FromJSON|] `appT` t)
+      [ funD 'parseJSON
+        [ clause [] (normalB [e|parseJSONBinary $(TH.lift tName)|]) []
+        ]
+      ]
+    ]

src/Settings/Cluster.hs

@@ -40,6 +40,8 @@ import Model.Types.TH.PathPiece
 import Data.ByteArray (ByteArray, ByteArrayAccess)
 import qualified Crypto.Random as Crypto
 
+import Handler.Sheet.PersonalisedFiles.Types (PersonalisedSheetFilesSeedKey, newPersonalisedSheetFilesSeedKey)
+
 
 data ClusterSettingsKey
   = ClusterCryptoIDKey
@@ -50,6 +52,7 @@ data ClusterSettingsKey
   | ClusterMemcachedKey
   | ClusterVerpSecret
   | ClusterAuthKey
+  | ClusterPersonalisedSheetFilesSeedKey
   deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable)
   deriving anyclass (Universe, Finite, NFData)
 
@@ -160,3 +163,9 @@ instance ClusterSetting 'ClusterAuthKey where
   type ClusterSettingValue 'ClusterAuthKey = Auth.Key
   initClusterSetting _ = liftIO Auth.newKey
   knownClusterSetting _ = ClusterAuthKey
+
+
+instance ClusterSetting 'ClusterPersonalisedSheetFilesSeedKey where
+  type ClusterSettingValue 'ClusterPersonalisedSheetFilesSeedKey = PersonalisedSheetFilesSeedKey
+  initClusterSetting _ = liftIO newPersonalisedSheetFilesSeedKey
+  knownClusterSetting _ = ClusterPersonalisedSheetFilesSeedKey

templates/i18n/changelog/personalised-sheet-files-seeds.de-de-formal.hamlet

@@ -0,0 +1,3 @@
+$newline never
+
+Die Metainformationsdateien, die zum Anlegen von personalisierten Übungsblattdateien erzeugt werden, enthalten nun einen Seed für Pseudozufallsgeneratoren.

templates/i18n/changelog/personalised-sheet-files-seeds.en-eu.hamlet

@@ -0,0 +1,3 @@
+$newline never
+
+Metadata files created when adding personalised files to exercise sheets now contain a seed for pseudorandom generators.