diff --git a/frontend/src/utils/form/navigate-away-prompt.js b/frontend/src/utils/form/navigate-away-prompt.js index e063809ee..fdb92fa79 100644 --- a/frontend/src/utils/form/navigate-away-prompt.js +++ b/frontend/src/utils/form/navigate-away-prompt.js @@ -48,6 +48,10 @@ export class NavigateAwayPrompt { return; } + if (this._element.attributes.target === '_blank') { + return; + } + // mark initialized this._element.classList.add(NAVIGATE_AWAY_PROMPT_INITIALIZED_CLASS); } diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 716a77bb2..86d879aa0 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -2686,6 +2686,12 @@ PersonalisedSheetFilesDownloadSurnames: Mit Nachnamen PersonalisedSheetFilesDownloadMatriculations: Mit Matrikelnummern PersonalisedSheetFilesDownloadGroups: Mit festen Abgabegruppen CoursePersonalisedSheetFilesArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-personalisierte_dateien +PersonalisedSheetFilesArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase shn}-personalisierte_dateien +PersonalisedSheetFilesMetaFilename uid@CryptoFileNameUser: meta-informationen_#{toPathPiece uid}.yaml +PersonalisedSheetFilesDownloadAnonymousField: Anonymisierung +PersonalisedSheetFilesDownloadAnonymousFieldTip: Soll das Archiv von personalisierten Dateien anonymisiert werden (es enthält dann keinerlei sofort persönlich identifizierende Informationen zu den Kursteilnehmern) oder sollen die Verzeichnisnamen mit einem Merkmal versehen werden und die Metainformations-Dateien zusätzlich persönliche Daten enthalten? +PersonalisedSheetFilesIgnored count@Int64: Es #{pluralDE count "wurde" "wurden"} #{count} hochgeladene #{pluralDE count "Datei" "Dateien"} ignoriert, da sie keinem Übungsblattdatei-Typ oder keinem Kursteilnehmer zugeordnet werden #{pluralDE count "konnte" "konnten"}. +PersonalisedSheetFilesIgnoredIntro: Es wurden die folgenden Dateien ignoriert: AdminCrontabNotGenerated: (Noch) keine Crontab generiert CronMatchAsap: ASAP -CronMatchNone: Nie +CronMatchNone: Nie \ No newline at end of file diff --git a/models/sheets.model b/models/sheets.model index f345db612..f54426040 100644 --- a/models/sheets.model +++ b/models/sheets.model @@ -53,6 +53,7 @@ PersonalisedSheetFile content FileContentReference Maybe modified UTCTime UniquePersonalisedSheetFile sheet user type title + deriving Eq Ord Read Show Generic Typeable FallbackPersonalisedSheetFilesKey course CourseId diff --git a/package.yaml b/package.yaml index ebf1a9543..5b9412b43 100644 --- a/package.yaml +++ b/package.yaml @@ -309,6 +309,7 @@ tests: - quickcheck-instances - generic-arbitrary - http-types + - yesod-persistent ghc-options: - -fno-warn-orphans - -threaded diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index ce5ead5ee..3178424a9 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -16,6 +16,7 @@ module Foundation.I18n , ErrorResponseTitle(..) , UniWorXMessages(..) , uniworxMessages + , unRenderMessage, unRenderMessage', unRenderMessageLenient ) where import Foundation.Type @@ -38,6 +39,11 @@ import GHC.Exts (IsList(..)) import Yesod.Form.I18n.German import Yesod.Form.I18n.English +import qualified Data.Foldable as F +import qualified Data.Char as Char +import Text.Unidecode (unidecode) +import Data.Text.Lens (packed) + appLanguages :: NonEmpty Lang appLanguages = "de-de-formal" :| ["en-eu"] @@ -214,6 +220,8 @@ newtype SheetTypeHeader = SheetTypeHeader SheetType embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>) newtype SheetArchiveFileTypeDirectory = SheetArchiveFileTypeDirectory SheetFileType + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving newtype (Enum, Bounded, Universe, Finite) embedRenderMessageVariant ''UniWorX ''SheetArchiveFileTypeDirectory $ ("SheetArchiveFileTypeDirectory" <>) . concat . drop 1 . splitCamel instance RenderMessage UniWorX SheetType where @@ -355,3 +363,19 @@ instance RenderMessage UniWorX (ValueRequired UniWorX) where label = mr label' mr :: forall msg. RenderMessage UniWorX msg => msg -> Text mr = renderMessage foundation ls + + +unRenderMessage' :: (Eq a, Finite a, RenderMessage master a) => (Text -> Text -> Bool) -> master -> Text -> [a] +unRenderMessage' cmp foundation inp = nub $ do + l <- appLanguages' + x <- universeF + guard $ renderMessage foundation (l : filter (/= l) appLanguages') x `cmp` inp + return x + where appLanguages' = F.toList appLanguages + +unRenderMessage :: (Eq a, Finite a, RenderMessage master a) => master -> Text -> [a] +unRenderMessage = unRenderMessage' (==) + +unRenderMessageLenient :: (Eq a, Finite a, RenderMessage master a) => master -> Text -> [a] +unRenderMessageLenient = unRenderMessage' cmp + where cmp = (==) `on` mk . under packed (filter Char.isAlphaNum . concatMap unidecode) diff --git a/src/Handler/Sheet/Edit.hs b/src/Handler/Sheet/Edit.hs index 4261a5849..ba4ba38f5 100644 --- a/src/Handler/Sheet/Edit.hs +++ b/src/Handler/Sheet/Edit.hs @@ -98,7 +98,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do insertSheetFile' sid SheetMarking $ fromMaybe (return ()) sfMarkingF runConduit $ maybe (return ()) (transPipe liftHandler) (spffFiles =<< sfPersonalF) - .| sinkPersonalisedSheetFiles cid (Just sid) (fromMaybe False $ spffFilesKeepExisting <$> sfPersonalF) + .| sinkPersonalisedSheetFiles cid sid (fromMaybe False $ spffFilesKeepExisting <$> sfPersonalF) insert_ $ SheetEdit aid actTime sid addMessageI Success $ MsgSheetEditOk tid ssh csh sfName -- Sanity checks generating warnings only, but not errors! diff --git a/src/Handler/Sheet/Form.hs b/src/Handler/Sheet/Form.hs index f8dffc12b..e116b784f 100644 --- a/src/Handler/Sheet/Form.hs +++ b/src/Handler/Sheet/Form.hs @@ -102,9 +102,11 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS makeSheetPersonalisedFilesForm :: Maybe SheetPersonalisedFilesForm -> MForm Handler (AForm Handler SheetPersonalisedFilesForm) makeSheetPersonalisedFilesForm template' = do templateDownloadMessage <- runMaybeT . hoist (liftHandler . runDB) $ do - Sheet{..} <- MaybeT . fmap join $ traverse get msId + mbSheet <- maybe (return Nothing) (fmap Just . hoistMaybe) =<< traverse (lift . get) msId Course{..} <- MaybeT $ get cId - let downloadRoute = CSheetR courseTerm courseSchool courseShorthand sheetName SPersonalFilesR + let downloadRoute = case mbSheet of + Just Sheet{..} -> CSheetR courseTerm courseSchool courseShorthand sheetName SPersonalFilesR + Nothing -> CourseR courseTerm courseSchool courseShorthand CPersonalFilesR guardM $ hasReadAccessTo downloadRoute messageIconWidget Info IconFileZip [whamlet| diff --git a/src/Handler/Sheet/PersonalisedFiles.hs b/src/Handler/Sheet/PersonalisedFiles.hs index c335436dc..4ff2c00e4 100644 --- a/src/Handler/Sheet/PersonalisedFiles.hs +++ b/src/Handler/Sheet/PersonalisedFiles.hs @@ -1,16 +1,23 @@ -{-# OPTIONS_GHC -Wno-error=redundant-constraints -Wno-error=unused-top-binds -Wno-error=deprecations #-} +{-# OPTIONS_GHC -Wno-error=redundant-constraints -Wno-error=unused-top-binds #-} module Handler.Sheet.PersonalisedFiles ( sinkPersonalisedSheetFiles , getSPersonalFilesR, getCPersonalFilesR , PersonalisedSheetFilesKeyException(..) + , sourcePersonalisedSheetFiles, resolvePersonalisedSheetFiles + , PersonalisedSheetFileUnresolved(..) + , _PSFUnresolved, _PSFUnresolvedCollatable, _PSFUnresolvedDirectory ) where -import Import +import Import hiding (StateT(..)) import Handler.Utils +import Handler.Sheet.PersonalisedFiles.Meta +import Handler.Sheet.PersonalisedFiles.Types import qualified Data.Conduit.Combinators as C +import qualified Data.Conduit.List as C (mapMaybeM) +import Data.Conduit.ResumableSink import qualified Crypto.MAC.KMAC as Crypto import qualified Data.ByteArray as BA @@ -31,50 +38,149 @@ import qualified Database.Esqueleto as E import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as Text +import Data.List (inits, tails) import Text.Unidecode (unidecode) import Data.Char (isAlphaNum) -import GHC.Stack +import qualified System.FilePath as FilePath (joinPath) + +import Control.Monad.Trans.State.Strict (StateT, runStateT) +import qualified Control.Monad.State as State +import Control.Monad.Memo (MemoStateT, MonadMemo(..), for2) +import Utils.Memo + + +data PersonalisedSheetFileUnresolved a + = PSFUnresolvedDirectory a + | PSFUnresolvedCollatable Text a + | PSFUnresolved a + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +makePrisms ''PersonalisedSheetFileUnresolved + + +personalisedSheetFileTypes :: [SheetFileType] +personalisedSheetFileTypes = filter (/= SheetMarking) universeF resolvePersonalisedSheetFiles - :: forall a m. + :: forall m a. ( MonadHandler m , HandlerSite m ~ UniWorX + , MonadCatch m, MonadRandom m ) => Lens' a FilePath + -> (a -> Bool) -- ^ @isDirectory@ -> CourseId - -> Maybe SheetId - -> ConduitT a (Either a (a, FileReferenceResidual PersonalisedSheetFile)) m () -resolvePersonalisedSheetFiles fpL _cid _mbsid = do - C.mapM $ \fRef -> maybeT (return $ Left fRef) . fmap (Right . swap) . flip runStateT fRef . zoom fpL $ do - error "not implemented" :: StateT FilePath (MaybeT m) (FileReferenceResidual PersonalisedSheetFile) + -> SheetId + -> ConduitT a (Either (PersonalisedSheetFileUnresolved a) (a, FileReferenceResidual PersonalisedSheetFile)) (SqlPersistT m) () +resolvePersonalisedSheetFiles fpL isDir cid sid = do + app <- getYesod + C.mapM $ \fRef -> exceptT (return . Left . ($ fRef)) (return . Right . swap) . flip runStateT fRef $ do + let + genRefOptions :: ConduitT () (UserId, SheetFileType, FilePath) (StateT FilePath (ExceptT _ (SqlPersistT m))) () + genRefOptions = evalMemoStateC Map.empty $ + transPipe lift (yieldMany <=< State.gets $ resolvePersonalisedFilesDirectory app) + .| C.mapMaybeM (runMaybeT . filterRefOption) + where + filterRefOption :: _ -> MaybeT (MemoStateT _ _ _ (StateT FilePath (ExceptT _ (SqlPersistT m)))) (UserId, SheetFileType, FilePath) + filterRefOption (mbIdx, cID, sfType, fPath) = hoist (hoistStateCache $ lift . lift) $ 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' + guardM . lift . lift $ exists [CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid] + return uid + + fmap (, sfType, fPath) . hoistMaybeM . lift $ for2 memo getUid mbIdx cID + + mbRef <- zoom fpL . runConduit $ genRefOptions .| C.head + case mbRef of + Just (uid, sfType, fPath) -> PersonalisedSheetFileResidual sid uid sfType <$ (fpL .= fPath) + Nothing -> do + isDirectory <- State.gets isDir + if | isDirectory + -> lift $ throwE PSFUnresolvedDirectory + | otherwise + -> lift $ throwE PSFUnresolved sinkPersonalisedSheetFiles :: forall m. ( MonadHandler m , HandlerSite m ~ UniWorX + , MonadCatch m, MonadRandom m ) => CourseId - -> Maybe SheetId + -> SheetId -> Bool -- ^ Keep existing? -> ConduitT FileReference Void (SqlPersistT m) () -sinkPersonalisedSheetFiles cid mbsid _keep - = resolvePersonalisedSheetFiles _fileReferenceTitle cid mbsid - .| error "not implemented" +sinkPersonalisedSheetFiles cid sid keep + = resolvePersonalisedSheetFiles _fileReferenceTitle (hasn't $ _fileReferenceContent . _Just) cid sid + .| evalRWSC () Map.empty fanoutReferences >>= msgUnreferenced + where + fanoutReferences = do + C.mapM_ $ \case + Left unresolved -> tell $ Set.singleton unresolved + Right (fRef, residual) -> do + let PersonalisedSheetFileResidual{..} = residual + redResidual = (personalisedSheetFileResidualSheet, personalisedSheetFileResidualUser) + mSinks <- State.gets $ Map.lookup redResidual + let mkSinks + | Just sinks' <- mSinks + = Left sinks' + | keep + = Right $ \residual' -> newResumableSink $ sinkFileReferences residual' + | otherwise + = Right $ \residual' -> newResumableSink . void $ replaceFileReferences' mkFilter residual' + sinks = case mkSinks of + Left sinks' -> sinks' + Right mkSinks' -> Map.fromList + [ (residual', mkSinks' residual') + | sfType <- personalisedSheetFileTypes + , let residual' = PersonalisedSheetFileResidual{ personalisedSheetFileResidualType = sfType, .. } + ] + sink = Map.findWithDefault (error "No sink for SheetFileType") residual sinks + sink' <- lift $ yield fRef ++$$ sink + case sink' of + Left _ -> error "sinkFileReferences/replaceFileReferences returned prematurely" + Right nSink -> State.modify . Map.insert redResidual $ Map.insert residual nSink sinks + openSinks <- State.get + lift . lift . mapM_ closeResumableSink $ openSinks ^.. folded . folded + let (nub -> sinkSheets, nub -> sinkUsers) = unzip $ Map.keys openSinks + lift . lift $ deleteWhere [ PersonalisedSheetFileSheet <-. sinkSheets + , PersonalisedSheetFileUser /<-. sinkUsers + ] + + msgUnreferenced ((), unreferenced) = unless (null collated && null uncollated) $ + addMessageModal msgStatus msgTrigger $ Right msgWidget + where collated = Map.fromListWith (<>) + [ (ptn, Sum 1) + | PSFUnresolvedCollatable ptn _fRef <- Set.toList unreferenced + ] + collatedL = Map.toList collated + uncollated = [ fileReferenceTitle | PSFUnresolved FileReference{..} <- Set.toList unreferenced ] + + Sum c = Sum (fromIntegral $ length uncollated) <> fold collated + + msgStatus | null uncollated = Info + | otherwise = Warning + + msgTrigger = i18n $ MsgPersonalisedSheetFilesIgnored c + msgWidget = $(widgetFile "messages/personalisedSheetFilesIgnored") + + mkFilter :: FileReferenceResidual PersonalisedSheetFile -> [Filter PersonalisedSheetFile] + mkFilter PersonalisedSheetFileResidual{..} = [ PersonalisedSheetFileSheet ==. personalisedSheetFileResidualSheet + , PersonalisedSheetFileUser ==. personalisedSheetFileResidualUser + , PersonalisedSheetFileType ==. personalisedSheetFileResidualType + ] + + sinkFileReferences :: FileReferenceResidual PersonalisedSheetFile -> ConduitT FileReference Void (SqlPersistT m) () + sinkFileReferences residual' = C.mapM_ $ \fRef -> void . put $ _FileReference # (fRef, residual') + -data PersonalisedSheetFilesDownloadAnonymous - = PersonalisedSheetFilesDownloadAnonymous - | PersonalisedSheetFilesDownloadSurnames - | PersonalisedSheetFilesDownloadMatriculations - | PersonalisedSheetFilesDownloadGroups - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - deriving anyclass (Universe, Finite) -nullaryPathPiece ''PersonalisedSheetFilesDownloadAnonymous $ camelToPathPiece' 4 -embedRenderMessage ''UniWorX ''PersonalisedSheetFilesDownloadAnonymous id - sourcePersonalisedSheetFiles :: forall m. ( MonadHandler m , HandlerSite m ~ UniWorX @@ -114,9 +220,10 @@ sourcePersonalisedSheetFiles cId mbsid anonMode = do E.on $ E.just (courseParticipant E.^. CourseParticipantUser) E.==. personalisedSheetFile E.?. PersonalisedSheetFileUser E.&&. E.val mbsid E.==. personalisedSheetFile E.?. PersonalisedSheetFileSheet E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. E.val cId + E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive return (courseParticipant, personalisedSheetFile) - toRefs = awaitForever $ \(Entity _ CourseParticipant{..}, mbPFile) -> do + toRefs = awaitForever $ \(Entity _ cPart@CourseParticipant{..}, mbPFile) -> do MsgRenderer mr <- getMsgRenderer suffix <- do sufCache <- uses _sufCache $ Map.lookup courseParticipantUser @@ -135,16 +242,20 @@ sourcePersonalisedSheetFiles cId mbsid anonMode = do , fileModified = courseParticipantRegistration } forM_ [SheetExercise, SheetHint, SheetSolution] $ \sfType -> - yield $ Right File - { fileTitle = dirName unpack (mr $ SheetArchiveFileTypeDirectory sfType) + yield $ Right File + { fileTitle = dirName unpack (mr $ SheetArchiveFileTypeDirectory sfType) , fileContent = Nothing , fileModified = courseParticipantRegistration } - -- TODO: meta.yml + yieldM . fmap Right $ do + fileContent <- lift $ Just . toStrict <$> formatPersonalisedSheetFilesMeta anonMode cPart cID + let fileTitle = (dirName ) . ensureExtension "yaml" . unpack . mr $ MsgPersonalisedSheetFilesMetaFilename cID + fileModified = courseParticipantRegistration + return File{..} _dirCache %= Set.insert dirName whenIsJust mbPFile $ \(Entity _ pFile@PersonalisedSheetFile{..}) -> do - let dirName' = dirName unpack (mr $ SheetArchiveFileTypeDirectory personalisedSheetFileType) - yield . Left $ over (_FileReference . _1 . _fileReferenceTitle) (dirName' ) pFile + let dirName' = dirName unpack (mr $ SheetArchiveFileTypeDirectory personalisedSheetFileType) + yield . Left $ over (_FileReference . _1 . _fileReferenceTitle) (dirName' ) pFile where _sufCache :: Lens' _ _ _sufCache = _1 @@ -167,7 +278,6 @@ newPersonalisedFilesKey :: forall m. ( MonadHandler m , HandlerSite m ~ UniWorX , MonadThrow m, MonadRandom m - , HasCallStack ) => Either CourseId SheetId -> SqlPersistT m (Maybe Word24, CryptoIDKey) newPersonalisedFilesKey (Right shId) = cryptoIDKey $ \cIDKey -> fmap (Nothing,) $ @@ -178,11 +288,9 @@ newPersonalisedFilesKey (Left cId) = do secret <- CryptoID.genKey let secret' = toStrict $ Binary.encode secret firstN <- getRandom - traceM $ "newPersonalisedFilesKey: " <> prettyCallStack callStack let loop :: Word24 -> SqlPersistT m (Maybe Word24, CryptoIDKey) loop n = do - traceM "insertUnique" didInsert <- is _Just <$> insertUnique (FallbackPersonalisedSheetFilesKey cId n secret' now) if | didInsert -> return (Just n, secret) @@ -195,7 +303,12 @@ newPersonalisedFilesKey (Left cId) = do -> loop $ succ n in loop firstN -getPersonalisedFilesKey :: CourseId -> Maybe SheetId -> Maybe Word24 -> DB CryptoIDKey +getPersonalisedFilesKey :: forall m. + ( MonadHandler m + , HandlerSite m ~ UniWorX + , MonadThrow m, MonadRandom m + ) + => CourseId -> Maybe SheetId -> Maybe Word24 -> SqlPersistT m CryptoIDKey getPersonalisedFilesKey _ Nothing Nothing = throwM PersonalisedSheetFilesKeyInsufficientContext getPersonalisedFilesKey _ (Just shId) Nothing = view _2 <$> newPersonalisedFilesKey (Right shId) getPersonalisedFilesKey cId _ (Just idx) = maybeT (throwM PersonalisedSheetFilesKeyNotFound) $ do @@ -206,15 +319,73 @@ mkPersonalisedFilesDirectory :: Maybe Word24 -> CryptoFileNameUser -> FilePath mkPersonalisedFilesDirectory Nothing cID = unpack $ toPathPiece cID mkPersonalisedFilesDirectory (Just idx) cID = unpack $ toPathPiece cID <> "-" <> CI.foldCase (toStrict . encodeBase32Unpadded $ Binary.encode idx) -resolvePersonalisedFilesDirectory :: FilePath -> [(Maybe Word24, CryptoFileNameUser)] -resolvePersonalisedFilesDirectory = error "not implemented" +resolvePersonalisedFilesDirectory :: forall master. + RenderMessage master SheetArchiveFileTypeDirectory + => master + -> FilePath + -> [(Maybe Word24, CryptoFileNameUser, SheetFileType, FilePath)] +resolvePersonalisedFilesDirectory foundation (splitPath -> fPath) = do + (fPath', remFPath) <- inits fPath `zip` tails fPath + guard . not $ null remFPath + (SheetArchiveFileTypeDirectory sfType, fPath'') <- foldMap (\(seg, rest) -> (, rest) <$> unRenderMessageLenient foundation (pack seg)) $ foci fPath' + guard $ sfType `elem` personalisedSheetFileTypes + let cryptSegments = foldMap (filter (not . Text.null) . Text.split (flip Set.notMember cryptChars . CI.mk) . Text.pack) fPath'' + (mIdx, cryptSegments') <- foldMap (\(inp, rest) -> (, rest) . Just <$> hoistMaybe (decodeIdx inp)) (foci cryptSegments) <|> pure (Nothing, cryptSegments) + cID <- foldMap (hoistMaybe . fromPathPiece) cryptSegments' + return (mIdx, cID, sfType, FilePath.joinPath remFPath) + where + foci :: forall a. [a] -> [(a, [a])] + foci [] = [] + foci (x:xs) = (x, xs) : map (over _2 (x:)) (foci xs) + + cryptoIdChars, base32Chars, cryptChars :: Set (CI Char) + cryptChars = base32Chars <> cryptoIdChars + cryptoIdChars = mappend base32Chars . Set.fromList $ map CI.mk "uwb" + base32Chars = Set.fromList $ map CI.mk "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567" + + decodeIdx :: Text -> Maybe Word24 + decodeIdx inp + | Right inp' <- decodeBase32Unpadded . fromStrict $ encodeUtf8 inp + , Right (remInp, _, idx) <- Binary.decodeOrFail inp' + , null remInp + = Just idx + | otherwise = Nothing + +getPersonalFilesR :: CourseId -> Maybe SheetId -> Handler TypedContent +getPersonalFilesR cId mbsid = do + (Course{..}, mbSheet) <- runDB $ (,) + <$> get404 cId + <*> traverse get404 mbsid + + cRoute <- getCurrentRoute + ((anonRes, anonFormWdgt), anonEnctype) <- runFormGet . renderAForm FormStandard $ + apopt (selectField optionsFinite) (fslI MsgPersonalisedSheetFilesDownloadAnonymousField & setTooltip MsgPersonalisedSheetFilesDownloadAnonymousFieldTip) (Just PersonalisedSheetFilesDownloadAnonymous) + + formResult anonRes $ \anonMode -> do + archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ case mbSheet of + Nothing -> MsgCoursePersonalisedSheetFilesArchiveName courseTerm courseSchool courseShorthand + Just Sheet{..} -> MsgPersonalisedSheetFilesArchiveName courseTerm courseSchool courseShorthand sheetName + sendResponse <=< serveZipArchive' archiveName $ sourcePersonalisedSheetFiles cId mbsid anonMode + + isModal <- hasCustomHeader HeaderIsModal + + fmap toTypedContent . siteLayoutMsg MsgMenuSheetPersonalisedFiles $ do + setTitleI MsgMenuSheetPersonalisedFiles + wrapForm anonFormWdgt def + { formMethod = GET + , formAction = SomeRoute <$> cRoute + , formEncoding = anonEnctype + , formAttrs = formAttrs def <> bool mempty [("uw-no-navigate-away-prompt", ""), ("target", "_blank")] isModal + } + getSPersonalFilesR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent -getSPersonalFilesR = error "not implemented" +getSPersonalFilesR tid ssh csh shn = do + Entity shId Sheet{..} <- runDB $ fetchSheet tid ssh csh shn + getPersonalFilesR sheetCourse $ Just shId getCPersonalFilesR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent getCPersonalFilesR tid ssh csh = do cId <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh - archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCoursePersonalisedSheetFilesArchiveName tid ssh csh - serveZipArchive' archiveName $ sourcePersonalisedSheetFiles cId Nothing PersonalisedSheetFilesDownloadAnonymous -- TODO: get Form for anonymisiation + getPersonalFilesR cId Nothing diff --git a/src/Handler/Sheet/PersonalisedFiles/Meta.hs b/src/Handler/Sheet/PersonalisedFiles/Meta.hs new file mode 100644 index 000000000..973f18d80 --- /dev/null +++ b/src/Handler/Sheet/PersonalisedFiles/Meta.hs @@ -0,0 +1,131 @@ +{-# OPTIONS_GHC -Wno-error=redundant-constraints #-} + +module Handler.Sheet.PersonalisedFiles.Meta + ( formatPersonalisedSheetFilesMeta + ) where + +import Import + +import Handler.Sheet.PersonalisedFiles.Types + +import qualified Data.Char as Char +import qualified Data.Text as Text +import qualified Data.ByteString.Lazy as Lazy (ByteString) +import qualified Data.ByteString.Lazy as Lazy.ByteString + +import qualified Data.YAML as YAML +import qualified Data.YAML.Event as YAML (untagged) +import qualified Data.YAML.Event as YAML.Event +import qualified Data.YAML.Token as YAML (Encoding(..)) + +import Control.Monad.Trans.State.Lazy (evalState) + +import qualified Database.Esqueleto as E + +import qualified Data.CaseInsensitive as CI + + +data PrettifyState + = PrettifyInitial + | PrettifyFlowSequence PrettifyState + | PrettifyBlockSequence PrettifyState + deriving (Eq, Ord, Read, Show, Generic, Typeable) + + +formatPersonalisedSheetFilesMeta + :: ( MonadHandler m + , HandlerSite m ~ UniWorX + ) + => PersonalisedSheetFilesDownloadAnonymous + -> CourseParticipant + -> CryptoFileNameUser + -> SqlPersistT m Lazy.ByteString +formatPersonalisedSheetFilesMeta anonMode CourseParticipant{..} cID = 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 + E.where_ $ exam E.^. ExamCourse E.==. E.val courseParticipantCourse + E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val courseParticipantUser + return $ exam E.^. ExamName + + let uglyYAML = YAML.Event.writeEvents YAML.UTF8 $ concat + [ [ YAML.Event.StreamStart + , YAML.Event.DocumentStart $ YAML.Event.DirEndMarkerVersion 2 + , YAML.Event.MappingStart Nothing YAML.untagged YAML.Event.Block + ] + , mapEvents (str' "user") (str $ toPathPiece cID) + , guardOnM (isn't _PersonalisedSheetFilesDownloadAnonymous anonMode) $ concat + [ mapEvents (str' "display_name") (str userDisplayName) + , mapEvents (str' "surname") (str userSurname) + , mapEvents (str' "first_names") (str userFirstName) + , case userMatrikelnummer of + Just matr -> mapEvents (str' "matriculation") (str matr) + Nothing -> mzero + , mapEvents (str' "email") (str $ CI.original userEmail) + ] + , map flowStyle $ mapEvents (str' "languages") . YAML.Sequence () YAML.untagged $ maybe [] (views _Wrapped $ map str) userLanguages + , mapEvents (str' "registered_exams") . YAML.Sequence () YAML.untagged $ map (str . CI.original . E.unValue) exams + , [ YAML.Event.MappingEnd + , YAML.Event.DocumentEnd False + , YAML.Event.StreamEnd + ] + ] + where + str :: forall t. Textual t => t -> YAML.Node () + str = YAML.Scalar () . YAML.SStr . repack + str' :: Text -> YAML.Node () + str' = str + + mapEvents :: YAML.Node () -> YAML.Node () -> [YAML.Event.Event] + mapEvents k v = filterEvs . nodeEvents . YAML.Mapping () YAML.untagged $ singletonMap k v + where filterEvs ((YAML.Event.MappingStart{} : inner) :> YAML.Event.MappingEnd) = inner + filterEvs _other = error "Could not strip Mapping" + + nodeEvents :: YAML.Node () -> [YAML.Event.Event] + nodeEvents = filterEvs . mapMaybe (fmap YAML.Event.eEvent . preview _Right) . YAML.Event.parseEvents . YAML.encodeNode . pure . YAML.Doc + where filterEvs = filter $ \case + YAML.Event.StreamStart -> False + YAML.Event.StreamEnd -> False + YAML.Event.DocumentStart _ -> False + YAML.Event.DocumentEnd _ -> False + _other -> True + + flowStyle :: YAML.Event.Event -> YAML.Event.Event + flowStyle = \case + YAML.Event.SequenceStart a t _ -> YAML.Event.SequenceStart a t YAML.Event.Flow + YAML.Event.MappingStart a t _ -> YAML.Event.MappingStart a t YAML.Event.Flow + other -> other + + prettyYAML = annotate . (evalState ?? PrettifyInitial) . transduce' $ YAML.Event.parseEvents uglyYAML + where + transduce' (Left _ : _) = error "Parse error on uglyYAML" + transduce' (Right YAML.Event.EvPos{ eEvent, ePos = pos1 } : es@(Right YAML.Event.EvPos{ ePos = pos2 }: _)) + = (:) <$> ((YAML.Event.posByteOffset pos1, YAML.Event.posByteOffset pos2, ) <$> state (`transduce` eEvent)) <*> transduce' es + transduce' (Right YAML.Event.EvPos{..} : es) + = (:) <$> ((YAML.Event.posByteOffset ePos, fromIntegral $ Lazy.ByteString.length uglyYAML, ) <$> state (`transduce` eEvent)) <*> transduce' es + transduce' [] = return [] + + annotate = fst . foldl' annotate' (uglyYAML, Lazy.ByteString.length uglyYAML) . reverse + where annotate' (dat, mLength) (fromIntegral -> pos1, fromIntegral -> pos2, (fromStrict . encodeUtf8 -> ann1, ann3, ann2)) + = let (before', after) = Lazy.ByteString.splitAt pos2' dat + (before, event) = Lazy.ByteString.splitAt pos1' before' + event' = decodeUtf8 $ toStrict event + ws = Text.takeWhileEnd Char.isSpace event' + event'' = Text.dropWhileEnd Char.isSpace event' + pos1' = min pos1 mLength + pos2' = min pos2 mLength + 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 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) + where f str | ']' `elem` str = filter (/= '\n') str + | otherwise = str + -- transduce PrettifyInitial _ = ((mempty, id), PrettifyInitial) + transduce cState (YAML.Event.SequenceStart _ _ YAML.Event.Block) = ((" ", id, id), PrettifyBlockSequence cState) + transduce (PrettifyBlockSequence pState) YAML.Event.SequenceEnd = ((mempty, id, id), pState) + transduce cState@(PrettifyBlockSequence _) _ = ((mempty, Text.replace "\n-" "\n -", id), cState) + transduce cState _ = ((mempty, id, id), cState) + -- transduce cState _ = (("<", id, \ws -> "|" <> ws <> ">"), cState) -- TODO + return prettyYAML diff --git a/src/Handler/Sheet/PersonalisedFiles/Types.hs b/src/Handler/Sheet/PersonalisedFiles/Types.hs new file mode 100644 index 000000000..c3f5a5ca8 --- /dev/null +++ b/src/Handler/Sheet/PersonalisedFiles/Types.hs @@ -0,0 +1,19 @@ +module Handler.Sheet.PersonalisedFiles.Types + ( PersonalisedSheetFilesDownloadAnonymous(..) + , _PersonalisedSheetFilesDownloadAnonymous, _PersonalisedSheetFilesDownloadSurnames, _PersonalisedSheetFilesDownloadMatriculations, _PersonalisedSheetFilesDownloadGroups + ) where + +import Import + + +data PersonalisedSheetFilesDownloadAnonymous + = PersonalisedSheetFilesDownloadAnonymous + | PersonalisedSheetFilesDownloadSurnames + | PersonalisedSheetFilesDownloadMatriculations + | PersonalisedSheetFilesDownloadGroups + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) +nullaryPathPiece ''PersonalisedSheetFilesDownloadAnonymous $ camelToPathPiece' 4 +embedRenderMessage ''UniWorX ''PersonalisedSheetFilesDownloadAnonymous id + +makePrisms ''PersonalisedSheetFilesDownloadAnonymous diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index 8ba23b315..412752087 100644 --- a/src/Handler/Utils/Rating.hs +++ b/src/Handler/Utils/Rating.hs @@ -101,7 +101,6 @@ ratingFile cID rating@Rating{ ratingValues = Rating'{..}, .. } = do fileTitle = ensureExtension extensionRating . unpack . mr $ MsgRatingFileTitle cID fileContent = Just . Lazy.ByteString.toStrict $ formatRating mr' dtFmt cID rating return File{..} - where ensureExtension ext fName = bool (`addExtension` ext) id (ext `isExtensionOf` fName) fName type SubmissionContent = Either FileReference (SubmissionId, Rating') @@ -162,4 +161,3 @@ isRatingFile (takeFileName -> fName) = liftHandler . runMaybeT $ do let canonExtension = Set.singleton $ CI.mk (pack extensionRating) validExtensions = foldMap (Set.map CI.mk . mimeExtensions) ["application/json", "text/vnd.yaml"] guard $ extension `Set.member` Set.union canonExtension validExtensions - where ensureExtension ext fName' = bool (`addExtension` ext) id (ext `isExtensionOf` fName') fName' diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 9a22aab88..5ee121828 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -1094,7 +1094,6 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db | Just DBTCsvEncode{..} <- dbtCsvEncode , Just exportData <- fromDynamic dbCsvExportData -> do hdr <- dbtCsvHeader $ Just exportData - let ensureExtension ext fName = bool (`addExtension` ext) id (ext `isExtensionOf` fName) fName dbtCsvName' <- timestampCsv <*> pure dbtCsvName setContentDisposition' . Just $ ensureExtension (unpack extensionCsv) dbtCsvName' sendResponse <=< liftHandler . respondCsvDB hdr $ C.sourceList (zip currentKeys rows) .| dbtCsvDoEncode exportData >> lift E.transactionSave diff --git a/src/Model.hs b/src/Model.hs index f33d6a3ce..eff1ffb82 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -57,6 +57,7 @@ instance ToMessage (Key Term) where instance HasFileReference CourseApplicationFile where newtype FileReferenceResidual CourseApplicationFile = CourseApplicationFileResidual { courseApplicationFileResidualApplication :: CourseApplicationId } + deriving (Eq, Ord, Read, Show, Generic, Typeable) _FileReference = iso (\CourseApplicationFile{..} -> ( FileReference @@ -84,6 +85,7 @@ instance HasFileReference CourseApplicationFile where instance HasFileReference CourseAppInstructionFile where newtype FileReferenceResidual CourseAppInstructionFile = CourseAppInstructionFileResidual { courseAppInstructionFileResidualCourse :: CourseId } + deriving (Eq, Ord, Read, Show, Generic, Typeable) _FileReference = iso (\CourseAppInstructionFile{..} -> ( FileReference @@ -112,7 +114,7 @@ instance HasFileReference SheetFile where data FileReferenceResidual SheetFile = SheetFileResidual { sheetFileResidualSheet :: SheetId , sheetFileResidualType :: SheetFileType - } + } deriving (Eq, Ord, Read, Show, Generic, Typeable) _FileReference = iso (\SheetFile{..} -> ( FileReference @@ -146,7 +148,7 @@ instance HasFileReference PersonalisedSheetFile where { personalisedSheetFileResidualSheet :: SheetId , personalisedSheetFileResidualUser :: UserId , personalisedSheetFileResidualType :: SheetFileType - } + } deriving (Eq, Ord, Read, Show, Generic, Typeable) _FileReference = iso (\PersonalisedSheetFile{..} -> ( FileReference @@ -182,7 +184,7 @@ instance HasFileReference SubmissionFile where { submissionFileResidualSubmission :: SubmissionId , submissionFileResidualIsUpdate , submissionFileResidualIsDeletion :: Bool - } + } deriving (Eq, Ord, Read, Show, Generic, Typeable) _FileReference = iso (\SubmissionFile{..} -> ( FileReference @@ -216,6 +218,7 @@ instance HasFileReference SubmissionFile where instance HasFileReference CourseNewsFile where newtype FileReferenceResidual CourseNewsFile = CourseNewsFileResidual { courseNewsFileResidualNews :: CourseNewsId } + deriving (Eq, Ord, Read, Show, Generic, Typeable) _FileReference = iso (\CourseNewsFile{..} -> ( FileReference @@ -241,9 +244,9 @@ instance HasFileReference CourseNewsFile where fileReferenceModifiedField = CourseNewsFileModified instance HasFileReference MaterialFile where - data FileReferenceResidual MaterialFile = MaterialFileResidual - { materialFileResidualMaterial :: MaterialId - } + newtype FileReferenceResidual MaterialFile + = MaterialFileResidual { materialFileResidualMaterial :: MaterialId } + deriving (Eq, Ord, Read, Show, Generic, Typeable) _FileReference = iso (\MaterialFile{..} -> ( FileReference diff --git a/src/Utils.hs b/src/Utils.hs index 20bb69524..8a96ec3cc 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -109,6 +109,9 @@ import qualified Data.Text.Lazy.Builder as Builder import Unsafe.Coerce +import System.FilePath as Utils (addExtension, isExtensionOf) +import System.FilePath (dropDrive) + {-# ANN module ("HLint: ignore Use asum" :: String) #-} @@ -440,6 +443,23 @@ dropWhileM p xs' = bool (return xs') (dropWhileM p xs) =<< p x | otherwise = return xs' + +isSubsequenceOfBy :: (a -> b -> Bool) -> [a] -> [b] -> Bool +isSubsequenceOfBy _ [] _ = True +isSubsequenceOfBy _ _ [] = False +isSubsequenceOfBy cmp a@(x:a') (y:b) + | x `cmp` y = isSubsequenceOfBy cmp a' b + | otherwise = isSubsequenceOfBy cmp a b + +withoutSubsequenceBy :: (a -> b -> Bool) -> [a] -> [b] -> Maybe [b] +withoutSubsequenceBy cmp = go [] + where go acc [] b = Just $ reverse acc ++ b + go _ _ [] = Nothing + go acc a@(x:a') (y:b) + | x `cmp` y = go acc a' b + | otherwise = go (y:acc) a b + + ---------- -- Sets -- ---------- @@ -1192,3 +1212,15 @@ instance (Eq k, Hashable k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON parseJSONElemAtIndex :: (Value -> Aeson.Parser a) -> Int -> Vector Value -> Aeson.Parser a parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) Aeson. Aeson.Index idx + +-------------- +-- FilePath -- +-------------- + +ensureExtension :: String -> FilePath -> FilePath +ensureExtension ext fName = bool (`addExtension` ext) id (ext `isExtensionOf` fName) fName + +infixr 4 + +() :: FilePath -> FilePath -> FilePath +dir file = dir dropDrive file diff --git a/src/Utils/Files.hs b/src/Utils/Files.hs index 8ccf64b13..d8045f015 100644 --- a/src/Utils/Files.hs +++ b/src/Utils/Files.hs @@ -2,7 +2,7 @@ module Utils.Files ( sinkFile, sinkFiles , sinkFile', sinkFiles' , FileUploads - , replaceFileReferences + , replaceFileReferences, replaceFileReferences' ) where import Import.NoFoundation @@ -19,7 +19,6 @@ import qualified Data.ByteArray as ByteArray import qualified Data.Map.Lazy as Map import qualified Data.Set as Set -import Control.Monad.Trans.State.Lazy (execStateT) import Control.Monad.State.Class (modify) import Database.Persist.Sql (deleteWhereCount) @@ -81,19 +80,17 @@ sinkFile' file residual = do type FileUploads = ConduitT () FileReference (HandlerFor UniWorX) () -replaceFileReferences :: ( MonadHandler m, MonadThrow m - , HandlerSite m ~ UniWorX - , HasFileReference record - , PersistEntityBackend record ~ SqlBackend - ) - => (FileReferenceResidual record -> [Filter record]) - -> FileReferenceResidual record - -> FileUploads - -> SqlPersistT m (Set (Key record), Set (Key record)) -- ^ @(oldFiles, changes)@ -replaceFileReferences mkFilter residual fs = do +replaceFileReferences' :: ( MonadIO m, MonadThrow m + , HasFileReference record + , PersistEntityBackend record ~ SqlBackend + ) + => (FileReferenceResidual record -> [Filter record]) + -> FileReferenceResidual record + -> ConduitT FileReference Void (SqlPersistT m) (Set (Key record), Set (Key record)) -- ^ @(oldFiles, changes)@ +replaceFileReferences' mkFilter residual = do let resFilter = mkFilter residual - oldFiles <- Map.fromListWith Set.union . map (\(Entity k v) -> (v ^. _FileReference . _1, Set.singleton k)) <$> selectList resFilter [] + oldFiles <- lift $ Map.fromListWith Set.union . map (\(Entity k v) -> (v ^. _FileReference . _1, Set.singleton k)) <$> selectList resFilter [] let oldFiles' = setOf (folded . folded) oldFiles let @@ -111,8 +108,19 @@ replaceFileReferences mkFilter residual fs = do fId <- lift $ insert fRef' modify $ Map.alter (Just . maybe (Set.singleton fId) (Set.insert fId)) fRef - changes <- fmap (setOf $ folded . folded) . flip execStateT oldFiles . runConduit $ transPipe liftHandler fs .| C.mapM_ finsert + changes <- fmap (setOf $ folded . folded) . execStateC oldFiles $ C.mapM_ finsert - deleteWhere $ resFilter <> [ persistIdField <-. Set.toList (oldFiles' `Set.intersection` changes) ] + lift . deleteWhere $ resFilter <> [ persistIdField <-. Set.toList (oldFiles' `Set.intersection` changes) ] return (oldFiles', changes) + +replaceFileReferences :: ( MonadHandler m, MonadThrow m + , HandlerSite m ~ UniWorX + , HasFileReference record + , PersistEntityBackend record ~ SqlBackend + ) + => (FileReferenceResidual record -> [Filter record]) + -> FileReferenceResidual record + -> FileUploads + -> SqlPersistT m (Set (Key record), Set (Key record)) -- ^ @(oldFiles, changes)@ +replaceFileReferences mkFilter residual fs = runConduit $ transPipe liftHandler fs .| replaceFileReferences' mkFilter residual diff --git a/src/Utils/Memo.hs b/src/Utils/Memo.hs new file mode 100644 index 000000000..2c5af621c --- /dev/null +++ b/src/Utils/Memo.hs @@ -0,0 +1,25 @@ +module Utils.Memo + ( evalMemoStateC + ) where + +import ClassyPrelude +import Data.Conduit +import Data.Conduit.Lift (evalStateC) + +import Control.Monad.Memo +import Control.Monad.Trans.State.Strict (StateT) +import qualified Control.Monad.State.Class as State + + +evalMemoStateC :: forall m s k v i o r. + Monad m + => s -> ConduitT i o (MemoStateT s k v m) r -> ConduitT i o m r +evalMemoStateC initSt = evalStateC initSt . transPipe runMemoStateT' + where + runMemoStateT' :: forall a. + MemoStateT s k v m a + -> StateT s m a + runMemoStateT' act = do + cache <- State.get + (res, cache') <- lift $ runMemoStateT act cache + res <$ State.put cache' diff --git a/templates/messages/personalisedSheetFilesIgnored.hamlet b/templates/messages/personalisedSheetFilesIgnored.hamlet new file mode 100644 index 000000000..c24725cec --- /dev/null +++ b/templates/messages/personalisedSheetFilesIgnored.hamlet @@ -0,0 +1,9 @@ +$newline never +_{MsgPersonalisedSheetFilesIgnoredIntro} +