feat(personalised-sheet-files): seeds

2021-07-13 10:46:23 +02:00 · 2021-07-13 10:46:23 +02:00 · cf67945292
commit cf67945292
parent ad7bf881bd
17 changed files with 282 additions and 27 deletions
--- a/messages/uniworx/categories/courses/sheet/de-de-formal.msg
+++ b/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
--- a/messages/uniworx/categories/courses/sheet/en-eu.msg
+++ b/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
--- a/models/sheets.model
+++ b/models/sheets.model
@ -59,9 +59,9 @@ PersonalisedSheetFile
    deriving Eq Ord Read Show Typeable Generic

 FallbackPersonalisedSheetFilesKey
-    course    CourseId OnDeleteCascade OnUpdateCascade
-    index     Word24
-    secret    ByteString
-    generated UTCTime
+    course     CourseId OnDeleteCascade OnUpdateCascade
+    index      Word24
+    secret     ByteString
+    generated  UTCTime
    UniqueFallbackPersonalisedSheetFilesKey course index
    deriving Generic
--- a/shell.nix
+++ b/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 ]);
 }
--- a/src/Application.hs
+++ b/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"
@ -709,4 +711,4 @@ addPWEntry :: User
 addPWEntry User{ userAuthentication = _, ..} (Text.encodeUtf8 -> pw) = db' $ do
  PWHashConf{..} <- getsYesod $ view _appAuthPWHash
  (AuthPWHash . Text.decodeUtf8 -> userAuthentication) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength
-  void $ insert User{..}
+  void $ insert User{..}
--- a/src/Audit/Types.hs
+++ b/src/Audit/Types.hs
@ -169,9 +169,13 @@ data Transaction
    }

  | TransactionUserAssimilated
-    { transactionUser            :: UserId
+    { transactionUser
    , transactionAssimilatedUser :: UserId
    }
+  | TransactionUserIdentChanged
+    { transactionOldUserIdent
+    , transactionNewUserIdent    :: UserIdent
+    }

  | TransactionAllocationUserEdited
    { transactionUser       :: UserId
--- a/src/Foundation/Type.hs
+++ b/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
--- a/src/Handler/Sheet/PersonalisedFiles.hs
+++ b/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'
-                      uid <- either (const mzero) return . (runReaderT ?? cIDKey) $ I.decrypt cID'
+                      kSet <- catchMPlus (Proxy @PersonalisedSheetFilesKeyException) . lift . lift $ getPersonalisedFilesKey cid (Just sid) mbIdx'
+                      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)
-newPersonalisedFilesKey (Right shId) = cryptoIDKey $ \cIDKey -> fmap (Nothing,) $
-  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
+                        => Either CourseId SheetId -> SqlPersistT m (Maybe Word24, PersonalisedSheetFilesKeySet)
+newPersonalisedFilesKey (Right shId) = (Nothing, ) <$> do
+  psfksCryptoID <- cryptoIDKey $ \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
--- a/src/Handler/Sheet/PersonalisedFiles/Meta.hs
+++ b/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
--- a/src/Handler/Sheet/PersonalisedFiles/Types.hs
+++ b/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)
--- a/src/Handler/Utils/Users.hs
+++ b/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
--- a/src/Import/NoModel.hs
+++ b/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

--- a/src/Jobs/HealthReport.hs
+++ b/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.
--- a/src/Model/Types/TH/Binary.hs
+++ b/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)|]) []
+        ]
+      ]
+    ]
--- a/src/Settings/Cluster.hs
+++ b/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
--- a/templates/i18n/changelog/personalised-sheet-files-seeds.de-de-formal.hamlet
+++ b/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.
--- a/templates/i18n/changelog/personalised-sheet-files-seeds.en-eu.hamlet
+++ b/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.