From cf679452928c14200e1eb3877987ee299fbf9f6f Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 13 Jul 2021 10:46:23 +0200 Subject: [PATCH] feat(personalised-sheet-files): seeds --- .../categories/courses/sheet/de-de-formal.msg | 2 + .../categories/courses/sheet/en-eu.msg | 2 + models/sheets.model | 8 +- shell.nix | 8 +- src/Application.hs | 8 +- src/Audit/Types.hs | 6 +- src/Foundation/Type.hs | 4 +- src/Handler/Sheet/PersonalisedFiles.hs | 36 +++--- src/Handler/Sheet/PersonalisedFiles/Meta.hs | 21 +++- src/Handler/Sheet/PersonalisedFiles/Types.hs | 78 ++++++++++++- src/Handler/Utils/Users.hs | 13 +++ src/Import/NoModel.hs | 1 + src/Jobs/HealthReport.hs | 4 + src/Model/Types/TH/Binary.hs | 103 ++++++++++++++++++ src/Settings/Cluster.hs | 9 ++ ...ised-sheet-files-seeds.de-de-formal.hamlet | 3 + ...ersonalised-sheet-files-seeds.en-eu.hamlet | 3 + 17 files changed, 282 insertions(+), 27 deletions(-) create mode 100644 src/Model/Types/TH/Binary.hs create mode 100644 templates/i18n/changelog/personalised-sheet-files-seeds.de-de-formal.hamlet create mode 100644 templates/i18n/changelog/personalised-sheet-files-seeds.en-eu.hamlet diff --git a/messages/uniworx/categories/courses/sheet/de-de-formal.msg b/messages/uniworx/categories/courses/sheet/de-de-formal.msg index c6d9e7959..4a19ad8df 100644 --- 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 diff --git a/messages/uniworx/categories/courses/sheet/en-eu.msg b/messages/uniworx/categories/courses/sheet/en-eu.msg index 32292cc68..461fc347d 100644 --- 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 diff --git a/models/sheets.model b/models/sheets.model index 57213ec7b..08073eed3 100644 --- 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 \ No newline at end of file diff --git a/shell.nix b/shell.nix index 8280c7d5f..10eb9dfcd 100644 --- 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 ]); } diff --git a/src/Application.hs b/src/Application.hs index 001d87096..9cd0fa810 100644 --- 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{..} \ No newline at end of file + void $ insert User{..} diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index b5c3d1cf7..c9d118fe9 100644 --- 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 diff --git a/src/Foundation/Type.hs b/src/Foundation/Type.hs index 3b7494d3c..52be76c44 100644 --- 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 diff --git a/src/Handler/Sheet/PersonalisedFiles.hs b/src/Handler/Sheet/PersonalisedFiles.hs index f1276f124..532181664 100644 --- 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 diff --git a/src/Handler/Sheet/PersonalisedFiles/Meta.hs b/src/Handler/Sheet/PersonalisedFiles/Meta.hs index e95993ae8..2b0713041 100644 --- 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 diff --git a/src/Handler/Sheet/PersonalisedFiles/Types.hs b/src/Handler/Sheet/PersonalisedFiles/Types.hs index c3f5a5ca8..b53d3c055 100644 --- 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) diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index fc411d16f..f851d4fc9 100644 --- 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 diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 2bd19bc28..491f640f5 100644 --- 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 diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs index bbee11bd1..54e0317ec 100644 --- 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. diff --git a/src/Model/Types/TH/Binary.hs b/src/Model/Types/TH/Binary.hs new file mode 100644 index 000000000..e896e89e4 --- /dev/null +++ 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)|]) [] + ] + ] + ] diff --git a/src/Settings/Cluster.hs b/src/Settings/Cluster.hs index faa409b08..6e3eb1e2a 100644 --- 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 diff --git a/templates/i18n/changelog/personalised-sheet-files-seeds.de-de-formal.hamlet b/templates/i18n/changelog/personalised-sheet-files-seeds.de-de-formal.hamlet new file mode 100644 index 000000000..d76ba6826 --- /dev/null +++ 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. diff --git a/templates/i18n/changelog/personalised-sheet-files-seeds.en-eu.hamlet b/templates/i18n/changelog/personalised-sheet-files-seeds.en-eu.hamlet new file mode 100644 index 000000000..eea3bacdf --- /dev/null +++ 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.