diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index cf8c9b568..fe3cecba6 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -333,6 +333,11 @@ SheetGeneratePseudonym: Generieren SheetAnonymousCorrection: Anonymisierte Korrektur SheetAnonymousCorrectionTip: Wenn die Korrektur anonymisiert erfolgt, können Korrektoren die ihnen zugeteilten Abgaben nicht bestimmten Studierenden zuordnen (Name, Matrikelnummer und feste Abgabegruppe der Abgebenden werden versteckt) +SheetArchiveFileTypeDirectoryExercise: aufgabenstellung +SheetArchiveFileTypeDirectoryHint: hinweis +SheetArchiveFileTypeDirectorySolution: loesung +SheetArchiveFileTypeDirectoryMarking: korrektur + SheetFormType: Wertung & Abgabe SheetFormTimes: Zeiten SheetFormFiles: Dateien diff --git a/minio-file-uploads.md b/minio-file-uploads.md new file mode 100644 index 000000000..e49af3033 --- /dev/null +++ b/minio-file-uploads.md @@ -0,0 +1,12 @@ + - `SessionFile` should only have `touched` and `content`; just there to keep `FileContent` alive + Store `fileTitle` and `fileModified` within actual session + + Better symmetry with e.g. `SubmissionFile` + - Restrict `genericFileField` to not allow duplicate `fileTitle`s + + Make `fieldAdditionalFiles` isomophoric to `[FileReference, FileFieldUserOption Bool]` + + `type FileUploads = Map FileTitle (Maybe FileContentReference, UTCTime)` (`~ [FileReference]`) + - Route um Uploads nachzureichen + + Cronjob, der `FileContent` aus MinIO füttert sollte panische E-Mail mit Link auf jene Route verschicken, wenn Datei nicht zur Hand ist \ No newline at end of file diff --git a/models/allocations.model b/models/allocations.model index a1d254dda..64f395a4d 100644 --- a/models/allocations.model +++ b/models/allocations.model @@ -30,7 +30,7 @@ AllocationMatching allocation AllocationId fingerprint AllocationFingerprint time UTCTime - log FileId + log FileContentReference AllocationCourse allocation AllocationId diff --git a/models/audit.model b/models/audit.model index ecff023f5..4524fdaf1 100644 --- a/models/audit.model +++ b/models/audit.model @@ -4,4 +4,5 @@ TransactionLog instance InstanceId initiator UserId Maybe -- User associated with performing this action remote IP Maybe -- Remote party that triggered this action via HTTP - info Value -- JSON-encoded `Transaction` \ No newline at end of file + info Value -- JSON-encoded `Transaction` + deriving Eq Read Show Generic Typeable \ No newline at end of file diff --git a/models/courses.model b/models/courses.model index 21bd6132b..db9ba46e0 100644 --- a/models/courses.model +++ b/models/courses.model @@ -35,9 +35,11 @@ CourseEvent lastChanged UTCTime default=now() CourseAppInstructionFile - course CourseId - file FileId - UniqueCourseAppInstructionFile course file + course CourseId + title FilePath + content FileContentReference Maybe + modified UTCTime + UniqueCourseAppInstructionFile course title CourseEdit -- who edited when a row in table "Course", kept indefinitely (might be replaced by generic Audit Table; like all ...-Edit tables) user UserId diff --git a/models/courses/applications.model b/models/courses/applications.model index d1d3a4876..b4648a60e 100644 --- a/models/courses/applications.model +++ b/models/courses/applications.model @@ -10,7 +10,10 @@ CourseApplication allocationPriority Natural Maybe time UTCTime default=now() ratingTime UTCTime Maybe + CourseApplicationFile application CourseApplicationId - file FileId - UniqueApplicationFile application file + title FilePath + content FileContentReference Maybe + modified UTCTime + UniqueCourseApplicationFile application title diff --git a/models/courses/materials.model b/models/courses/materials.model index b8d321fc3..fd1d19fb7 100644 --- a/models/courses/materials.model +++ b/models/courses/materials.model @@ -9,5 +9,7 @@ Material -- course material for disemination to course participants deriving Generic MaterialFile -- a file that is part of a material distribution material MaterialId - file FileId - UniqueMaterialFile material file \ No newline at end of file + title FilePath + content FileContentReference Maybe + modified UTCTime + UniqueMaterialFile material title \ No newline at end of file diff --git a/models/courses/news.model b/models/courses/news.model index 8596d0930..fdd2c0254 100644 --- a/models/courses/news.model +++ b/models/courses/news.model @@ -7,6 +7,8 @@ CourseNews summary Html Maybe lastEdit UTCTime CourseNewsFile - news CourseNewsId - file FileId - UniqueCourseNewsFile news file \ No newline at end of file + news CourseNewsId + title FilePath + content FileContentReference Maybe + modified UTCTime + UniqueCourseNewsFile news title \ No newline at end of file diff --git a/models/files.model b/models/files.model index 6b2324e55..eae0276d7 100644 --- a/models/files.model +++ b/models/files.model @@ -1,12 +1,8 @@ --- Table storing all kinds of larges files as 8bit-byte vectors (regardless of encoding) --- PostgreSQL is intelligent enough to handle this in a sensible manner; --- helps to ensure consistency of database snapshots, no data is stored outside database -File - title FilePath - content ByteString Maybe -- Nothing iff this is a directory - modified UTCTime - deriving Show Eq Generic +FileContent + hash FileContentReference + content ByteString + Primary hash SessionFile - file FileId + content FileContentReference Maybe touched UTCTime \ No newline at end of file diff --git a/models/sheets.model b/models/sheets.model index 418590e52..0f674b67b 100644 --- a/models/sheets.model +++ b/models/sheets.model @@ -37,7 +37,9 @@ SheetCorrector -- grant corrector role to user for a sheet UniqueSheetCorrector user sheet deriving Show Eq Ord SheetFile -- a file that is part of an exercise sheet - sheet SheetId - file FileId - type SheetFileType -- excercise, marking, hint or solution - UniqueSheetFile file sheet type + sheet SheetId + type SheetFileType -- excercise, marking, hint or solution + title FilePath + content FileContentReference Maybe + modified UTCTime + UniqueSheetFile sheet type title diff --git a/models/submissions.model b/models/submissions.model index e7e85f02c..f2c87fdc4 100644 --- a/models/submissions.model +++ b/models/submissions.model @@ -11,11 +11,13 @@ SubmissionEdit -- user uploads new version of their submissio time UTCTime submission SubmissionId SubmissionFile -- files that are part of a submission - submission SubmissionId - file FileId - isUpdate Bool -- is this the file updated by a corrector (original will always be retained) - isDeletion Bool -- only set if isUpdate is also set, but file was deleted by corrector - UniqueSubmissionFile file submission isUpdate + submission SubmissionId + title FilePath + content FileContentReference Maybe + modified UTCTime + isUpdate Bool -- is this the file updated by a corrector (original will always be retained) + isDeletion Bool -- only set if isUpdate is also set, but file was deleted by corrector + UniqueSubmissionFile submission title isUpdate deriving Show SubmissionUser -- which submission belongs to whom user UserId diff --git a/src/Audit.hs b/src/Audit.hs index 0b7890b8c..fb52cb96d 100644 --- a/src/Audit.hs +++ b/src/Audit.hs @@ -24,6 +24,8 @@ import qualified Net.IPv6 as IPv6 import Control.Exception (ErrorCall(..)) +import GHC.Stack + {-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-} @@ -86,6 +88,7 @@ audit :: ( AuthId (HandlerSite m) ~ Key User , MonadHandler m , MonadCatch m , HasAppSettings (HandlerSite m) + , HasCallStack ) => Transaction -- ^ Transaction to record -> ReaderT (YesodPersistBackend (HandlerSite m)) m () @@ -94,7 +97,7 @@ audit :: ( AuthId (HandlerSite m) ~ Key User -- - `transactionLogTime` is now -- - `transactionLogInitiator` is currently logged in user (or none) -- - `transactionLogRemote` is determined from current HTTP-Request -audit (toJSON -> transactionLogInfo) = do +audit transaction@(toJSON -> transactionLogInfo) = do transactionLogTime <- liftIO getCurrentTime transactionLogInstance <- getsYesod $ view instanceID @@ -102,3 +105,5 @@ audit (toJSON -> transactionLogInfo) = do transactionLogRemote <- handle (throwM . AuditRemoteException) $ Just <$> getRemote insert_ TransactionLog{..} + + $logInfoS "Audit" $ tshow (transaction, transactionLogInitiator, transactionLogRemote) <> "\n" <> pack (prettyCallStack callStack) diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 61c3628a9..573a91af5 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -92,28 +92,10 @@ data Transaction | TransactionSubmissionFileEdit { transactionSubmissionFile :: SubmissionFileId , transactionSubmission :: SubmissionId - , transactionFile :: FileId } | TransactionSubmissionFileDelete { transactionSubmissionFile :: SubmissionFileId , transactionSubmission :: SubmissionId - , transactionFile :: FileId - } - - -- TODO: not yet audited - | TransactionUserEdit - { transactionUser :: UserId - } - | TransactionUserDelete - { transactionUser :: UserId - } - - -- TODO: not yet audited - | TransactionFileEdit - { transactionFile :: FileId - } - | TransactionFileDelete - { transactionFile :: FileId } | TransactionExamOfficeUserAdd diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 02ec64b11..a6cfb4d62 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -58,7 +58,6 @@ instance {-# OVERLAPPING #-} MonadThrow m => MonadCrypto (ReaderT CryptoIDKey m) -- Generates CryptoUUID... and CryptoFileName... Datatypes decCryptoIDs [ ''SubmissionId - , ''FileId , ''UserId , ''SheetId , ''SystemMessageId diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index c94b61c08..026f3e79e 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -22,6 +22,7 @@ module Database.Esqueleto.Utils , (->.) , fromSqlKey , selectCountRows + , selectMaybe , module Database.Esqueleto.Utils.TH ) where @@ -271,3 +272,6 @@ selectCountRows q = do -> return res' _other -> error "E.countRows did not return exactly one result" + +selectMaybe :: (E.SqlSelect a r, MonadIO m) => E.SqlQuery a -> E.SqlReadT m (Maybe r) +selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1) diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index b95207b9b..ce5ead5ee 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -7,6 +7,7 @@ module Foundation.I18n , MsgLanguage(..) , ShortSex(..) , SheetTypeHeader(..) + , SheetArchiveFileTypeDirectory(..) , ShortStudyDegree(..) , ShortStudyTerms(..) , StudyDegreeTerm(..) @@ -212,6 +213,9 @@ embedRenderMessageVariant ''UniWorX ''ShortSex ("Short" <>) newtype SheetTypeHeader = SheetTypeHeader SheetType embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>) +newtype SheetArchiveFileTypeDirectory = SheetArchiveFileTypeDirectory SheetFileType +embedRenderMessageVariant ''UniWorX ''SheetArchiveFileTypeDirectory $ ("SheetArchiveFileTypeDirectory" <>) . concat . drop 1 . splitCamel + instance RenderMessage UniWorX SheetType where renderMessage foundation ls sheetType = case sheetType of NotGraded -> mr $ SheetTypeHeader NotGraded diff --git a/src/Handler/Admin/Test/Download.hs b/src/Handler/Admin/Test/Download.hs index a7c73c857..a6efc04ef 100644 --- a/src/Handler/Admin/Test/Download.hs +++ b/src/Handler/Admin/Test/Download.hs @@ -10,7 +10,6 @@ import qualified Crypto.Random as Random import qualified Data.ByteString.Base64.URL as Base64 -import qualified Data.Conduit.List as C (mapMaybe) import qualified Data.Conduit.Combinators as C import qualified Data.Binary as Binary @@ -81,13 +80,12 @@ testDownload = do sourceDBChunks :: ConduitT () Int DB () sourceDBChunks = forever sourceDBFiles .| C.mapM (\x -> x <$ $logDebugS "testDownload.sourceDBChunks" (tshow $ entityKey x)) - .| C.mapMaybe ((fmap length $!!) . fileContent . entityVal) + .| C.map ((length $!!) . fileContentContent . entityVal) .| takeLimit dlMaxSize where - sourceDBFiles = E.selectSource . E.from $ \file -> do + sourceDBFiles = E.selectSource . E.from $ \fileContent -> do E.orderBy [E.asc $ E.random_ @Int64] - E.where_ . E.not_ . E.isNothing $ file E.^. FileContent - return file + return fileContent takeLimit n | n <= 0 = return () takeLimit n = do diff --git a/src/Handler/Allocation/Application.hs b/src/Handler/Allocation/Application.hs index 9c1cba0e1..b7eebebb0 100644 --- a/src/Handler/Allocation/Application.hs +++ b/src/Handler/Allocation/Application.hs @@ -15,12 +15,9 @@ import qualified Data.Text as Text import qualified Data.Set as Set import qualified Database.Esqueleto as E -import qualified Database.Esqueleto.Utils as E import qualified Data.Conduit.List as C -import Crypto.Hash (hash) - import Control.Monad.Trans.State (execStateT) import Control.Monad.State.Class (modify) @@ -290,13 +287,8 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do , courseApplicationTime = now , courseApplicationRatingTime = guardOn rated now } - let - sinkFile' (Right file) = - insert file >>= sinkFile' . Left - sinkFile' (Left fId) = - insert_ $ CourseApplicationFile appId fId - forM_ afFiles $ \afFiles' -> - runConduit $ transPipe liftHandler afFiles' .| C.mapM_ sinkFile' + + runConduit $ transPipe liftHandler (traverse_ id afFiles) .| C.mapM_ (insert_ . review _FileReference . (, CourseApplicationFileResidual appId)) audit $ TransactionCourseApplicationEdit cid uid appId addMessageI Success $ MsgCourseApplicationCreated courseShorthand | is _BtnAllocationApplicationEdit afAction || is _BtnAllocationApplicationRate afAction @@ -307,33 +299,15 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do changes <- if | afmApplicantEdit afMode -> do - oldFiles <- Set.fromList . map (courseApplicationFileFile . entityVal) <$> selectList [CourseApplicationFileApplication ==. appId] [] + oldFiles <- Set.fromList . map (courseApplicationFileTitle . entityVal) <$> selectList [CourseApplicationFileApplication ==. appId] [] changes <- flip execStateT oldFiles . forM_ afFiles $ \afFiles' -> - let sinkFile' (Right file) = do - oldFiles' <- lift . E.select . E.from $ \(courseApplicationFile `E.InnerJoin` file') -> do - E.on $ courseApplicationFile E.^. CourseApplicationFileFile E.==. file' E.^. FileId - E.where_ $ file' E.^. FileTitle E.==. E.val (fileTitle file) - E.&&. E.maybe - (E.val . is _Nothing $ fileContent file) - (\fc' -> maybe E.false (\fc -> E.sha256 fc' E.==. E.val (hash fc)) $ fileContent file) - (file' E.^. FileContent) - E.&&. file' E.^. FileId `E.in_` E.valList (Set.toList oldFiles) - return $ file' E.^. FileId - if - | [E.Value oldFileId] <- oldFiles' - -> modify $ Set.delete oldFileId - | otherwise - -> do - fId <- lift $ insert file - lift . insert_ $ CourseApplicationFile appId fId - modify $ Set.insert fId - sinkFile' (Left fId) - | fId `Set.member` oldFiles = modify $ Set.delete fId + let sinkAppFile fRef@FileReference{..} + | fileReferenceTitle `Set.member` oldFiles = modify $ Set.delete fileReferenceTitle | otherwise = do - lift . insert_ $ CourseApplicationFile appId fId - modify $ Set.insert fId - in runConduit $ transPipe liftHandler afFiles' .| C.mapM_ sinkFile' - deleteCascadeWhere [ FileId <-. Set.toList (oldFiles `Set.intersection` changes) ] + lift . insert_ $ _FileReference # (fRef, CourseApplicationFileResidual appId) + modify $ Set.insert fileReferenceTitle + in runConduit $ transPipe liftHandler afFiles' .| C.mapM_ sinkAppFile + deleteWhere [ CourseApplicationFileApplication ==. appId, CourseApplicationFileTitle <-. Set.toList (oldFiles `Set.intersection` changes) ] return changes | otherwise -> return Set.empty diff --git a/src/Handler/Course/Application/Files.hs b/src/Handler/Course/Application/Files.hs index 124ec688f..c608aa94e 100644 --- a/src/Handler/Course/Application/Files.hs +++ b/src/Handler/Course/Application/Files.hs @@ -31,10 +31,9 @@ getCAFilesR tid ssh csh cID = do archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCourseApplicationArchiveName tid ssh csh cID userDisplayName let - fsSource = E.selectSource . E.from $ \(courseApplicationFile `E.InnerJoin` file) -> do - E.on $ courseApplicationFile E.^. CourseApplicationFileFile E.==. file E.^. FileId + fsSource = E.selectSource . E.from $ \courseApplicationFile -> do E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. E.val appId - return file + return courseApplicationFile serveSomeFiles archiveName $ fsSource .| C.map entityVal @@ -47,7 +46,7 @@ getCAppsFilesR tid ssh csh = do archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCourseAllApplicationsArchiveName tid ssh csh let - fsSource :: ConduitT () File DB () + fsSource :: ConduitT () CourseApplicationFile DB () fsSource = do apps <- lift . E.select . E.from $ \((course `E.InnerJoin` courseApplication `E.InnerJoin` user) `E.LeftOuterJoin` allocation) -> do E.on $ allocation E.?. AllocationId E.==. courseApplication E.^. CourseApplicationAllocation @@ -90,19 +89,19 @@ getCAppsFilesR tid ssh csh = do forM_ apps' $ \(mbAlloc, Entity _ User{..}, Entity appId CourseApplication{..}) -> do cID <- cachedByBinary appId $ encrypt appId :: _ CryptoFileNameCourseApplication let mkAppDir = mkAllocationDir (entityVal <$> mbAlloc) . () (unpack [st|#{CI.foldedCase $ ciphertext cID}-#{CI.foldCase userSurname}|]) - dirFiles = C.map $ over _fileTitle mkAppDir . entityVal - fileEntitySource = E.selectSource . E.from $ \(courseApplicationFile `E.InnerJoin` file) -> do - E.on $ courseApplicationFile E.^. CourseApplicationFileFile E.==. file E.^. FileId + fileEntitySource = E.selectSource . E.from $ \courseApplicationFile -> do E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. E.val appId - return file + return courseApplicationFile - yield File - { fileModified = courseApplicationTime - , fileTitle = mkAppDir "" - , fileContent = Nothing - } + yield $ _FileReference # ( FileReference + { fileReferenceModified = courseApplicationTime + , fileReferenceTitle = mkAppDir "" + , fileReferenceContent = Nothing + } + , CourseApplicationFileResidual appId + ) - fileEntitySource .| dirFiles + fileEntitySource .| C.map (view _entityVal) .| C.map (over (_FileReference . _1 . _fileReferenceTitle) mkAppDir) serveSomeFiles archiveName fsSource diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index a867bba49..d7a774586 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -40,7 +40,7 @@ data CourseForm = CourseForm , cfAllocation :: Maybe AllocationCourseForm , cfAppRequired :: Bool , cfAppInstructions :: Maybe Html - , cfAppInstructionFiles :: Maybe (ConduitT () (Either FileId File) Handler ()) + , cfAppInstructionFiles :: Maybe FileUploads , cfAppText :: Bool , cfAppFiles :: UploadMode , cfAppRatingsVisible :: Bool @@ -84,10 +84,10 @@ courseToForm cEnt@(Entity cid Course{..}) lecs lecInvites alloc = CourseForm ++ [Left (email, mType) | (email, InvDBDataLecturer mType) <- Map.toList lecInvites ] } where - cfAppInstructionFiles = Just . transPipe runDB $ selectAppFiles .| C.map (Left . E.unValue) + cfAppInstructionFiles = Just . transPipe runDB $ selectAppFiles .| C.map (view $ _entityVal . _FileReference . _1) where selectAppFiles = E.selectSource . E.from $ \courseAppInstructionFile -> do E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. E.val cid - return $ courseAppInstructionFile E.^. CourseAppInstructionFileFile + return courseAppInstructionFile allocationCourseToForm :: Entity Course -> Entity AllocationCourse -> AllocationCourseForm @@ -521,14 +521,14 @@ courseEditHandler miButtonAction mbCourseForm = do insert_ $ CourseEdit aid now cid let - finsert val = do - fId <- lift $ either return insert val - tell $ Set.singleton fId - lift $ - void . insertUnique $ CourseAppInstructionFile cid fId + finsert fRef@FileReference{..} = do + tell $ Set.singleton fileReferenceTitle + void . lift $ upsertBy (UniqueCourseAppInstructionFile cid fileReferenceTitle) (_FileReference # (fRef, CourseAppInstructionFileResidual cid)) + [ CourseAppInstructionFileModified =. fileReferenceModified + , CourseAppInstructionFileContent =. fileReferenceContent + ] keep <- execWriterT . runConduit $ transPipe liftHandler (traverse_ id $ cfAppInstructionFiles res) .| C.mapM_ finsert - acfs <- selectList [ CourseAppInstructionFileCourse ==. cid, CourseAppInstructionFileFile /<-. Set.toList keep ] [] - mapM_ deleteCascade $ map (courseAppInstructionFileFile . entityVal) acfs + deleteWhere [ CourseAppInstructionFileCourse ==. cid, CourseAppInstructionFileTitle /<-. Set.toList keep ] upsertAllocationCourse cid $ cfAllocation res diff --git a/src/Handler/Course/News/Download.hs b/src/Handler/Course/News/Download.hs index f83244ce8..b898c7f7f 100644 --- a/src/Handler/Course/News/Download.hs +++ b/src/Handler/Course/News/Download.hs @@ -19,10 +19,9 @@ getCNArchiveR tid ssh csh cID = do archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgCourseNewsArchiveName tid ssh csh (fromMaybe (toPathPiece courseNewsLastEdit) courseNewsTitle) let getFilesQuery = (.| C.map entityVal) . E.selectSource . E.from $ - \(newsFile `E.InnerJoin` file) -> do - E.on $ file E.^. FileId E.==. newsFile E.^. CourseNewsFileFile + \newsFile -> do E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId - return file + return newsFile serveSomeFiles archiveName getFilesQuery @@ -32,10 +31,9 @@ getCNFileR _ _ _ cID title = do nId <- decrypt cID let - fileQuery = E.selectSource . E.from $ \(newsFile `E.InnerJoin` file) -> do - E.on $ newsFile E.^. CourseNewsFileFile E.==. file E.^. FileId - E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId - E.&&. file E.^. FileTitle E.==. E.val title - return file + fileQuery = E.selectSource . E.from $ \newsFile -> do + E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId + E.&&. newsFile E.^. CourseNewsFileTitle E.==. E.val title + return newsFile serveOneFile $ fileQuery .| C.map entityVal diff --git a/src/Handler/Course/News/Edit.hs b/src/Handler/Course/News/Edit.hs index af701c4ca..61c92a49d 100644 --- a/src/Handler/Course/News/Edit.hs +++ b/src/Handler/Course/News/Edit.hs @@ -20,7 +20,7 @@ postCNEditR tid ssh csh cID = do courseNews <- get404 nId cnfs <- selectList [CourseNewsFileNews ==. nId] [] return ( courseNews - , setOf (folded . _entityVal . _courseNewsFileFile) cnfs + , cnfs ^.. folded . _entityVal . _FileReference . _1 ) ((newsRes, newsWgt'), newsEnctype) <- runFormPost . courseNewsForm . Just $ courseNewsToForm courseNews fids @@ -38,10 +38,12 @@ postCNEditR tid ssh csh cID = do , courseNewsLastEdit = now } let - insertFile (Left fId) = fId <$ upsertBy (UniqueCourseNewsFile nId fId) (CourseNewsFile nId fId) [] - insertFile (Right f ) = insert f >>= \fId -> fId <$ insert_ (CourseNewsFile nId fId) - newFids <- runConduit $ transPipe lift (fromMaybe (return ()) cnfFiles) .| C.mapM insertFile .| C.foldMap Set.singleton - deleteWhere [ CourseNewsFileNews ==. nId, CourseNewsFileFile /<-. Set.toList newFids ] + insertFile fRef@FileReference{..} = fileReferenceTitle <$ upsertBy (UniqueCourseNewsFile nId fileReferenceTitle) (_FileReference # (fRef, CourseNewsFileResidual nId)) + [ CourseNewsFileModified =. fileReferenceModified + , CourseNewsFileContent =. fileReferenceContent + ] + newTitles <- runConduit $ transPipe lift (fromMaybe (return ()) cnfFiles) .| C.mapM insertFile .| C.foldMap Set.singleton + deleteWhere [ CourseNewsFileNews ==. nId, CourseNewsFileTitle /<-. Set.toList newTitles ] addMessageI Success MsgCourseNewsEdited redirect $ CourseR tid ssh csh CShowR :#: [st|news-#{toPathPiece cID}|] diff --git a/src/Handler/Course/News/Form.hs b/src/Handler/Course/News/Form.hs index 992b1099c..0d52e3001 100644 --- a/src/Handler/Course/News/Form.hs +++ b/src/Handler/Course/News/Form.hs @@ -9,8 +9,6 @@ import Handler.Utils import qualified Data.Conduit.List as C -import qualified Data.Set as Set - data CourseNewsForm = CourseNewsForm { cnfTitle :: Maybe Text @@ -18,14 +16,14 @@ data CourseNewsForm = CourseNewsForm , cnfContent :: Html , cnfParticipantsOnly :: Bool , cnfVisibleFrom :: Maybe UTCTime - , cnfFiles :: Maybe (ConduitT () (Either FileId File) Handler ()) + , cnfFiles :: Maybe FileUploads } courseNewsForm :: Maybe CourseNewsForm -> Form CourseNewsForm courseNewsForm template = identifyForm FIDCourseNews . renderWForm FormStandard $ do now <- liftIO getCurrentTime - let oldFileIds = maybe (return mempty) (\s -> runConduit $ s .| C.foldMap (either opoint $ const mempty)) $ template >>= cnfFiles + let oldFileIds = fromMaybe (return ()) $ template >>= cnfFiles cTime = ceilingQuarterHour now visibleFromTip | Just vFrom <- template >>= cnfVisibleFrom @@ -48,7 +46,7 @@ courseNewsForm template = identifyForm FIDCourseNews . renderWForm FormStandard (cnfContent <$> template) cnfParticipantsOnly' <- wpopt checkBoxField (fslI MsgCourseNewsParticipantsOnly) (cnfParticipantsOnly <$> template) cnfVisibleFrom' <- wopt utcTimeField (fslI MsgCourseNewsVisibleFrom & setTooltip visibleFromTip) (cnfVisibleFrom <$> template <|> Just (Just cTime)) - cnfFiles' <- wopt (multiFileField oldFileIds) (fslI MsgCourseNewsFiles) (cnfFiles <$> template) + cnfFiles' <- wopt (multiFileField' oldFileIds) (fslI MsgCourseNewsFiles) (cnfFiles <$> template) return $ CourseNewsForm <$> cnfTitle' @@ -58,12 +56,12 @@ courseNewsForm template = identifyForm FIDCourseNews . renderWForm FormStandard <*> cnfVisibleFrom' <*> cnfFiles' -courseNewsToForm :: CourseNews -> Set FileId -> CourseNewsForm +courseNewsToForm :: CourseNews -> [FileReference] -> CourseNewsForm courseNewsToForm CourseNews{..} fs = CourseNewsForm { cnfTitle = courseNewsTitle , cnfSummary = courseNewsSummary , cnfContent = courseNewsContent , cnfParticipantsOnly = courseNewsParticipantsOnly , cnfVisibleFrom = courseNewsVisibleFrom - , cnfFiles = guardOn (not $ Set.null fs) $ C.sourceList (Left <$> Set.toList fs) + , cnfFiles = guardOn (not $ null fs) $ C.sourceList fs } diff --git a/src/Handler/Course/News/New.hs b/src/Handler/Course/News/New.hs index c6b2f10be..44c2f8924 100644 --- a/src/Handler/Course/News/New.hs +++ b/src/Handler/Course/News/New.hs @@ -30,8 +30,7 @@ postCNewsNewR tid ssh csh = do , courseNewsLastEdit = now } let - insertFile (Left fId) = insert_ $ CourseNewsFile nId fId - insertFile (Right f ) = insert_ . CourseNewsFile nId =<< insert f + insertFile = insert_ . review _FileReference . (, CourseNewsFileResidual nId) forM_ cnfFiles $ \fSource -> runConduit $ transPipe lift fSource .| C.mapM_ insertFile encrypt nId :: DB CryptoUUIDCourseNews diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index 106667ba3..5e0165a1c 100644 --- a/src/Handler/Course/Register.hs +++ b/src/Handler/Course/Register.hs @@ -195,7 +195,7 @@ postCRegisterR tid ssh csh = do whenIsJust appRes $ audit . TransactionCourseApplicationEdit cid uid whenIsJust ((,) <$> appRes <*> crfApplicationFiles) $ \(appId, fSource) -> do - runConduit $ transPipe liftHandler fSource .| C.mapM_ (insert_ . CourseApplicationFile appId <=< either return insert) + runConduit $ transPipe liftHandler fSource .| C.mapM_ (insert_ . review _FileReference . (, CourseApplicationFileResidual appId)) return appRes | otherwise = return $ Just () @@ -256,9 +256,7 @@ deleteApplications uid cid = do audit $ TransactionCourseApplicationDeleted cid uid appId deleteApplicationFiles :: CourseApplicationId -> DB () -deleteApplicationFiles appId = do - fs <- selectList [ CourseApplicationFileApplication ==. appId ] [] - deleteCascadeWhere [ FileId <-. map (courseApplicationFileFile . entityVal) fs ] +deleteApplicationFiles appId = deleteWhere [ CourseApplicationFileApplication ==. appId ] deregisterParticipant :: UserId -> CourseId -> DB () deregisterParticipant uid cid = do diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index e74d226da..d8cd57425 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -79,10 +79,9 @@ getCShowR tid ssh csh = do cID <- encrypt nId :: MaybeT (MaybeT DB) CryptoUUIDCourseNews guardM . hasReadAccessTo $ CNewsR tid ssh csh cID CNShowR let visible = cTime >= NTop courseNewsVisibleFrom - files' <- lift . lift . E.select . E.from $ \(newsFile `E.InnerJoin` file) -> do - E.on $ file E.^. FileId E.==. newsFile E.^. CourseNewsFileFile + files' <- lift . lift . E.select . E.from $ \newsFile -> do E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId - return (E.isNothing $ file E.^. FileContent, file E.^. FileTitle) + return (E.isNothing $ newsFile E.^. CourseNewsFileContent, newsFile E.^. CourseNewsFileTitle) let files = files' & over (mapped . _1) E.unValue & over (mapped . _2) E.unValue @@ -228,11 +227,10 @@ getCShowR tid ssh csh = do getCRegisterTemplateR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent getCRegisterTemplateR tid ssh csh = do archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgCourseApplicationTemplateArchiveName tid ssh csh - let source = (.| C.map entityVal) . E.selectSource . E.from $ \(file `E.InnerJoin` courseAppInstructionFile `E.InnerJoin` course) -> do + let source = (.| C.map entityVal) . E.selectSource . E.from $ \(courseAppInstructionFile `E.InnerJoin` course) -> do E.on $ course E.^. CourseId E.==. courseAppInstructionFile E.^. CourseAppInstructionFileCourse - E.on $ courseAppInstructionFile E.^. CourseAppInstructionFileFile E.==. file E.^. FileId E.where_ $ course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh - return file + return courseAppInstructionFile serveSomeFiles archiveName source diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index c84996842..3abce8011 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -22,19 +22,13 @@ data MaterialForm = MaterialForm , mfType :: Maybe (CI Text) , mfDescription :: Maybe Html , mfVisibleFrom :: Maybe UTCTime - , mfFiles :: Maybe (ConduitT () (Either FileId File) Handler ()) + , mfFiles :: Maybe FileUploads } makeMaterialForm :: CourseId -> Maybe MaterialForm -> Form MaterialForm makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do MsgRenderer mr <- getMsgRenderer - let setIds :: Either FileId File -> Set FileId - setIds = either Set.singleton $ const Set.empty - oldFileIds - | Just source <- template >>= mfFiles - = runConduit $ source .| C.foldMap setIds - | otherwise = return Set.empty - typeOptions :: HandlerFor UniWorX (OptionList (CI Text)) + let typeOptions :: HandlerFor UniWorX (OptionList (CI Text)) typeOptions = do let defaults = Set.fromList $ map (CI.mk . mr) [MsgMaterialTypeSlides,MsgMaterialTypeCode,MsgMaterialTypeExample] previouslyUsed <- runDB $ @@ -62,7 +56,7 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do (mfDescription <$> template) <*> aopt utcTimeField (fslI MsgMaterialVisibleFrom & setTooltip visibleToolTip) ((mfVisibleFrom <$> template) <|> pure (Just ctime)) - <*> aopt (multiFileField oldFileIds) + <*> aopt (multiFileField' . fromMaybe (return ()) $ mfFiles =<< template) (fslI MsgMaterialFiles) (mfFiles <$> template) getMaterialKeyBy404 :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (Key Material) @@ -163,20 +157,19 @@ getMFileR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> FilePath - getMFileR tid ssh csh mnm title = serveOneFile $ fileQuery .| C.map entityVal where fileQuery = E.selectSource $ E.from $ - \(course `E.InnerJoin` material `E.InnerJoin` matFile `E.InnerJoin` file) -> do + \(course `E.InnerJoin` material `E.InnerJoin` matFile) -> do -- Restrict to consistent rows that correspond to each other - E.on (file E.^. FileId E.==. matFile E.^. MaterialFileFile) E.on (matFile E.^. MaterialFileMaterial E.==. material E.^. MaterialId) E.on (material E.^. MaterialCourse E.==. course E.^. CourseId) -- filter to requested file - E.where_ ((file E.^. FileTitle E.==. E.val title) - E.&&. (material E.^. MaterialName E.==. E.val mnm ) - E.&&. (course E.^. CourseShorthand E.==. E.val csh ) - E.&&. (course E.^. CourseSchool E.==. E.val ssh ) - E.&&. (course E.^. CourseTerm E.==. E.val tid ) + E.where_ ((matFile E.^. MaterialFileTitle E.==. E.val title) + E.&&. (material E.^. MaterialName E.==. E.val mnm ) + E.&&. (course E.^. CourseShorthand E.==. E.val csh ) + E.&&. (course E.^. CourseSchool E.==. E.val ssh ) + E.&&. (course E.^. CourseTerm E.==. E.val tid ) ) -- return file entity - return file + return matFile getMShowR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html getMShowR tid ssh csh mnm = do @@ -197,12 +190,11 @@ getMShowR tid ssh csh mnm = do else colFileModificationWhen $ \t -> NTop (Just t) > NTop (materialVisibleFrom $ entityVal matEnt) let psValidator = def & defaultSortingByFileTitle fileTable' <- dbTable psValidator DBTable - { dbtSQLQuery = \(matFile `E.InnerJoin` file) -> do - E.on $ matFile E.^. MaterialFileFile E.==. file E.^. FileId + { dbtSQLQuery = \matFile -> do E.where_ $ matFile E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt) - E.&&. E.not_ (E.isNothing $ file E.^. FileContent) -- don't show directories - return (file E.^. FileTitle, file E.^. FileModified) - , dbtRowKey = \(_ `E.InnerJoin` file) -> file E.^. FileId + E.&&. E.not_ (E.isNothing $ matFile E.^. MaterialFileContent) -- don't show directories + return (matFile E.^. MaterialFileTitle, matFile E.^. MaterialFileModified) + , dbtRowKey = (E.^. MaterialFileId) , dbtColonnade = widgetColonnade $ mconcat [ (<> indicatorCell) <$> colFilePathSimple (view $ _dbrOutput . _1) matLink , materialModDateCol (view $ _dbrOutput . _2) @@ -214,9 +206,9 @@ getMShowR tid ssh csh mnm = do , dbtFilterUI = mempty , dbtIdent = "material-files" :: Text , dbtSorting = Map.fromList - [ sortFilePath $(sqlIJproj 2 2) - , sortFileModification $(sqlIJproj 2 2) - ] + [ sortFilePath id + , sortFileModification id + ] , dbtCsvEncode = noCsvEncode , dbtCsvDecode = Nothing } @@ -239,18 +231,15 @@ getMEditR = postMEditR postMEditR tid ssh csh mnm = do (Entity mid Material{..}, files) <- runDB $ do matEnt <- fetchMaterial tid ssh csh mnm - fileIds <- E.select . E.from $ \(matFile `E.InnerJoin` file) -> do - E.on $ matFile E.^. MaterialFileFile E.==. file E.^. FileId - E.where_ $ matFile E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt) - return $ file E.^. FileId - return (matEnt, Left . E.unValue <$> fileIds) + mFileEnts <- selectList [ MaterialFileMaterial ==. entityKey matEnt ] [] + return (matEnt, mFileEnts) -- let cid = materialCourse let template = Just MaterialForm { mfName = materialName , mfType = materialType , mfDescription = materialDescription , mfVisibleFrom = materialVisibleFrom - , mfFiles = Just $ yieldMany files + , mfFiles = Just $ yieldMany [ matFile ^. _FileReference . _1 | Entity _ matFile <- files ] } editWidget <- handleMaterialEdit tid ssh csh materialCourse template $ uniqueReplace mid let headingLong = prependCourseTitle tid ssh csh $ MsgMaterialEditHeading mnm @@ -305,23 +294,21 @@ handleMaterialEdit tid ssh csh cid template dbMaterial = do when saveOk $ redirect -- redirect must happen outside of runDB $ CourseR tid ssh csh (MaterialR mfName MShowR) - insertMaterialFile' :: MaterialId -> ConduitT () (Either FileId File) Handler () -> DB () + insertMaterialFile' :: MaterialId -> FileUploads -> DB () insertMaterialFile' mid fs = do - oldFileIdVals <- E.select . E.from $ \(file `E.InnerJoin` materialFile) -> do - E.on $ materialFile E.^. MaterialFileFile E.==. file E.^. FileId - E.where_ $ materialFile E.^. MaterialFileMaterial E.==. E.val mid - return $ file E.^. FileId - let oldFileIds = setFromList $ map E.unValue oldFileIdVals - keep <- execWriterT . runConduit $ transPipe (lift . lift) fs .| C.mapM_ finsert - mapM_ deleteCascade (oldFileIds \\ keep :: Set FileId) + oldFiles <- fmap (Map.fromList . map $(unValueN 2)) . E.select . E.from $ \materialFile -> do + E.where_ $ materialFile E.^. MaterialFileMaterial E.==. E.val mid + return (materialFile E.^. MaterialFileTitle, materialFile E.^. MaterialFileId) + keep <- execWriterT . runConduit $ transPipe liftHandler fs .| C.mapM_ (finsert oldFiles) + deleteWhere [ MaterialFileMaterial ==. mid, MaterialFileId <-. Set.toList (setOf folded oldFiles \\ keep) ] where - finsert (Left fid) = do - lift . void $ upsertBy (UniqueMaterialFile mid fid) (MaterialFile mid fid) [] - tell $ singleton fid - finsert (Right file) = lift $ do - fid <- insert file - void . insert $ MaterialFile mid fid -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step - + finsert oldFiles fRef + | Just sfId <- fileReferenceTitle fRef `Map.lookup` oldFiles + = tell $ Set.singleton sfId + | otherwise + = do + sfId <- lift . insert $ _FileReference # (fRef, MaterialFileResidual mid) + tell $ Set.singleton sfId getMDelR, postMDelR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html getMDelR = postMDelR @@ -363,15 +350,14 @@ getMArchiveR tid ssh csh mnm = do archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgMaterialArchiveName tid ssh csh mnm let getMatQuery = (.| C.map entityVal) . E.selectSource . E.from $ - \(course `E.InnerJoin` material `E.InnerJoin` materialFile `E.InnerJoin` file) -> do - E.on $ file E.^. FileId E.==. materialFile E.^. MaterialFileFile + \(course `E.InnerJoin` material `E.InnerJoin` materialFile) -> do E.on $ material E.^. MaterialId E.==. materialFile E.^. MaterialFileMaterial E.on $ material E.^. MaterialCourse E.==. course E.^. CourseId E.where_ $ course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. material E.^. MaterialName E.==. E.val mnm - return file + return materialFile serveSomeFiles archiveName getMatQuery diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index aa610b6e7..2a193a7dd 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -57,7 +57,7 @@ type Loads = Map (Either UserEmail UserId) (InvitationData SheetCorrector) data SheetForm = SheetForm { sfName :: SheetName , sfDescription :: Maybe Html - , sfSheetF, sfHintF, sfSolutionF, sfMarkingF :: Maybe (ConduitT () (Either FileId File) Handler ()) + , sfSheetF, sfHintF, sfSolutionF, sfMarkingF :: Maybe FileUploads , sfVisibleFrom :: Maybe UTCTime , sfActiveFrom :: Maybe UTCTime , sfActiveTo :: Maybe UTCTime @@ -85,13 +85,12 @@ instance Button UniWorX ButtonGeneratePseudonym where btnClasses BtnGenerate = [BCIsButton, BCDefault] -getFtIdMap :: Key Sheet -> DB (SheetFileType -> Set FileId) +getFtIdMap :: Key Sheet -> DB (SheetFileType -> Set FileReference) getFtIdMap sId = do - allfIds <- E.select . E.from $ \(sheetFile `E.InnerJoin` file) -> do - E.on $ sheetFile E.^. SheetFileFile E.==. file E.^. FileId + allSheetFiles <- E.select . E.from $ \sheetFile -> do E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sId - return (sheetFile E.^. SheetFileType, file E.^. FileId) - return $ partitionFileType [(t,i)|(E.Value t, E.Value i) <- allfIds] + return sheetFile + return $ partitionFileType [ (sheetFileType, sf ^. _FileReference . _1) | Entity _ sf@SheetFile{..} <- allSheetFiles ] makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm makeSheetForm msId template = identifyForm FIDsheet . validateForm validateSheet $ \html -> do @@ -353,14 +352,12 @@ getSShowR tid ssh csh shn = do | NTop (Just mtime) > NTop (sheetFileTypeDates sheet sft) = dateTimeCell mtime | otherwise = mempty - let fileData (sheetFile `E.InnerJoin` file) = do - -- Restrict to consistent rows that correspond to each other - E.on (sheetFile E.^. SheetFileFile E.==. file E.^. FileId) + let fileData sheetFile = do -- filter to requested file E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid - E.&&. E.not_ (E.isNothing $ file E.^. FileContent) -- don't show directories + E.&&. E.not_ (E.isNothing $ sheetFile E.^. SheetFileContent) -- don't show directories -- return desired columns - return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) + return $ (sheetFile E.^. SheetFileTitle, sheetFile E.^. SheetFileModified, sheetFile E.^. SheetFileType) let colonnadeFiles = widgetColonnade $ mconcat [ sortable (Just "type") (i18nCell MsgSheetFileTypeHeader) $ \(_,_, E.Value ftype) -> let link = CSheetR tid ssh csh shn $ SZipR ftype in @@ -382,7 +379,7 @@ getSShowR tid ssh csh shn = do & forceFilter "may-access" (Any True) (Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable { dbtSQLQuery = fileData - , dbtRowKey = \(_ `E.InnerJoin` file) -> file E.^. FileId + , dbtRowKey = (E.^. SheetFileId) , dbtColonnade = colonnadeFiles , dbtProj = return . dbrOutput :: DBRow _ -> DB (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType) , dbtStyle = def @@ -395,16 +392,16 @@ getSShowR tid ssh csh shn = do , dbtIdent = "files" :: Text , dbtSorting = Map.fromList [ ( "type" - , SortColumn $ \(sheetFile `E.InnerJoin` _file) -> E.orderByEnum $ sheetFile E.^. SheetFileType + , SortColumn $ \sheetFile -> E.orderByEnum $ sheetFile E.^. SheetFileType ) , ( "path" - , SortColumn $ \(_sheetFile `E.InnerJoin` file) -> file E.^. FileTitle + , SortColumn $ \sheetFile -> sheetFile E.^. SheetFileTitle ) -- , ( "visible" -- , SortColumn $ \(sheetFile `E.InnerJoin` _file) -> sheetFileTypeDates sheet $ sheetFile E.^. SheetFileType -- not possible without another join for the sheet -- ) , ( "time" - , SortColumn $ \(_sheetFile `E.InnerJoin` file) -> file E.^. FileModified + , SortColumn $ \sheetFile -> sheetFile E.^. SheetFileModified ) ] , dbtParams = def @@ -442,10 +439,44 @@ getSShowR tid ssh csh shn = do getSArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent getSArchiveR tid ssh csh shn = do - archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgSheetArchiveName tid ssh csh shn + shId <- runDB $ fetchSheetId tid ssh csh shn + + MsgRenderer mr <- getMsgRenderer + let archiveName = flip addExtension (unpack extensionZip) . unpack . mr $ MsgSheetArchiveName tid ssh csh shn let sftArchive = CSheetR tid ssh csh shn . SZipR -- used to check access to SheetFileTypes - allowedSFTs <- filterM (hasReadAccessTo . sftArchive) [minBound..maxBound] - serveZipArchive archiveName $ sheetFilesSFTsQuery tid ssh csh shn allowedSFTs .| C.map entityVal + allowedSFTs <- filterM (hasReadAccessTo . sftArchive) universeF + multipleSFTs <- if + | length allowedSFTs < 2 -> return False + | otherwise -> runDB . E.selectExists . E.from $ \(sheet `E.InnerJoin` (sFile1 `E.InnerJoin` sFile2)) -> do + E.on $ sFile1 E.^. SheetFileType E.!=. sFile2 E.^. SheetFileType + E.&&. sFile1 E.^. SheetFileTitle E.==. sFile2 E.^. SheetFileTitle + E.on $ sheet E.^. SheetId E.==. sFile1 E.^. SheetFileSheet + E.&&. sheet E.^. SheetId E.==. sFile2 E.^. SheetFileSheet + E.where_ $ sheet E.^. SheetId E.==. E.val shId + E.&&. sFile1 E.^. SheetFileType `E.in_` E.valList allowedSFTs + E.&&. sFile2 E.^. SheetFileType `E.in_` E.valList allowedSFTs + let modifyTitles SheetFile{..} + | not multipleSFTs = SheetFile{..} + | otherwise = SheetFile + { sheetFileTitle = unpack (mr $ SheetArchiveFileTypeDirectory sheetFileType) sheetFileTitle + , .. + } + sftDirectories <- if + | not multipleSFTs -> return mempty + | otherwise -> runDB . fmap (mapMaybe $ \(sft, mTime) -> (sft, ) <$> mTime) . forM allowedSFTs $ \sft -> fmap ((sft, ) . (=<<) E.unValue) . E.selectMaybe . E.from $ \sFile -> do + E.where_ $ sFile E.^. SheetFileSheet E.==. E.val shId + E.&&. sFile E.^. SheetFileType E.==. E.val sft + return . E.max_ $ sFile E.^. SheetFileModified + + serveZipArchive archiveName $ do + forM_ sftDirectories $ \(sft, mTime) -> yield $ SheetFile + { sheetFileType = sft + , sheetFileTitle = unpack . mr $ SheetArchiveFileTypeDirectory sft + , sheetFileModified = mTime + , sheetFileContent = Nothing + , sheetFileSheet = shId + } + sheetFilesSFTsQuery tid ssh csh shn allowedSFTs .| C.map entityVal .| C.map modifyTitles getSPseudonymR, postSPseudonymR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent @@ -562,12 +593,12 @@ getSEditR tid ssh csh shn = do , sfActiveFrom = sheetActiveFrom , sfActiveTo = sheetActiveTo , sfSubmissionMode = sheetSubmissionMode - , sfSheetF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetExercise + , sfSheetF = Just . yieldMany . Set.elems $ sheetFileIds SheetExercise , sfHintFrom = sheetHintFrom - , sfHintF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetHint + , sfHintF = Just . yieldMany . Set.elems $ sheetFileIds SheetHint , sfSolutionFrom = sheetSolutionFrom - , sfSolutionF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetSolution - , sfMarkingF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetMarking + , sfSolutionF = Just . yieldMany . Set.elems $ sheetFileIds SheetSolution + , sfMarkingF = Just . yieldMany . Set.elems $ sheetFileIds SheetMarking , sfMarkingText = sheetMarkingText , sfAutoDistribute = sheetAutoDistribute , sfAnonymousCorrection = sheetAnonymousCorrection @@ -674,22 +705,22 @@ postSDelR tid ssh csh shn = do } -insertSheetFile' :: SheetId -> SheetFileType -> ConduitT () (Either FileId File) Handler () -> YesodJobDB UniWorX () +insertSheetFile' :: SheetId -> SheetFileType -> FileUploads -> YesodJobDB UniWorX () insertSheetFile' sid ftype fs = do - oldFileIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do - E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile + oldFiles <- fmap (Map.fromList . map $(E.unValueN 2)) . E.select . E.from $ \sheetFile -> do E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid - E.&&. sheetFile E.^. SheetFileType E.==. E.val ftype - return (file E.^. FileId) - keep <- execWriterT . runConduit $ transPipe liftHandler fs .| C.mapM_ finsert - mapM_ deleteCascade $ (oldFileIds \\ keep :: Set FileId) + E.&&. sheetFile E.^. SheetFileType E.==. E.val ftype + return (sheetFile E.^. SheetFileTitle, sheetFile E.^. SheetFileId) + keep <- execWriterT . runConduit $ transPipe liftHandler fs .| C.mapM_ (finsert oldFiles) + deleteWhere [ SheetFileSheet ==. sid, SheetFileType ==. ftype, SheetFileId <-. Set.toList (setOf folded oldFiles \\ keep) ] where - finsert (Left fid) = do - lift . void $ upsertBy (UniqueSheetFile fid sid ftype) (SheetFile sid fid ftype) [] - tell $ singleton fid - finsert (Right file) = lift $ do - fid <- insert file - void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step + finsert oldFiles fRef + | Just sfId <- fileReferenceTitle fRef `Map.lookup` oldFiles + = tell $ Set.singleton sfId + | otherwise + = do + sfId <- lift . insert $ _FileReference # (fRef, SheetFileResidual sid ftype) + tell $ Set.singleton sfId defaultLoads :: CourseId -> DB Loads diff --git a/src/Handler/Submission/Correction.hs b/src/Handler/Submission/Correction.hs index 86c174b73..1130e9a0e 100644 --- a/src/Handler/Submission/Correction.hs +++ b/src/Handler/Submission/Correction.hs @@ -17,8 +17,6 @@ import qualified Control.Monad.State.Class as State import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E -import qualified Data.Conduit.List as C - correctionData :: TermId -> SchoolId -> CourseShorthand -> SheetName -> _ -- CryptoFileNameSubmission -> _ correctionData tid ssh csh shn sub = E.select . E.from $ \((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> do @@ -30,13 +28,11 @@ correctionData tid ssh csh shn sub = E.select . E.from $ \((course `E.InnerJoin` E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. sheet E.^. SheetName E.==. E.val shn E.&&. submission E.^. SubmissionId E.==. E.val sub - let filesCorrected = E.exists . E.from $ \((f1 `E.InnerJoin` sFile1) `E.LeftOuterJoin` (f2 `E.InnerJoin` sFile2)) -> do - E.on $ f2 E.?. FileId E.==. sFile2 E.?. SubmissionFileFile - E.on $ E.just (f1 E.^. FileTitle) E.==. f2 E.?. FileTitle + let filesCorrected = E.exists . E.from $ \(sFile1 `E.LeftOuterJoin` sFile2) -> do + E.on $ E.just (sFile1 E.^. SubmissionFileTitle) E.==. sFile2 E.?. SubmissionFileTitle E.&&. E.just (sFile1 E.^. SubmissionFileSubmission) E.==. sFile2 E.?. SubmissionFileSubmission - -- E.&&. f1 E.^. FileContent E.!=. E.joinV (f2 E.?. FileContent) + E.&&. sFile1 E.^. SubmissionFileContent E.!=. E.joinV (sFile2 E.?. SubmissionFileContent) E.&&. sFile1 E.^. SubmissionFileIsUpdate E.&&. E.maybe E.false E.not_ (sFile2 E.?. SubmissionFileIsUpdate) - E.on $ f1 E.^. FileId E.==. sFile1 E.^. SubmissionFileFile E.where_ $ sFile1 E.^. SubmissionFileSubmission E.==. submission E.^. SubmissionId E.&&. sFile2 E.?. SubmissionFileSubmission E.==. E.just (submission E.^. SubmissionId) return (course, sheet, submission, corrector, filesCorrected) @@ -133,7 +129,7 @@ postCorrectionR tid ssh csh shn cid = do formResult uploadResult $ \fileUploads -> do uid <- maybeAuthId - res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| C.mapM (either get404 return) .| extractRatingsMsg .| sinkSubmission uid (Right sub) True + res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True when (is _Just res) $ do addMessageI Success MsgRatingFilesUpdated diff --git a/src/Handler/Submission/Download.hs b/src/Handler/Submission/Download.hs index b15f732a9..99f2f4457 100644 --- a/src/Handler/Submission/Download.hs +++ b/src/Handler/Submission/Download.hs @@ -37,14 +37,13 @@ getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) pat maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file | otherwise -> notFound False -> do - let results = (.| Conduit.map entityVal) . E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> do - E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile) + let results = (.| Conduit.map entityVal) . E.selectSource . E.from $ \sf -> do E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID - E.&&. f E.^. FileTitle E.==. E.val path + E.&&. sf E.^. SubmissionFileTitle E.==. E.val path E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion) E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate -- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204 - return f + return sf serveOneFile results @@ -61,17 +60,16 @@ getSubArchiveR tid ssh csh shn cID sfType = do rating <- lift $ getRating submissionID case sfType of - SubmissionOriginal -> (.| Conduit.map entityVal) . E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> do - E.on $ f E.^. FileId E.==. sf E.^. SubmissionFileFile + SubmissionOriginal -> (.| Conduit.map (Left . entityVal)) . E.selectSource . E.from $ \sf -> do E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val False - return f - _ -> submissionFileSource submissionID .| Conduit.map entityVal + return sf + _other -> E.selectSource (E.from $ submissionFileQuery submissionID) .| Conduit.map (Left . entityVal) when (sfType == SubmissionCorrected) $ - maybe (return ()) (yieldM . ratingFile cID) rating + maybe (return ()) (yieldM . fmap Right . ratingFile cID) rating - serveSomeFiles archiveName source + serveSomeFiles' archiveName source getCorrectionsDownloadR :: Handler TypedContent diff --git a/src/Handler/Submission/Helper.hs b/src/Handler/Submission/Helper.hs index ca0ddbf7d..dc1b0141f 100644 --- a/src/Handler/Submission/Helper.hs +++ b/src/Handler/Submission/Helper.hs @@ -18,8 +18,6 @@ import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Internal.Sql as E (unsafeSqlFunction) -import qualified Data.Conduit.Combinators as Conduit - import qualified Data.Set as Set import Data.Map ((!), (!?)) import qualified Data.Map as Map @@ -396,7 +394,7 @@ submissionHelper tid ssh csh shn mcid = do (Nothing, Just smid) -- no new files, existing submission partners updated -> return smid (Just files, _) -> -- new files - runConduit $ transPipe (lift . lift) files .| Conduit.mapM (either get404 return) .| extractRatingsMsg .| sinkSubmission muid (maybe (Left shid) Right msmid) False + runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkSubmission muid (maybe (Left shid) Right msmid) False (Nothing, Nothing) -- new submission, no file upload requested -> do sid <- insert Submission @@ -482,58 +480,53 @@ submissionHelper tid ssh csh shn mcid = do -- Maybe construct a table to display uploaded archive files let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (HandlerFor UniWorX) ()) colonnadeFiles cid = mconcat $ catMaybes - [ Just . sortable (Just "path") (i18nCell MsgFileTitle) $ \(coalesce -> (mOrig, mCorr)) -> let - Just fileTitle' = fileTitle . entityVal . snd <$> (mOrig <|> mCorr) - origIsFile = fmap (isJust . fileContent . entityVal . snd) mOrig - corrIsFile = fmap (isJust . fileContent . entityVal . snd) mCorr + [ Just . sortable (Just "path") (i18nCell MsgFileTitle) $ \(mOrig, mCorr) -> let + Just fileTitle' = submissionFileTitle . entityVal <$> (mOrig <|> mCorr) + origIsFile = fmap (isJust . submissionFileContent . entityVal) mOrig + corrIsFile = fmap (isJust . submissionFileContent . entityVal) mCorr Just isFile = origIsFile <|> corrIsFile in if | Just True <- origIsFile -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionOriginal fileTitle') [whamlet|#{fileTitle'}|] | otherwise -> textCell $ bool (<> "/") id isFile fileTitle' - , guardOn showCorrection . sortable (toNothing "state") (i18nCell MsgCorState) $ \(coalesce -> (_, mCorr)) -> case mCorr of + , guardOn showCorrection . sortable (toNothing "state") (i18nCell MsgCorState) $ \(_, mCorr) -> case mCorr of Nothing -> cell mempty - Just (_, Entity _ File{..}) - | isJust fileContent -> - anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionCorrected fileTitle) - [whamlet|_{MsgFileCorrected}|] + Just (Entity _ SubmissionFile{..}) + | isJust submissionFileContent -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionCorrected submissionFileTitle) + [whamlet|_{MsgFileCorrected}|] | otherwise -> i18nCell MsgCorrected - , Just . sortable (Just "time") (i18nCell MsgFileModified) $ \(coalesce -> (mOrig, mCorr)) -> let - origTime = fileModified . entityVal . snd <$> mOrig - corrTime = fileModified . entityVal . snd <$> mCorr + , Just . sortable (Just "time") (i18nCell MsgFileModified) $ \(mOrig, mCorr) -> let + origTime = submissionFileModified . entityVal <$> mOrig + corrTime = submissionFileModified . entityVal <$> mCorr Just fileTime = (max <$> origTime <*> corrTime) <|> origTime <|> corrTime in dateTimeCell fileTime ] - coalesce :: ((Maybe (Entity SubmissionFile), Maybe (Entity File)), (Maybe (Entity SubmissionFile), Maybe (Entity File))) -> (Maybe (Entity SubmissionFile, Entity File), Maybe (Entity SubmissionFile, Entity File)) - coalesce ((ma, mb), (mc, md)) = ((,) <$> ma <*> mb, (,) <$> mc <*> md) submissionFiles :: _ -> _ -> E.SqlQuery _ - submissionFiles smid ((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) = do - E.on $ f2 E.?. FileId E.==. sf2 E.?. SubmissionFileFile - E.on $ f1 E.?. FileTitle E.==. f2 E.?. FileTitle + submissionFiles smid (sf1 `E.FullOuterJoin` sf2) = do + E.on $ sf1 E.?. SubmissionFileTitle E.==. sf2 E.?. SubmissionFileTitle E.&&. sf1 E.?. SubmissionFileSubmission E.==. sf2 E.?. SubmissionFileSubmission E.&&. sf1 E.?. SubmissionFileId E.!=. sf2 E.?. SubmissionFileId E.&&. sf2 E.?. SubmissionFileIsDeletion E.==. E.val (Just False) - E.on $ f1 E.?. FileId E.==. sf1 E.?. SubmissionFileFile E.where_ $ (sf1 E.?. SubmissionFileIsUpdate E.==. E.val (Just False) E.||. E.isNothing (sf1 E.?. SubmissionFileIsUpdate)) E.&&. (sf2 E.?. SubmissionFileIsUpdate E.==. E.val (Just True) E.||. E.isNothing (sf2 E.?. SubmissionFileIsUpdate)) E.&&. (sf2 E.?. SubmissionFileIsDeletion E.==. E.val (Just False) E.||. E.isNothing (sf2 E.?. SubmissionFileIsDeletion)) E.&&. (sf1 E.?. SubmissionFileSubmission E.==. E.val (Just smid) E.||. sf2 E.?. SubmissionFileSubmission E.==. E.val (Just smid)) - return ((sf1, f1), (sf2, f2)) + return (sf1, sf2) smid2ArchiveTable (smid,cid) = DBTable { dbtSQLQuery = submissionFiles smid - , dbtRowKey = \((_ `E.InnerJoin` f1) `E.FullOuterJoin` (_ `E.InnerJoin` f2)) -> (f1 E.?. FileId, f2 E.?. FileId) + , dbtRowKey = \(sf1 `E.FullOuterJoin` sf2) -> (sf1 E.?. SubmissionFileId, sf2 E.?. SubmissionFileId) , dbtColonnade = colonnadeFiles cid , dbtProj = return . dbrOutput , dbtStyle = def , dbtIdent = "files" :: Text , dbtSorting = Map.fromList [ ( "path" - , SortColumn $ \((_sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (_sf2 `E.InnerJoin` f2)) -> E.coalesce [f1 E.?. FileTitle, f2 E.?. FileTitle] + , SortColumn $ \(sf1 `E.FullOuterJoin` sf2) -> E.coalesce [sf1 E.?. SubmissionFileTitle, sf2 E.?. SubmissionFileTitle] ) , ( "time" - , SortColumn $ \((_sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (_sf2 `E.InnerJoin` f2)) -> (E.unsafeSqlFunction "GREATEST" ([f1 E.?. FileModified, f2 E.?. FileModified] :: [E.SqlExpr (E.Value (Maybe UTCTime))]) :: E.SqlExpr (E.Value (Maybe UTCTime))) + , SortColumn $ \(sf1 `E.FullOuterJoin` sf2) -> (E.unsafeSqlFunction "GREATEST" ([sf1 E.?. SubmissionFileModified, sf2 E.?. SubmissionFileModified] :: [E.SqlExpr (E.Value (Maybe UTCTime))]) :: E.SqlExpr (E.Value (Maybe UTCTime))) ) ] , dbtFilter = mempty @@ -545,13 +538,11 @@ submissionHelper tid ssh csh shn mcid = do mFileTable <- traverse (runDB . dbTableWidget' def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid - filesCorrected <- fmap (fromMaybe False) . for msmid $ \subId -> runDB . E.selectExists . E.from $ \((f1 `E.InnerJoin` sFile1) `E.LeftOuterJoin` (f2 `E.InnerJoin` sFile2)) -> do - E.on $ f2 E.?. FileId E.==. sFile2 E.?. SubmissionFileFile - E.on $ E.just (f1 E.^. FileTitle) E.==. f2 E.?. FileTitle + filesCorrected <- fmap (fromMaybe False) . for msmid $ \subId -> runDB . E.selectExists . E.from $ \(sFile1 `E.LeftOuterJoin` sFile2) -> do + E.on $ E.just (sFile1 E.^. SubmissionFileTitle) E.==. sFile2 E.?. SubmissionFileTitle E.&&. E.just (sFile1 E.^. SubmissionFileSubmission) E.==. sFile2 E.?. SubmissionFileSubmission - -- E.&&. f1 E.^. FileContent E.!=. E.joinV (f2 E.?. FileContent) + E.&&. sFile1 E.^. SubmissionFileContent E.!=. E.joinV (sFile2 E.?. SubmissionFileContent) E.&&. sFile1 E.^. SubmissionFileIsUpdate E.&&. E.maybe E.false E.not_ (sFile2 E.?. SubmissionFileIsUpdate) - E.on $ f1 E.^. FileId E.==. sFile1 E.^. SubmissionFileFile E.where_ $ sFile1 E.^. SubmissionFileSubmission E.==. E.val subId E.where_ $ sFile2 E.?. SubmissionFileSubmission E.==. E.just (E.val subId) diff --git a/src/Handler/Submission/Upload.hs b/src/Handler/Submission/Upload.hs index baddb6d17..026677686 100644 --- a/src/Handler/Submission/Upload.hs +++ b/src/Handler/Submission/Upload.hs @@ -54,7 +54,6 @@ postCorrectionsUploadR = do uid <- requireAuthId mbSubs <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) files - .| C.mapM (either get404 return) .| extractRatingsMsg .| C.map setDone .| sinkMultiSubmission uid True diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 6340ce78a..15de58bf3 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -430,9 +430,7 @@ deleteUser duid = do singleSubmissions <- selectSubmissionsWhere (\numBuddies -> numBuddies E.==. E.val (0::Int64)) deleteCascade duid forM_ singleSubmissions $ \(E.Value submissionId) -> do - deleteFileIds <- map E.unValue <$> getSubmissionFiles submissionId deleteCascade submissionId - deleteCascadeWhere [FileId <-. deleteFileIds] -- TODO: throws exception for de-duplicated files deletedSubmissionGroups <- deleteSingleSubmissionGroups return ((length singleSubmissions, length groupSubmissions),deletedSubmissionGroups) @@ -447,13 +445,6 @@ deleteUser duid = do E.&&. whereBuddies numBuddies return $ submission E.^. SubmissionId - getSubmissionFiles :: SubmissionId -> DB [E.Value (Key File)] - getSubmissionFiles subId = E.select $ E.from $ \file -> do - E.where_ $ E.exists $ E.from $ \submissionFile -> - E.where_ $ submissionFile E.^. SubmissionFileSubmission E.==. E.val subId - E.&&. submissionFile E.^. SubmissionFileFile E.==. file E.^. FileId - return $ file E.^. FileId - deleteSingleSubmissionGroups = E.deleteCount $ E.from $ \submissionGroup -> do E.where_ $ E.exists $ E.from $ \subGroupUser -> E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index bff604838..de308ce3d 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -9,6 +9,7 @@ import Data.Map ((!)) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Conduit.List as Conduit +import qualified Data.Conduit.Combinators as C import Handler.Utils.DateTime as Handler.Utils import Handler.Utils.Form as Handler.Utils @@ -25,6 +26,7 @@ import Handler.Utils.Widgets as Handler.Utils import Handler.Utils.Database as Handler.Utils import Handler.Utils.Occurrences as Handler.Utils import Handler.Utils.Memcached as Handler.Utils +import Handler.Utils.Files as Handler.Utils import Handler.Utils.Term as Handler.Utils @@ -36,44 +38,47 @@ sendThisFile :: File -> Handler TypedContent sendThisFile File{..} | Just fileContent' <- fileContent = do setContentDisposition' . Just $ takeFileName fileTitle - return $ TypedContent (mimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent') + return $ TypedContent (simpleContentType (mimeLookup $ pack fileTitle) <> "; charset=utf-8") (toContent fileContent') | otherwise = sendResponseStatus noContent204 () -- | Serve a single file, identified through a given DB query -serveOneFile :: ConduitT () File (YesodDB UniWorX) () -> Handler TypedContent +serveOneFile :: forall file. HasFileReference file => ConduitT () file (YesodDB UniWorX) () -> Handler TypedContent serveOneFile source = do results <- runDB . runConduit $ source .| Conduit.take 2 -- We don't need more than two files to make a decision below case results of - [file] -> sendThisFile file + [file] -> sendThisFile =<< runDB (sourceFile' file) [] -> notFound - other -> do - $logErrorS "SFileR" $ "Multiple matching files: " <> tshow other + _other -> do + $logErrorS "SFileR" "Multiple matching files found." error "Multiple matching files found." -- | Serve one file directly or a zip-archive of files, identified through a given DB query -- -- Like `serveOneFile`, but sends a zip-archive if multiple results are returned -serveSomeFiles :: FilePath -> ConduitT () File (YesodDB UniWorX) () -> Handler TypedContent -serveSomeFiles archiveName source = do +serveSomeFiles :: forall file. HasFileReference file => FilePath -> ConduitT () file (YesodDB UniWorX) () -> Handler TypedContent +serveSomeFiles archiveName source = serveSomeFiles' archiveName $ source .| C.map Left + +serveSomeFiles' :: forall file. HasFileReference file => FilePath -> ConduitT () (Either file File) (YesodDB UniWorX) () -> Handler TypedContent +serveSomeFiles' archiveName source = do results <- runDB . runConduit $ source .| peekN 2 $logDebugS "serveSomeFiles" . tshow $ length results case results of [] -> notFound - [file] -> sendThisFile file + [file] -> sendThisFile =<< either (runDB . sourceFile') return file _moreFiles -> do setContentDisposition' $ Just archiveName respondSourceDB typeZip $ do let zipComment = T.encodeUtf8 $ pack archiveName - source .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder + source .| eitherC sourceFiles' (C.map id) .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder -- | Serve any number of files as a zip-archive of files, identified through a given DB query -- -- Like `serveSomeFiles`, but always sends a zip-archive, even if a single file is returned -serveZipArchive :: FilePath -> ConduitT () File (YesodDB UniWorX) () -> Handler TypedContent +serveZipArchive :: forall file. HasFileReference file => FilePath -> ConduitT () file (YesodDB UniWorX) () -> Handler TypedContent serveZipArchive archiveName source = do - results <- runDB . runConduit $ source .| peekN 2 + results <- runDB . runConduit $ source .| peekN 1 $logDebugS "serveZipArchive" . tshow $ length results @@ -83,7 +88,7 @@ serveZipArchive archiveName source = do setContentDisposition' $ Just archiveName respondSourceDB typeZip $ do let zipComment = T.encodeUtf8 $ pack archiveName - source .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder + source .| sourceFiles' .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder -- | Prefix a message with a short course id, diff --git a/src/Handler/Utils/Allocation.hs b/src/Handler/Utils/Allocation.hs index 33590a8ac..27e3c3d81 100644 --- a/src/Handler/Utils/Allocation.hs +++ b/src/Handler/Utils/Allocation.hs @@ -278,6 +278,7 @@ storeAllocationResult :: AllocationId -> (AllocationFingerprint, Set (UserId, CourseId), Seq MatchingLogRun) -> DB () storeAllocationResult allocId now (allocFp, allocMatchings, ppMatchingLog -> allocLog) = do - insert_ . AllocationMatching allocId allocFp now <=< insert $ File "matchings.log" (Just $ encodeUtf8 allocLog) now + FileReference{..} <- sinkFile $ File "matchings.log" (Just $ encodeUtf8 allocLog) now + insert_ . AllocationMatching allocId allocFp now $ fromMaybe (error "allocation result stored without fileReferenceContent") fileReferenceContent doAllocation allocId now allocMatchings diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs index 4b2d9dcf4..128b94b3b 100644 --- a/src/Handler/Utils/Csv.hs +++ b/src/Handler/Utils/Csv.hs @@ -215,7 +215,7 @@ fileSourceCsv :: ( FromNamedRecord csv , MonadHandler m , HandlerSite m ~ UniWorX ) - => ConduitT (Either FileId File) csv m () + => ConduitT FileReference csv m () fileSourceCsv = uploadContents .| decodeCsv fileSourceCsvPositional :: ( MonadHandler m @@ -224,7 +224,7 @@ fileSourceCsvPositional :: ( MonadHandler m , FromRecord csv ) => HasHeader - -> ConduitT (Either FileId File) csv m () + -> ConduitT FileReference csv m () fileSourceCsvPositional hdr = uploadContents .| decodeCsvPositional hdr diff --git a/src/Handler/Utils/Files.hs b/src/Handler/Utils/Files.hs new file mode 100644 index 000000000..4b7950659 --- /dev/null +++ b/src/Handler/Utils/Files.hs @@ -0,0 +1,45 @@ +module Handler.Utils.Files + ( sourceFile, sourceFile' + , sourceFiles, sourceFiles' + , SourceFilesException(..) + ) where + +import Import + +import qualified Data.Conduit.Combinators as C + + +data SourceFilesException + = SourceFilesMismatchedHashes + | SourceFilesContentUnavailable + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (Exception) + + +sourceFiles :: ConduitT FileReference File (YesodDB UniWorX) () +sourceFiles = C.mapM sourceFile + +sourceFile :: FileReference -> DB File +sourceFile FileReference{..} = do + mFileContent <- traverse get $ FileContentKey <$> fileReferenceContent + fileContent <- if + | is (_Just . _Nothing) mFileContent + -> throwM SourceFilesContentUnavailable + | fmap (fmap fileContentHash) mFileContent /= fmap Just fileReferenceContent + -> throwM SourceFilesMismatchedHashes + | Just fileContent' <- fileContentContent <$> join mFileContent + -> return $ Just fileContent' + | otherwise + -> return Nothing + + return File + { fileTitle = fileReferenceTitle + , fileContent + , fileModified = fileReferenceModified + } + +sourceFiles' :: forall file. HasFileReference file => ConduitT file File (YesodDB UniWorX) () +sourceFiles' = C.mapM sourceFile' + +sourceFile' :: forall file. HasFileReference file => file -> DB File +sourceFile' = sourceFile . view (_FileReference . _1) diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 842c3b4a5..c9d238e1f 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -7,6 +7,7 @@ module Handler.Utils.Form ) where import Utils.Form +import Utils.Files import Handler.Utils.Form.Types @@ -18,6 +19,8 @@ import Handler.Utils.Widgets import Handler.Utils.I18n +import Handler.Utils.Files + import Import import Data.Char (chr, ord) import qualified Data.Char as Char @@ -31,7 +34,7 @@ import Yesod.Form.Bootstrap3 import Handler.Utils.Zip import qualified Data.Conduit.Combinators as C -import qualified Data.Conduit.List as C (mapMaybe, mapMaybeM) +import qualified Data.Conduit.List as C (mapMaybe) import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E @@ -61,8 +64,6 @@ import Handler.Utils.Form.MassInput import qualified Data.Binary as Binary import qualified Data.ByteString.Base64.URL as Base64 -import Data.Time.Clock.System (systemEpochDay) - ---------------------------- -- Buttons (new version ) -- @@ -831,11 +832,10 @@ pseudonymWordField = checkMMap doCheck id $ ciField & addDatalist (return $ mkOp = return . Left $ MsgUnknownPseudonymWord (CI.original w) -type FileUploads = ConduitT () (Either FileId File) Handler () +type FileUploads = ConduitT () FileReference Handler () -uploadContents :: (MonadHandler m, HandlerSite m ~ UniWorX) => ConduitT (Either FileId File) ByteString m () -uploadContents = C.mapMaybeM $ either dbContents (return . fileContent) - where dbContents = fmap (fileContent =<<) . liftHandler . runDB . get +uploadContents :: (MonadHandler m, HandlerSite m ~ UniWorX) => ConduitT FileReference ByteString m () +uploadContents = transPipe (liftHandler . runDB) sourceFiles .| C.mapMaybe fileContent data FileFieldUserOption a = FileFieldUserOption { fieldOptionForce :: Bool @@ -847,9 +847,9 @@ data FileField = FileField , fieldUnpackZips :: FileFieldUserOption Bool , fieldMultiple :: Bool , fieldRestrictExtensions :: Maybe (NonNull (Set Extension)) - , fieldAdditionalFiles :: Map FileId (FileFieldUserOption Bool) - , fieldMaxFileSize :: Maybe Natural -- ^ Applied to each file separately - } deriving (Eq, Ord, Read, Show, Generic, Typeable) + , fieldAdditionalFiles :: Map FilePath (Maybe FileContentReference, UTCTime, FileFieldUserOption Bool) + , fieldMaxFileSize :: Maybe Natural + } deriving (Generic, Typeable) genericFileField :: forall m. ( MonadHandler m @@ -860,6 +860,8 @@ genericFileField mkOpts = Field{..} where permittedExtension :: FileField -> FileName -> Bool permittedExtension FileField{..} fTitle + | unpack fTitle `Map.member` fieldAdditionalFiles + = True | Just exts <- fieldRestrictExtensions = anyOf (re _nullable . folded . unpacked) ((flip isExtensionOf `on` CI.foldCase) $ unpack fTitle) exts | otherwise @@ -880,38 +882,37 @@ genericFileField mkOpts = Field{..} $logDebugS "genericFileField.getIdent" $ tshow ident return ident - getPermittedFiles :: Maybe Text -> FileField -> DB (Map FileId (FileFieldUserOption Bool)) + getPermittedFiles :: Maybe Text -> FileField -> DB (Map FilePath (Maybe FileContentReference, UTCTime, FileFieldUserOption Bool)) getPermittedFiles mIdent opts@FileField{..} = do - sessionFiles <- fmap fold . for mIdent $ \fieldIdent' -> - fold . (HashMap.lookup fieldIdent' . unMergeHashMap =<<) <$> lookupSessionJson @_ @(MergeHashMap Text (Set SessionFileId)) @_ SessionFiles - sessionFiles' <- flip foldMapM sessionFiles $ \sfId -> maybeT (return Map.empty) $ do + sessionFiles <- for mIdent $ \fieldIdent' -> + foldMap (HashMap.findWithDefault mempty fieldIdent' . unMergeHashMap) <$> lookupSessionJson @_ @(MergeHashMap Text (Map FilePath (SessionFileId, UTCTime))) @_ SessionFiles + sessionFiles' <- flip foldMapM sessionFiles $ \sFiles -> flip foldMapM (Map.toList sFiles) $ \(fTitle, (sfId, fModified)) -> maybeT (return Map.empty) $ do SessionFile{..} <- MaybeT $ get sfId - when (is _Just fieldRestrictExtensions) $ do - (fTitle, isDirectory) <- MaybeT . fmap (getFirst . foldMap (First . Just . $(E.unValueN 2))) . E.select . E.from $ \file -> do - E.where_ $ file E.^. FileId E.==. E.val sessionFileFile - return $ (file E.^. FileTitle, E.isNothing $ file E.^. FileContent) - guard $ isDirectory || permittedExtension opts (pack fTitle) - return . Map.singleton sessionFileFile $ FileFieldUserOption False True + guard $ is _Nothing sessionFileContent || permittedExtension opts (pack fTitle) + return $ Map.singleton fTitle (sessionFileContent, fModified, FileFieldUserOption False True) $logDebugS "genericFileField.getPermittedFiles" $ "Additional: " <> tshow fieldAdditionalFiles $logDebugS "genericFileField.getPermittedFiles" $ "Session: " <> tshow sessionFiles' - return $ fieldAdditionalFiles <> sessionFiles' + return $ mconcat + [ Map.filter (views _3 $ (||) <$> not . fieldOptionForce <*> not . fieldOptionDefault) fieldAdditionalFiles + , sessionFiles' + , Map.filter (views _3 $ (&&) <$> fieldOptionForce <*> fieldOptionDefault) fieldAdditionalFiles + ] - handleUpload :: FileField -> Maybe Text -> File -> DB (Maybe FileId) - handleUpload FileField{fieldMaxFileSize} mIdent file - | maybe (const False) (<) fieldMaxFileSize $ maybe 0 (fromIntegral . olength) (fileContent file) - = return Nothing -- Don't save files that are too large - | otherwise = do - for mIdent $ \ident -> do - now <- liftIO getCurrentTime - oldSFIds <- fmap (Set.fromList . map E.unValue) . E.select . E.from $ \sessionFile -> do - E.where_ $ E.subSelectForeign sessionFile SessionFileFile (E.^. FileTitle) E.==. E.val (fileTitle file) - E.&&. sessionFile E.^. SessionFileTouched E.<=. E.val now - return $ sessionFile E.^. SessionFileId - fId <- insert file - sfId <- insert $ SessionFile fId now - modifySessionJson SessionFiles $ \(fromMaybe mempty -> MergeHashMap old) -> - Just . MergeHashMap $ HashMap.insert ident (Set.insert sfId . maybe Set.empty (`Set.difference` oldSFIds) $ HashMap.lookup ident old) old - return fId + handleUpload :: FileField -> Maybe Text -> ConduitT File FileReference (YesodDB UniWorX) () + handleUpload FileField{fieldMaxFileSize} mIdent + = C.filter (\File{..} -> maybe (const True) (<) fieldMaxFileSize $ maybe 0 (fromIntegral . olength) fileContent) + .| sinkFiles + .| maybe (C.map id) mkSessionFile mIdent + where + mkSessionFile ident = C.mapM $ \fRef@FileReference{..} -> fRef <$ do + now <- liftIO getCurrentTime + sfId <- insert $ SessionFile fileReferenceContent now + modifySessionJson SessionFiles $ \(fromMaybe mempty -> MergeHashMap old) -> + Just . MergeHashMap $ HashMap.insert ident (Map.insert fileReferenceTitle (sfId, fileReferenceModified) $ HashMap.findWithDefault mempty ident old) old + + + _FileTitle :: Prism' Text FilePath + _FileTitle = prism' (("f." <>) . pack) $ fmap unpack . Text.stripPrefix "f." fieldEnctype = Multipart fieldParse :: [Text] -> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe FileUploads)) @@ -921,10 +922,6 @@ genericFileField mkOpts = Field{..} mIdent <- fmap getFirst . flip foldMapM vals $ \v -> fmap First . runMaybeT . exceptTMaybe $ encodedSecretBoxOpen v - let - decrypt' :: CryptoUUIDFile -> Handler (Maybe FileId) - decrypt' = fmap (either (\(_ :: CryptoIDError) -> Nothing) Just) . try . decrypt - let uploadedFilenames = fileName <$> bool (take 1) id fieldMultiple files let @@ -933,7 +930,7 @@ genericFileField mkOpts = Field{..} | otherwise = unpackZips `elem` vals handleFile :: FileInfo -> ConduitT () File Handler () handleFile - | doUnpack = sourceFiles + | doUnpack = receiveFiles | otherwise = yieldM . acceptFile invalidUploadExtension fName = not (permittedExtension opts fName) @@ -942,36 +939,42 @@ genericFileField mkOpts = Field{..} whenIsJust fieldMaxFileSize $ \maxSize -> forM_ files $ \fInfo -> do fLength <- runConduit $ fileSource fInfo .| C.takeE (fromIntegral $ succ maxSize) .| C.lengthE when (fLength > maxSize) $ do - liftHandler . runDB . runConduit $ - mapM_ (transPipe lift . handleFile) files - .| C.mapM_ (void . handleUpload opts mIdent) + when (is _Just mIdent) $ + liftHandler . runDB . runConduit $ + mapM_ (transPipe lift . handleFile) files + .| handleUpload opts mIdent + .| C.sinkNull throwE . SomeMessage . MsgGenericFileFieldFileTooLarge . unpack $ fileName fInfo if | invExt : _ <- filter invalidUploadExtension uploadedFilenames -> do - liftHandler . runDB . runConduit $ - mapM_ (transPipe lift . handleFile) files - .| C.mapM_ (void . handleUpload opts mIdent) + when (is _Just mIdent) $ + liftHandler . runDB . runConduit $ + mapM_ (transPipe lift . handleFile) files + .| handleUpload opts mIdent + .| C.sinkNull throwE . SomeMessage . MsgGenericFileFieldInvalidExtension $ unpack invExt | otherwise -> do let fSrc = do permittedFiles <- liftHandler . runDB $ getPermittedFiles mIdent opts - yieldMany [ Left fId - | (fId, FileFieldUserOption{..}) <- Map.toList permittedFiles + yieldMany [ FileReference{..} + | ( fileReferenceTitle + , (fileReferenceContent, fileReferenceModified, FileFieldUserOption{..}) + ) <- Map.toList permittedFiles , fieldOptionForce, fieldOptionDefault ] yieldMany vals - .| C.mapMaybe fromPathPiece - .| C.mapMaybeM (\enc -> fmap (, enc) <$> decrypt' enc) - .| C.filter (\(fId, _) -> maybe False (not . fieldOptionForce) $ Map.lookup fId permittedFiles) - .| C.filter (\(_, enc) -> fieldMultiple - || ( (bool (\n h -> [n] == h) elem fieldMultiple) enc (mapMaybe fromPathPiece vals) - && null files - ) + .| C.mapMaybe (preview _FileTitle) + .| C.mapMaybe (\fTitle -> fmap (fTitle, ) . assertM (views _3 $ not . fieldOptionForce) $ Map.lookup fTitle permittedFiles) + .| C.filter (\(fTitle, _) -> + fieldMultiple + || ( (bool (\n h -> h == pure n) elem fieldMultiple) fTitle (mapMaybe (preview _FileTitle) vals) + && null files + ) ) - .| C.map (\(fId, _) -> Left fId) - mapM_ handleFile (bool (take 1) id fieldMultiple files) .| C.map Right + .| C.map (\(fileReferenceTitle, (fileReferenceContent, fileReferenceModified, _)) -> FileReference{..}) + mapM_ handleFile (bool (take 1) id fieldMultiple files) .| transPipe runDB (handleUpload opts mIdent) (unsealConduitT -> fSrc', length -> nFiles) <- liftHandler $ fSrc $$+ peekN 2 $logDebugS "genericFileField.fieldParse" $ tshow nFiles if @@ -980,7 +983,8 @@ genericFileField mkOpts = Field{..} | not fieldMultiple -> do liftHandler . runDB . runConduit $ mapM_ (transPipe lift . handleFile) files - .| C.mapM_ (void . handleUpload opts mIdent) + .| handleUpload opts mIdent + .| sinkNull throwE $ SomeMessage MsgOnlyUploadOneFile | otherwise -> return $ Just fSrc' @@ -990,39 +994,33 @@ genericFileField mkOpts = Field{..} mIdent <- getIdent opts identSecret <- for mIdent $ encodedSecretBox SecretBoxShort - fileInfos <- liftHandler . runDB $ do - (uploads, references) <- runWriterT . for val $ \src -> do - fmap Set.fromList . sourceToList - $ transPipe (lift . lift) src - .| C.mapMaybeM (either (\fId -> Nothing <$ tell (Set.singleton fId)) $ lift . handleUpload opts mIdent) + fileInfos <- liftHandler $ do + references <- for val $ fmap (Map.fromList . map (\FileReference{..} -> (fileReferenceTitle, (fileReferenceContent, fileReferenceModified)))) . sourceToList - permittedFiles <- getPermittedFiles mIdent opts + permittedFiles <- runDB $ getPermittedFiles mIdent opts let - sentVals :: Either Text (Set FileId) - sentVals = uploads <&> Set.union (references `Set.intersection` Map.keysSet permittedFiles) + sentVals :: Either Text (Set FilePath) + sentVals = references <&> (`Set.intersection` Map.keysSet permittedFiles) . Map.keysSet let - toFUI (E.Value fuiId', E.Value fuiTitle) = do - fuiId <- encrypt fuiId' - let fuiHtmlId = [st|#{fieldId}--#{toPathPiece fuiId}|] - fuiChecked - | Right sentVals' <- sentVals - = fuiId' `Set.member` sentVals' - | Just FileFieldUserOption{..} <- Map.lookup fuiId' fieldAdditionalFiles - = fieldOptionDefault - | otherwise = False - fuiSession = fuiId' `Map.notMember` fieldAdditionalFiles - fuiForced - | Just FileFieldUserOption{..} <- Map.lookup fuiId' permittedFiles - = fieldOptionForce - | otherwise - = False - return FileUploadInfo{..} - fileInfos' <- mapM toFUI <=< E.select . E.from $ \file -> do - E.where_ $ file E.^. FileId `E.in_` E.valList (Set.toList $ fold sentVals <> Map.keysSet permittedFiles) - E.orderBy [E.asc $ file E.^. FileTitle] - return (file E.^. FileId, file E.^. FileTitle) + toFUI fuiTitle + = let fuiHtmlId = [st|#{fieldId}--#{fuiTitle}|] + fuiChecked + | Right sentVals' <- sentVals + = fuiTitle `Set.member` sentVals' + | Just (_, _, FileFieldUserOption{..}) <- Map.lookup fuiTitle fieldAdditionalFiles + = fieldOptionDefault + | otherwise = False + fuiSession = fuiTitle `Map.notMember` fieldAdditionalFiles + fuiForced + | Just (_, _, FileFieldUserOption{..}) <- Map.lookup fuiTitle permittedFiles + = fieldOptionForce + | otherwise + = False + in FileUploadInfo{..} + + fileInfos' = map toFUI . Set.toList $ fold sentVals <> Map.keysSet permittedFiles return $ sortOn (splitPath . fuiTitle) fileInfos' @@ -1063,7 +1061,7 @@ fileField = genericFileField $ return FileField } specificFileField :: UploadSpecificFile -> Field Handler FileUploads -specificFileField UploadSpecificFile{..} = convertField fixupFileTitles id . genericFileField $ return FileField +specificFileField UploadSpecificFile{..} = convertField (.| fixupFileTitles) id . genericFileField $ return FileField { fieldIdent = Nothing , fieldUnpackZips = FileFieldUserOption True False , fieldMultiple = False @@ -1072,25 +1070,7 @@ specificFileField UploadSpecificFile{..} = convertField fixupFileTitles id . gen , fieldMaxFileSize = specificFileMaxSize } where - fixupFileTitles = flip (.|) . C.mapM $ either (fmap Left . updateFileReference) (fmap Right . updateFile) - where updateFileReference fId = runDB . maybeT (return fId) $ do - oldTitle <- MaybeT . fmap (getFirst . foldMap (First . Just)) . E.select . E.from $ \file -> do - E.where_ $ file E.^. FileId E.==. E.val fId - return $ file E.^. FileTitle - if | oldTitle == E.Value (unpack specificFileName) - -> return fId - | otherwise -> lift $ do - fId' <- insert $ File (unpack specificFileName) Nothing (toMidnight systemEpochDay) {- temporary -} - E.update $ \file' -> do - let newModified = E.subSelect . E.from $ \file -> do - E.where_ $ file E.^. FileId E.==. E.val fId - return $ file E.^. FileModified - newContent = E.subSelect . E.from $ \file -> do - E.where_ $ file E.^. FileId E.==. E.val fId - return $ file E.^. FileContent - E.set file' [ FileModified E.=. E.maybe (E.val $ toMidnight systemEpochDay) id newModified, FileContent E.=. E.joinV newContent ] - return fId' - updateFile = return . set _fileTitle (unpack specificFileName) + fixupFileTitles = C.map $ set _fileReferenceTitle (unpack specificFileName) zipFileField :: Bool -- ^ Unpack zips? -> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions @@ -1126,9 +1106,9 @@ fileUploadForm isReq mkFs = \case multiFileField' :: FileUploads -- ^ Permitted files in same format as produced by `multiFileField` -> Field Handler FileUploads -multiFileField' permittedFiles = multiFileField . runConduit $ permittedFiles .| C.mapMaybe (preview _Left) .| C.foldMap Set.singleton +multiFileField' permittedFiles = multiFileField . runConduit $ permittedFiles .| C.foldMap Set.singleton -multiFileField :: Handler (Set FileId) -- ^ Set of files that may be submitted by id-reference +multiFileField :: Handler (Set FileReference) -- ^ Set of files that may be submitted by id-reference -> Field Handler FileUploads multiFileField mkPermitted = genericFileField $ mkField <$> mkPermitted where mkField permitted = FileField @@ -1136,7 +1116,10 @@ multiFileField mkPermitted = genericFileField $ mkField <$> mkPermitted , fieldUnpackZips = FileFieldUserOption False False , fieldMultiple = True , fieldRestrictExtensions = Nothing - , fieldAdditionalFiles = Map.fromSet (const $ FileFieldUserOption False True) permitted + , fieldAdditionalFiles = Map.fromList + [ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True)) + | FileReference{..} <- Set.toList permitted + ] , fieldMaxFileSize = Nothing } diff --git a/src/Handler/Utils/Form/Types.hs b/src/Handler/Utils/Form/Types.hs index 9adb7e83c..beacebf61 100644 --- a/src/Handler/Utils/Form/Types.hs +++ b/src/Handler/Utils/Form/Types.hs @@ -3,8 +3,7 @@ module Handler.Utils.Form.Types where import Import data FileUploadInfo = FileUploadInfo - { fuiId :: CryptoUUIDFile - , fuiTitle :: FilePath + { fuiTitle :: FilePath , fuiHtmlId :: Text , fuiChecked, fuiSession, fuiForced :: Bool } diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index f564ae3d4..85038a894 100644 --- a/src/Handler/Utils/Mail.hs +++ b/src/Handler/Utils/Mail.hs @@ -8,6 +8,7 @@ module Handler.Utils.Mail import Import import Handler.Utils.Pandoc +import Handler.Utils.Files import qualified Data.CaseInsensitive as CI @@ -69,15 +70,15 @@ userMailT uid mAct = do addFileDB :: ( MonadMail m , HandlerSite m ~ UniWorX - ) => FileId -> m (Maybe MailObjectId) -addFileDB fId = runMaybeT $ do - File{fileTitle = pack . takeBaseName -> fileName, fileContent = Just fileContent} <- MaybeT . liftHandler . runDB $ get fId + ) => FileReference -> m (Maybe MailObjectId) +addFileDB fRef = runMaybeT $ do + File{fileTitle = pack . takeBaseName -> fileName, fileContent = Just fileContent} <- lift . liftHandler . runDB $ sourceFile fRef lift . addPart $ do _partType .= decodeUtf8 (mimeLookup fileName) _partEncoding .= Base64 _partDisposition .= AttachmentDisposition fileName _partContent .= PartContent (LBS.fromStrict fileContent) - setMailObjectIdCrypto fId :: StateT Part (HandlerFor UniWorX) MailObjectId + setMailObjectIdPseudorandom (fileName, fileContent) :: StateT Part (HandlerFor UniWorX) MailObjectId class YesodMail site => ToMailHtml site a where diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index ec622fad0..8ba23b315 100644 --- a/src/Handler/Utils/Rating.hs +++ b/src/Handler/Utils/Rating.hs @@ -11,6 +11,7 @@ module Handler.Utils.Rating import Import +import Handler.Utils.Files import Handler.Utils.DateTime (getDateTimeFormatter) import qualified Data.Text as Text @@ -102,23 +103,23 @@ ratingFile cID rating@Rating{ ratingValues = Rating'{..}, .. } = do return File{..} where ensureExtension ext fName = bool (`addExtension` ext) id (ext `isExtensionOf` fName) fName -type SubmissionContent = Either File (SubmissionId, Rating') +type SubmissionContent = Either FileReference (SubmissionId, Rating') extractRatings :: ( MonadHandler m , HandlerSite m ~ UniWorX - - ) => ConduitT File SubmissionContent m () -extractRatings = Conduit.mapM $ \f@File{..} -> liftHandler $ do - msId <- isRatingFile fileTitle - case () of - _ | Just sId <- msId - , isJust fileContent -> do - (rating, cID) <- handle (throwM . RatingFileException fileTitle) $ parseRating f - sId' <- traverse decrypt cID - unless (maybe (const True) (==) sId' sId) $ - throwM $ RatingFileException fileTitle RatingSubmissionIDIncorrect - return $ Right (sId, rating) - | otherwise -> return $ Left f + ) => ConduitT FileReference SubmissionContent m () +extractRatings = Conduit.mapM $ \fRef@FileReference{..} -> liftHandler $ do + msId <- isRatingFile fileReferenceTitle + if + | Just sId <- msId + , isJust fileReferenceContent -> do + f <- runDB $ sourceFile fRef + (rating, cID) <- handle (throwM . RatingFileException fileReferenceTitle) $ parseRating f + sId' <- traverse decrypt cID + unless (maybe (const True) (==) sId' sId) $ + throwM $ RatingFileException fileReferenceTitle RatingSubmissionIDIncorrect + return $ Right (sId, rating) + | otherwise -> return $ Left fRef isRatingFile :: forall m. ( MonadHandler m diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index f36a1158f..7af8f3d57 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -39,6 +39,7 @@ import qualified Database.Esqueleto.Utils.TH as E import qualified Data.Conduit.List as Conduit import Data.Conduit.ResumableSink +import qualified Data.Conduit.Combinators as C import System.FilePath import System.FilePath.Glob @@ -255,21 +256,21 @@ planSubmissions sid restriction = do maximumsBy f xs = flip Set.filter xs $ \x -> maybe True (((==) `on` f) x . maximumBy (comparing f)) $ fromNullable xs -submissionFileSource :: SubmissionId -> ConduitT () (Entity File) (YesodDB UniWorX) () -submissionFileSource = E.selectSource . fmap snd . E.from . submissionFileQuery +submissionFileSource :: SubmissionId -> ConduitT () File (YesodDB UniWorX) () +submissionFileSource subId = E.selectSource (E.from $ submissionFileQuery subId) + .| C.map entityVal + .| sourceFiles' -submissionFileQuery :: SubmissionId -> E.SqlExpr (Entity SubmissionFile) `E.InnerJoin` E.SqlExpr (Entity File) - -> E.SqlQuery (E.SqlExpr (Entity SubmissionFile), E.SqlExpr (Entity File)) -submissionFileQuery submissionID (sf `E.InnerJoin` f) = E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do - E.on $ f E.^. FileId E.==. sf E.^. SubmissionFileFile +submissionFileQuery :: SubmissionId -> E.SqlExpr (Entity SubmissionFile) + -> E.SqlQuery (E.SqlExpr (Entity SubmissionFile)) +submissionFileQuery submissionID sf = E.distinctOnOrderBy [E.asc $ sf E.^. SubmissionFileTitle] $ do E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID - E.where_ . E.not_ . E.exists . E.from $ \(sf' `E.InnerJoin` f') -> do - E.on $ f' E.^. FileId E.==. sf' E.^. SubmissionFileFile + E.where_ . E.not_ . E.exists . E.from $ \sf' -> E.where_ $ sf' E.^. SubmissionFileIsDeletion E.&&. sf' E.^. SubmissionFileSubmission E.==. sf E.^. SubmissionFileSubmission - E.&&. f' E.^. FileTitle E.==. f E.^. FileTitle + E.&&. sf' E.^. SubmissionFileTitle E.==. sf E.^. SubmissionFileTitle E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] -- E.desc returns corrector updated data first - return (sf, f) + return sf data SubmissionDownloadAnonymous = SubmissionDownloadAnonymous | SubmissionDownloadSurnames @@ -366,8 +367,8 @@ submissionMultiArchive anonymous (Set.toList -> ids) = do | otherwise = submissionDirectory fileEntitySource = do - submissionFileSource submissionID .| Conduit.map entityVal - yieldM (ratingFile cID rating) + yieldM $ ratingFile cID rating + submissionFileSource submissionID withinDirectory f@File{..} = f { fileTitle = directoryName fileTitle } @@ -400,13 +401,13 @@ instance Monoid SubmissionSinkState where mempty = memptydefault mappend = (<>) -filterSubmission :: MonadLogger m => ConduitM File File m (Set FilePath) +filterSubmission :: MonadLogger m => ConduitM FileReference FileReference m (Set FilePath) -- ^ Removes all `File`s matching `submissionBlacklist`, returning their `fileTitle`s filterSubmission = do $logDebugS "filterSubmission" $ tshow submissionBlacklist execWriterLC . awaitForever $ \case - File{fileTitle} - | any (`match'` fileTitle) submissionBlacklist -> tell $ Set.singleton fileTitle + FileReference{fileReferenceTitle} + | any (`match'` fileReferenceTitle) submissionBlacklist -> tell $ Set.singleton fileReferenceTitle file -> yield file where match' = matchWith $ matchDefault @@ -415,12 +416,12 @@ filterSubmission = do extractRatings :: ( MonadHandler m , HandlerSite m ~ UniWorX - ) => ConduitM File SubmissionContent m (Set FilePath) + ) => ConduitM FileReference SubmissionContent m (Set FilePath) extractRatings = filterSubmission `fuseUpstream` Rating.extractRatings extractRatingsMsg :: ( MonadHandler m , HandlerSite m ~ UniWorX - ) => ConduitT File SubmissionContent m () + ) => ConduitT FileReference SubmissionContent m () extractRatingsMsg = do ignored' <- filterSubmission `fuseUpstream` Rating.extractRatings let ignoredFiles :: Set (Either CryptoFileNameSubmission FilePath) @@ -558,10 +559,10 @@ sinkSubmission userId mExists isUpdate = do , not isUpdate , Just (map unpack . Set.toList . toNullable -> exts) <- extensionRestriction = Conduit.mapM $ \x -> if - | Left File{..} <- x - , none ((flip isExtensionOf `on` CI.foldCase) fileTitle) exts - , isn't _Nothing fileContent -- File record is not a directory, we don't care about those - -> throwM $ InvalidFileTitleExtension fileTitle + | Left FileReference{..} <- x + , none ((flip isExtensionOf `on` CI.foldCase) fileReferenceTitle) exts + , isn't _Nothing fileReferenceContent -- File record is not a directory, we don't care about those + -> throwM $ InvalidFileTitleExtension fileReferenceTitle | otherwise -> return x | otherwise = Conduit.map id @@ -569,55 +570,57 @@ sinkSubmission userId mExists isUpdate = do sinkSubmission' :: SubmissionId -> ConduitT SubmissionContent Void (YesodJobDB UniWorX) () sinkSubmission' submissionId = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case - Left file@(File{..}) -> do - $logDebugS "sinkSubmission" . tshow $ (submissionId, fileTitle) + Left file@(FileReference{..}) -> do + $logDebugS "sinkSubmission" . tshow $ (submissionId, fileReferenceTitle) - alreadySeen <- gets (Set.member fileTitle . sinkFilenames) - when alreadySeen . throwM $ DuplicateFileTitle fileTitle - tellSt $ mempty{ sinkFilenames = Set.singleton fileTitle } + alreadySeen <- gets (Set.member fileReferenceTitle . sinkFilenames) + when alreadySeen . throwM $ DuplicateFileTitle fileReferenceTitle + tellSt $ mempty{ sinkFilenames = Set.singleton fileReferenceTitle } - otherVersions <- lift . E.select . E.from $ \(sf `E.InnerJoin` f) -> do - E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId + otherVersions <- lift . E.select . E.from $ \sf -> do E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId -- E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate - E.where_ $ f E.^. FileTitle E.==. E.val fileTitle -- 'Zip.hs' normalises filenames already, so this should work - return (f, sf) + E.where_ $ sf E.^. SubmissionFileTitle E.==. E.val fileReferenceTitle -- 'Zip.hs' normalises filenames already, so this should work + return sf - let collidingFiles = [ t | t@(_, Entity _ sf) <- otherVersions + let collidingFiles = [ t | t@(Entity _ sf) <- otherVersions , submissionFileIsUpdate sf == isUpdate ] - underlyingFiles = [ t | t@(_, Entity _ sf) <- otherVersions + underlyingFiles = [ t | t@(Entity _ sf) <- otherVersions , submissionFileIsUpdate sf == False ] anyChanges - | not (null collidingFiles) = any (/~ file) [ f | (Entity _ f, _) <- collidingFiles ] + | not (null collidingFiles) = any (/~ file) [ view (_FileReference . _1) sf | Entity _ sf <- collidingFiles ] | otherwise = True matchesUnderlying - | not (null underlyingFiles) = all (~~ file) [ f | (Entity _ f, Entity _ _sf) <- underlyingFiles ] + | not (null underlyingFiles) = all (~~ file) [ view (_FileReference . _1) sf | Entity _ sf <- underlyingFiles ] | otherwise = False - undoneDeletion = any submissionFileIsDeletion [ sf | (_, Entity _ sf) <- collidingFiles ] + undoneDeletion = any submissionFileIsDeletion [ sf | Entity _ sf <- collidingFiles ] when anyChanges $ do touchSubmission - when (not $ null collidingFiles) $ - lift $ deleteCascadeWhere [ FileId <-. [ fId | (Entity fId _, _) <- collidingFiles ] ] - lift $ case () of - _ | matchesUnderlying - , isUpdate - -> return () - _ -> do - fileId <- insert file - subFileId <- insert $ SubmissionFile - { submissionFileSubmission = submissionId - , submissionFileFile = fileId - , submissionFileIsUpdate = isUpdate - , submissionFileIsDeletion = False - } - audit $ TransactionSubmissionFileEdit subFileId submissionId fileId + forM_ collidingFiles $ \(Entity sfId' _) -> lift $ do + delete sfId' + audit $ TransactionSubmissionFileDelete sfId' submissionId + lift $ if + | matchesUnderlying + , isUpdate + -> return () + | otherwise -> do + subFileId <- insert $ + _FileReference # ( file + , SubmissionFileResidual + { submissionFileResidualSubmission = submissionId + , submissionFileResidualIsUpdate = isUpdate + , submissionFileResidualIsDeletion = False + } + ) + audit $ TransactionSubmissionFileEdit subFileId submissionId when undoneDeletion $ do touchSubmission - lift $ forM_ [ (sfId, submissionFileFile sf) | (_, Entity sfId sf) <- collidingFiles, submissionFileIsDeletion sf ] $ \(sfId, fId) -> audit $ TransactionSubmissionFileDelete sfId submissionId fId - lift $ deleteWhere [ SubmissionFileId <-. [ sfId | (_, Entity sfId sf) <- collidingFiles, submissionFileIsDeletion sf ] ] + forM_ (filter (submissionFileIsDeletion . entityVal) collidingFiles) $ \(Entity sfId' _) -> lift $ do + delete sfId' + audit $ TransactionSubmissionFileDelete sfId' submissionId Right (submissionId', r) -> do $logDebugS "sinkSubmission" $ tshow submissionId' @@ -673,9 +676,10 @@ sinkSubmission userId mExists isUpdate = do where a /~ b = not $ a ~~ b - (~~) :: File -> File -> Bool + (~~) :: FileReference -> FileReference -> Bool (~~) a b - | isUpdate = fileTitle a == fileTitle b && fileContent a == fileContent b + | isUpdate = fileReferenceTitle a == fileReferenceTitle b + && fileReferenceContent a == fileReferenceContent b | otherwise = a == b -- The Eq Instance for File compares modification time exactly even -- though zip archives have very limited accuracy and range regarding @@ -710,40 +714,46 @@ sinkSubmission userId mExists isUpdate = do finalize :: SubmissionSinkState -> YesodJobDB UniWorX () finalize SubmissionSinkState{..} = do - missingFiles <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do - E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId + missingFiles <- E.select . E.from $ \sf -> E.distinctOnOrderBy [E.asc $ sf E.^. SubmissionFileTitle] $ do E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId when (not isUpdate) $ - E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate - E.where_ $ f E.^. FileTitle `E.notIn` E.valList (Set.toList sinkFilenames) + E.where_ . E.not_ $ sf E.^. SubmissionFileIsUpdate + E.where_ $ sf E.^. SubmissionFileTitle `E.notIn` E.valList (Set.toList sinkFilenames) E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] - return (f, sf) + return sf case isUpdate of - False -> deleteCascadeWhere [ FileId <-. [ fileId | (Entity fileId _, _) <- missingFiles ] ] - True -> forM_ missingFiles $ \(Entity fileId File{..}, Entity sfId SubmissionFile{..}) -> do - shadowing <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do - E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId - E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId - E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val (not isUpdate) - E.where_ $ f E.^. FileTitle E.==. E.val fileTitle - return $ f E.^. FileId + False -> do + shadowed <- selectKeysList + [ SubmissionFileSubmission ==. submissionId + , SubmissionFileIsUpdate ==. False + , SubmissionFileId <-. map entityKey missingFiles + ] [] + forM_ shadowed $ \sfId' -> do + delete sfId' + audit $ TransactionSubmissionFileDelete sfId' submissionId + True -> forM_ missingFiles $ \(Entity sfId SubmissionFile{..}) -> do + shadowing <- existsBy $ UniqueSubmissionFile submissionFileSubmission submissionFileTitle False - case (shadowing, submissionFileIsUpdate) of - ([], _) -> deleteCascade fileId - (E.Value f:_, False) -> do - sfId' <- insert $ SubmissionFile - { submissionFileSubmission = submissionId - , submissionFileFile = f - , submissionFileIsUpdate = True - , submissionFileIsDeletion = True - } - audit $ TransactionSubmissionFileEdit sfId' submissionId f - (E.Value f:_, True) -> do - update sfId [ SubmissionFileFile =. f, SubmissionFileIsDeletion =. True ] - deleteCascade fileId - audit $ TransactionSubmissionFileDelete sfId submissionId f + if + | not shadowing -> do + delete sfId + audit $ TransactionSubmissionFileDelete sfId submissionId + | submissionFileIsUpdate -> do + update sfId [ SubmissionFileContent =. Nothing, SubmissionFileIsDeletion =. True ] + audit $ TransactionSubmissionFileEdit sfId submissionId + | otherwise -> do + now <- liftIO getCurrentTime + sfId' <- insert $ SubmissionFile + { submissionFileSubmission = submissionId + , submissionFileTitle + , submissionFileModified = now + , submissionFileContent = Nothing + , submissionFileIsUpdate = True + , submissionFileIsDeletion = True + } + audit $ TransactionSubmissionFileEdit sfId' submissionId if | isUpdate @@ -805,7 +815,7 @@ sinkMultiSubmission userId isUpdate = do cID <- encrypt sId $logDebugS "sinkMultiSubmission" $ "Feeding rating for " <> toPathPiece cID lift (feed sId v `catches` [ E.Handler (throwM . SubmissionSinkException cID Nothing), E.Handler (void . handleHCError (Left cID)) ]) - (Left f@File{..}) -> do + (Left f@FileReference{..}) -> do let acc :: (Maybe SubmissionId, [FilePath]) -> FilePath -> _ (Maybe SubmissionId, [FilePath]) acc (Just sId, fp) segment = return (Just sId, fp ++ [segment]) @@ -817,17 +827,17 @@ sinkMultiSubmission userId isUpdate = do sId <- decrypt (cID :: CryptoFileNameSubmission) Just sId <$ get404 sId | otherwise = return Nothing - Dual (Alt msId) <- lift . flip foldMapM segments' $ \seg -> Dual . Alt <$> lift (tryDecrypt seg) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileTitle) ] + Dual (Alt msId) <- lift . flip foldMapM segments' $ \seg -> Dual . Alt <$> lift (tryDecrypt seg) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileReferenceTitle) ] return (msId, fp) - (msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileTitle + (msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileReferenceTitle case msId of Nothing -> do - $logDebugS "sinkMultiSubmission" $ "Dropping " <> tshow (splitDirectories fileTitle, msId, fileTitle') + $logDebugS "sinkMultiSubmission" $ "Dropping " <> tshow (splitDirectories fileReferenceTitle, msId, fileTitle') Just sId -> do - $logDebugS "sinkMultiSubmission" $ "Feeding " <> tshow (splitDirectories fileTitle, msId, fileTitle') + $logDebugS "sinkMultiSubmission" $ "Feeding " <> tshow (splitDirectories fileReferenceTitle, msId, fileTitle') cID <- encrypt sId - lift . handle (throwM . SubmissionSinkException cID (Just fileTitle)) $ - feed sId $ Left f{ fileTitle = fileTitle' } + lift . handle (throwM . SubmissionSinkException cID (Just fileReferenceTitle)) $ + feed sId $ Left f{ fileReferenceTitle = fileTitle' } when (not $ null ignoredFiles) $ do mr <- (toHtml .) <$> getMessageRender addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr) diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 10a939e95..a586fedfd 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -417,11 +417,11 @@ colFileModificationWhen condition row2time = sortable (Just "time") (i18nCell Ms where conDTCell = ifCell condition dateTimeCell $ const mempty -sortFilePath :: IsString s => (t -> E.SqlExpr (Entity File)) -> (s, SortColumn t r') -sortFilePath queryPath = ("path", SortColumn $ queryPath >>> (E.^. FileTitle)) +sortFilePath :: (HasFileReference record, IsString s) => (t -> E.SqlExpr (Entity record)) -> (s, SortColumn t r') +sortFilePath queryPath = ("path", SortColumn $ queryPath >>> (E.^. fileReferenceTitleField)) -sortFileModification :: IsString s => (t -> E.SqlExpr (Entity File)) -> (s, SortColumn t r') -sortFileModification queryModification = ("time", SortColumn $ queryModification >>> (E.^. FileModified)) +sortFileModification :: (HasFileReference record, IsString s) => (t -> E.SqlExpr (Entity record)) -> (s, SortColumn t r') +sortFileModification queryModification = ("time", SortColumn $ queryModification >>> (E.^. fileReferenceModifiedField)) defaultSortingByFileTitle :: PSValidator m x -> PSValidator m x defaultSortingByFileTitle = defaultSorting [SortAscBy "path"] diff --git a/src/Handler/Utils/Zip.hs b/src/Handler/Utils/Zip.hs index 9ee8fbf96..0d30778c8 100644 --- a/src/Handler/Utils/Zip.hs +++ b/src/Handler/Utils/Zip.hs @@ -8,7 +8,7 @@ module Handler.Utils.Zip , produceZip , consumeZip , modifyFileTitle - , sourceFiles, acceptFile + , receiveFiles, acceptFile ) where import Import @@ -123,8 +123,8 @@ modifyFileTitle :: Monad m => (FilePath -> FilePath) -> ConduitT File File m () modifyFileTitle f = mapC $ \x@File{..} -> x{ fileTitle = f fileTitle } -- Takes FileInfo and if it is a ZIP-Archive, extract files, otherwiese yield fileinfo -sourceFiles :: (MonadLogger m, MonadResource m, MonadThrow m, MonadBase IO m) => FileInfo -> ConduitT () File m () -sourceFiles fInfo +receiveFiles :: (MonadLogger m, MonadResource m, MonadThrow m, MonadBase IO m) => FileInfo -> ConduitT () File m () +receiveFiles fInfo | ((==) `on` simpleContentType) mimeType typeZip = do $logInfoS "sourceFiles" "Unpacking ZIP" fileSource fInfo .| void consumeZip diff --git a/src/Import.hs b/src/Import.hs index b93336ae8..382be90fe 100644 --- a/src/Import.hs +++ b/src/Import.hs @@ -7,5 +7,6 @@ import Import.NoFoundation as Import import Utils.SystemMessage as Import import Utils.Metrics as Import +import Utils.Files as Import import Jobs.Types as Import (JobHandler(..)) diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 493cdbe53..784d57ee0 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -19,6 +19,7 @@ import ClassyPrelude.Yesod as Import , try, embed, catches, handle, catch, bracket, bracketOnError, bracket_, catchJust, finally, handleJust, mask, mask_, onException, tryJust, uninterruptibleMask, uninterruptibleMask_ , htmlField, fileField , mreq, areq, wreq -- Use `mreqMsg`, `areqMsg`, `wreqMsg` + , sinkFile, sourceFile ) import UnliftIO.Async.Utils as Import @@ -161,7 +162,7 @@ import Web.Cookie.Instances as Import () import Network.HTTP.Types.Method.Instances as Import () import Crypto.Random.Instances as Import () -import Crypto.Hash as Import (Digest, SHA3_256) +import Crypto.Hash as Import (Digest, SHA3_256, SHA3_512) import Crypto.Random as Import (ChaChaDRG, Seed) import Control.Lens as Import diff --git a/src/Jobs/Handler/PruneFiles.hs b/src/Jobs/Handler/PruneFiles.hs index d49b198dc..9fcb84805 100644 --- a/src/Jobs/Handler/PruneFiles.hs +++ b/src/Jobs/Handler/PruneFiles.hs @@ -21,18 +21,18 @@ dispatchJobPruneSessionFiles = JobHandlerAtomic . hoist lift $ do dispatchJobPruneUnreferencedFiles :: JobHandler UniWorX dispatchJobPruneUnreferencedFiles = JobHandlerAtomic . hoist lift $ do - n <- E.deleteCount . E.from $ \file -> - E.where_ . E.not_ . E.any E.exists $ references file + n <- E.deleteCount . E.from $ \fileContent -> + E.where_ . E.not_ . E.any E.exists $ references fileContent $logInfoS "PruneUnreferencedFiles" [st|Deleted #{n} unreferenced files|] where - references :: E.SqlExpr (Entity File) -> [E.SqlQuery ()] - references ((E.^. FileId) -> fId) = - [ E.from $ \appFile -> E.where_ $ appFile E.^. CourseApplicationFileFile E.==. fId - , E.from $ \matFile -> E.where_ $ matFile E.^. MaterialFileFile E.==. fId - , E.from $ \newsFile -> E.where_ $ newsFile E.^. CourseNewsFileFile E.==. fId - , E.from $ \sheetFile -> E.where_ $ sheetFile E.^. SheetFileFile E.==. fId - , E.from $ \appInstr -> E.where_ $ appInstr E.^. CourseAppInstructionFileFile E.==. fId - , E.from $ \matching -> E.where_ $ matching E.^. AllocationMatchingLog E.==. fId - , E.from $ \subFile -> E.where_ $ subFile E.^. SubmissionFileFile E.==. fId - , E.from $ \sessFile -> E.where_ $ sessFile E.^. SessionFileFile E.==. fId + references :: E.SqlExpr (Entity FileContent) -> [E.SqlQuery ()] + references (E.just . (E.^. FileContentHash) -> fHash) = + [ E.from $ \appFile -> E.where_ $ appFile E.^. CourseApplicationFileContent E.==. fHash + , E.from $ \matFile -> E.where_ $ matFile E.^. MaterialFileContent E.==. fHash + , E.from $ \newsFile -> E.where_ $ newsFile E.^. CourseNewsFileContent E.==. fHash + , E.from $ \sheetFile -> E.where_ $ sheetFile E.^. SheetFileContent E.==. fHash + , E.from $ \appInstr -> E.where_ $ appInstr E.^. CourseAppInstructionFileContent E.==. fHash + , E.from $ \matching -> E.where_ $ E.just (matching E.^. AllocationMatchingLog) E.==. fHash + , E.from $ \subFile -> E.where_ $ subFile E.^. SubmissionFileContent E.==. fHash + , E.from $ \sessFile -> E.where_ $ sessFile E.^. SessionFileContent E.==. fHash ] diff --git a/src/Model.hs b/src/Model.hs index 56132c831..fcd41546b 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -38,8 +38,6 @@ deriving newtype instance ToJSONKey UserId deriving newtype instance FromJSONKey UserId deriving newtype instance ToJSONKey ExamOccurrenceId deriving newtype instance FromJSONKey ExamOccurrenceId -deriving newtype instance ToJSONKey FileId -deriving newtype instance FromJSONKey FileId -- ToMarkup and ToMessage instances for displaying selected database primary keys @@ -54,3 +52,185 @@ instance ToMarkup (Key Term) where instance ToMessage (Key Term) where toMessage = termToText . unTermKey + + +instance HasFileReference CourseApplicationFile where + newtype FileReferenceResidual CourseApplicationFile + = CourseApplicationFileResidual { courseApplicationFileResidualApplication :: CourseApplicationId } + + _FileReference + = iso (\CourseApplicationFile{..} -> ( FileReference + { fileReferenceTitle = courseApplicationFileTitle + , fileReferenceContent = courseApplicationFileContent + , fileReferenceModified = courseApplicationFileModified + } + , CourseApplicationFileResidual courseApplicationFileApplication + ) + ) + (\( FileReference{..} + , CourseApplicationFileResidual courseApplicationFileApplication + ) -> CourseApplicationFile + { courseApplicationFileApplication + , courseApplicationFileTitle = fileReferenceTitle + , courseApplicationFileContent = fileReferenceContent + , courseApplicationFileModified = fileReferenceModified + } + ) + + fileReferenceTitleField = CourseApplicationFileTitle + fileReferenceContentField = CourseApplicationFileContent + fileReferenceModifiedField = CourseApplicationFileModified + +instance HasFileReference CourseAppInstructionFile where + newtype FileReferenceResidual CourseAppInstructionFile + = CourseAppInstructionFileResidual { courseAppInstructionFileResidualCourse :: CourseId } + + _FileReference + = iso (\CourseAppInstructionFile{..} -> ( FileReference + { fileReferenceTitle = courseAppInstructionFileTitle + , fileReferenceContent = courseAppInstructionFileContent + , fileReferenceModified = courseAppInstructionFileModified + } + , CourseAppInstructionFileResidual courseAppInstructionFileCourse + ) + ) + (\( FileReference{..} + , CourseAppInstructionFileResidual courseAppInstructionFileCourse + ) -> CourseAppInstructionFile + { courseAppInstructionFileCourse + , courseAppInstructionFileTitle = fileReferenceTitle + , courseAppInstructionFileContent = fileReferenceContent + , courseAppInstructionFileModified = fileReferenceModified + } + ) + + fileReferenceTitleField = CourseAppInstructionFileTitle + fileReferenceContentField = CourseAppInstructionFileContent + fileReferenceModifiedField = CourseAppInstructionFileModified + +instance HasFileReference SheetFile where + data FileReferenceResidual SheetFile = SheetFileResidual + { sheetFileResidualSheet :: SheetId + , sheetFileResidualType :: SheetFileType + } + + _FileReference + = iso (\SheetFile{..} -> ( FileReference + { fileReferenceTitle = sheetFileTitle + , fileReferenceContent = sheetFileContent + , fileReferenceModified = sheetFileModified + } + , SheetFileResidual + { sheetFileResidualSheet = sheetFileSheet + , sheetFileResidualType = sheetFileType + } + ) + ) + (\( FileReference{..} + , SheetFileResidual{..} + ) -> SheetFile + { sheetFileSheet = sheetFileResidualSheet + , sheetFileType = sheetFileResidualType + , sheetFileTitle = fileReferenceTitle + , sheetFileContent = fileReferenceContent + , sheetFileModified = fileReferenceModified + } + ) + + fileReferenceTitleField = SheetFileTitle + fileReferenceContentField = SheetFileContent + fileReferenceModifiedField = SheetFileModified + +instance HasFileReference SubmissionFile where + data FileReferenceResidual SubmissionFile = SubmissionFileResidual + { submissionFileResidualSubmission :: SubmissionId + , submissionFileResidualIsUpdate + , submissionFileResidualIsDeletion :: Bool + } + + _FileReference + = iso (\SubmissionFile{..} -> ( FileReference + { fileReferenceTitle = submissionFileTitle + , fileReferenceContent = submissionFileContent + , fileReferenceModified = submissionFileModified + } + , SubmissionFileResidual + { submissionFileResidualSubmission = submissionFileSubmission + , submissionFileResidualIsUpdate = submissionFileIsUpdate + , submissionFileResidualIsDeletion = submissionFileIsDeletion + } + ) + ) + (\( FileReference{..} + , SubmissionFileResidual{..} + ) -> SubmissionFile + { submissionFileSubmission = submissionFileResidualSubmission + , submissionFileIsUpdate = submissionFileResidualIsUpdate + , submissionFileIsDeletion = submissionFileResidualIsDeletion + , submissionFileTitle = fileReferenceTitle + , submissionFileContent = fileReferenceContent + , submissionFileModified = fileReferenceModified + } + ) + + fileReferenceTitleField = SubmissionFileTitle + fileReferenceContentField = SubmissionFileContent + fileReferenceModifiedField = SubmissionFileModified + +instance HasFileReference CourseNewsFile where + newtype FileReferenceResidual CourseNewsFile + = CourseNewsFileResidual { courseNewsFileResidualNews :: CourseNewsId } + + _FileReference + = iso (\CourseNewsFile{..} -> ( FileReference + { fileReferenceTitle = courseNewsFileTitle + , fileReferenceContent = courseNewsFileContent + , fileReferenceModified = courseNewsFileModified + } + , CourseNewsFileResidual courseNewsFileNews + ) + ) + (\( FileReference{..} + , CourseNewsFileResidual courseNewsFileNews + ) -> CourseNewsFile + { courseNewsFileNews + , courseNewsFileTitle = fileReferenceTitle + , courseNewsFileContent = fileReferenceContent + , courseNewsFileModified = fileReferenceModified + } + ) + + fileReferenceTitleField = CourseNewsFileTitle + fileReferenceContentField = CourseNewsFileContent + fileReferenceModifiedField = CourseNewsFileModified + +instance HasFileReference MaterialFile where + data FileReferenceResidual MaterialFile = MaterialFileResidual + { materialFileResidualMaterial :: MaterialId + } + + _FileReference + = iso (\MaterialFile{..} -> ( FileReference + { fileReferenceTitle = materialFileTitle + , fileReferenceContent = materialFileContent + , fileReferenceModified = materialFileModified + } + , MaterialFileResidual + { materialFileResidualMaterial = materialFileMaterial + } + ) + ) + (\( FileReference{..} + , MaterialFileResidual{..} + ) -> MaterialFile + { materialFileMaterial = materialFileResidualMaterial + , materialFileTitle = fileReferenceTitle + , materialFileContent = fileReferenceContent + , materialFileModified = fileReferenceModified + } + ) + + fileReferenceTitleField = MaterialFileTitle + fileReferenceContentField = MaterialFileContent + fileReferenceModifiedField = MaterialFileModified + diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 05671e7c9..5116b9708 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -426,7 +426,7 @@ customMigrations = Map.fromListWith (>>) |] let getFileEntries = rawQuery [st|SELECT "allocation_course_file"."id", "allocation_course"."course", "allocation_course_file"."file" FROM "allocation_course_file" INNER JOIN "allocation_course" ON "allocation_course"."id" = "allocation_course_file"."allocation_course"|] [] - moveFileEntry [fromPersistValue -> Right (acfId :: Int64), fromPersistValue -> Right (cid :: CourseId), fromPersistValue -> Right (fid :: FileId)] = + moveFileEntry [fromPersistValue -> Right (acfId :: Int64), fromPersistValue -> Right (cid :: CourseId), fromPersistValue -> Right (fid :: Int64)] = [executeQQ| INSERT INTO "course_app_instruction_file" ("course", "file") VALUES (#{cid}, #{fid}); DELETE FROM "allocation_course_file" WHERE "id" = #{acfId}; @@ -662,6 +662,191 @@ customMigrations = Map.fromListWith (>>) , whenM (tableExists "session_file") $ tableDropEmpty "session_file" ) + , ( AppliedMigrationKey [migrationVersion|37.0.0|] [version|38.0.0|] + , do + unlessM (tableExists "file_content") $ + [executeQQ| + CREATE TABLE "file_content" ( PRIMARY KEY ("hash") + , "hash" BYTEA NOT NULL + , "content" BYTEA NOT NULL + ); + |] + + let + migrateFromFile :: forall fRef. + ( HasFileReference fRef + , PersistRecordBackend fRef SqlBackend + ) + => ([PersistValue] -> (Key fRef, FileReferenceResidual fRef)) + -> (Entity fRef -> ReaderT SqlBackend m ()) + -> [PersistValue] + -> ReaderT SqlBackend m () + migrateFromFile toResidual doUpdate ((fromPersistValue -> Right (fId :: Int64)):rest) = do + let (fRefKey, residual) = toResidual rest + fileDat <- [sqlQQ| + SELECT "file".title, "file".modified FROM "file" WHERE "id" = #{fId}; + |] + insertedContent <- [sqlQQ| + INSERT INTO "file_content" (SELECT digest("content", 'sha3-512') as "hash", "content" FROM "file" WHERE id = #{fId} AND NOT ("content" IS NULL)) ON CONFLICT("hash") DO UPDATE SET "hash" = EXCLUDED."hash" RETURNING "hash"; + |] + forM_ fileDat $ \case + (fromPersistValue . unSingle -> Right (fileReferenceTitle' :: FilePath), fromPersistValue . unSingle -> Right (fileReferenceModified :: UTCTime)) -> do + let fileReferenceContent = listToMaybe $ mapMaybe (preview _Right . fromPersistValue . unSingle) insertedContent + fileRef fileReferenceTitle = _FileReference # (FileReference{..}, residual) + candidateTitles = fileReferenceTitle' : [ fName <.> ("old-" <> show n) <.> ext | n <- [1..1000] ] + where (fName, ext) = splitExtension fileReferenceTitle' + validTitles <- dropWhileM (fmap (is _Just) . checkUnique . fileRef) candidateTitles + case validTitles of + fTitle : _ -> doUpdate . Entity fRefKey $ fileRef fTitle + _other -> error "Could not make validTitle" + _other -> return () + migrateFromFile _ _ _ = return () + + whenM (tableExists "submission_file") $ do + [executeQQ| + ALTER TABLE "submission_file" ADD COLUMN "title" VARCHAR; + ALTER TABLE "submission_file" ADD COLUMN "content" BYTEA NULL; + ALTER TABLE "submission_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE; + ALTER TABLE "submission_file" DROP CONSTRAINT "unique_submission_file"; + ALTER TABLE "submission_file" ADD CONSTRAINT "unique_submission_file" UNIQUE("submission", "title", "is_update"); + |] + let getSubmissionFiles = [queryQQ|SELECT "file", "submission_file"."id", "submission", "is_update", "is_deletion" FROM "submission_file" LEFT OUTER JOIN "file" ON "submission_file"."file" = "file".id ORDER BY "file"."modified" DESC;|] + toResidual [ fromPersistValue -> Right sfId + , fromPersistValue -> Right submissionFileResidualSubmission + , fromPersistValue -> Right submissionFileResidualIsUpdate + , fromPersistValue -> Right submissionFileResidualIsDeletion + ] + = (sfId, SubmissionFileResidual{..}) + toResidual _ = error "Could not convert SubmissionFile to residual" + runConduit $ getSubmissionFiles .| C.mapM_ (migrateFromFile @SubmissionFile toResidual replaceEntity) + [executeQQ| + ALTER TABLE "submission_file" DROP COLUMN "file"; + |] + + whenM (tableExists "sheet_file") $ do + [executeQQ| + ALTER TABLE "sheet_file" ADD COLUMN "title" VARCHAR; + ALTER TABLE "sheet_file" ADD COLUMN "content" BYTEA NULL; + ALTER TABLE "sheet_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE; + ALTER TABLE "sheet_file" DROP CONSTRAINT "unique_sheet_file"; + ALTER TABLE "sheet_file" ADD CONSTRAINT "unique_sheet_file" UNIQUE("sheet", "type", "title"); + |] + let getSheetFiles = [queryQQ|SELECT "file", "sheet_file"."id", "sheet", "type" FROM "sheet_file" LEFT OUTER JOIN "file" ON "sheet_file"."file" = "file".id ORDER BY "file"."modified" DESC;|] + toResidual [ fromPersistValue -> Right shfId + , fromPersistValue -> Right sheetFileResidualSheet + , fromPersistValue -> Right sheetFileResidualType + ] + = (shfId, SheetFileResidual{..}) + toResidual _ = error "Could not convert SheetFile to residual" + runConduit $ getSheetFiles .| C.mapM_ (migrateFromFile @SheetFile toResidual replaceEntity) + [executeQQ| + ALTER TABLE "sheet_file" DROP COLUMN "file"; + |] + + whenM (tableExists "course_app_instruction_file") $ do + [executeQQ| + ALTER TABLE "course_app_instruction_file" ADD COLUMN "title" VARCHAR; + ALTER TABLE "course_app_instruction_file" ADD COLUMN "content" BYTEA NULL; + ALTER TABLE "course_app_instruction_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE; + ALTER TABLE "course_app_instruction_file" DROP CONSTRAINT "unique_course_app_instruction_file"; + ALTER TABLE "course_app_instruction_file" ADD CONSTRAINT "unique_course_app_instruction_file" UNIQUE("course", "title"); + |] + let getCourseAppInstructionFiles = [queryQQ|SELECT "file", "course_app_instruction_file"."id", "course" FROM "course_app_instruction_file" LEFT OUTER JOIN "file" ON "course_app_instruction_file"."file" = "file".id ORDER BY "file"."modified" DESC;|] + toResidual [ fromPersistValue -> Right caifId + , fromPersistValue -> Right courseAppInstructionFileResidualCourse + ] + = (caifId, CourseAppInstructionFileResidual{..}) + toResidual _ = error "Could not convert CourseAppInstructionFile to residual" + runConduit $ getCourseAppInstructionFiles .| C.mapM_ (migrateFromFile @CourseAppInstructionFile toResidual replaceEntity) + [executeQQ| + ALTER TABLE "course_app_instruction_file" DROP COLUMN "file"; + |] + + whenM (tableExists "course_news_file") $ do + [executeQQ| + ALTER TABLE "course_news_file" ADD COLUMN "title" VARCHAR; + ALTER TABLE "course_news_file" ADD COLUMN "content" BYTEA NULL; + ALTER TABLE "course_news_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE; + ALTER TABLE "course_news_file" DROP CONSTRAINT "unique_course_news_file"; + ALTER TABLE "course_news_file" ADD CONSTRAINT "unique_course_news_file" UNIQUE("news", "title"); + |] + let getCourseNewsFiles = [queryQQ|SELECT "file", "course_news_file"."id", "news" FROM "course_news_file" LEFT OUTER JOIN "file" ON "course_news_file"."file" = "file".id ORDER BY "file"."modified" DESC;|] + toResidual [ fromPersistValue -> Right cnfId + , fromPersistValue -> Right courseNewsFileResidualNews + ] + = (cnfId, CourseNewsFileResidual{..}) + toResidual _ = error "Could not convert CourseNewsFile to residual" + runConduit $ getCourseNewsFiles .| C.mapM_ (migrateFromFile @CourseNewsFile toResidual replaceEntity) + [executeQQ| + ALTER TABLE "course_news_file" DROP COLUMN "file"; + |] + + whenM (tableExists "material_file") $ do + [executeQQ| + ALTER TABLE "material_file" ADD COLUMN "title" VARCHAR; + ALTER TABLE "material_file" ADD COLUMN "content" BYTEA NULL; + ALTER TABLE "material_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE; + ALTER TABLE "material_file" DROP CONSTRAINT "unique_material_file"; + ALTER TABLE "material_file" ADD CONSTRAINT "unique_material_file" UNIQUE("material", "title"); + |] + let getMaterialFiles = [queryQQ|SELECT "file", "material_file"."id", "material" FROM "material_file" LEFT OUTER JOIN "file" ON "material_file"."file" = "file".id ORDER BY "file"."modified" DESC;|] + toResidual [ fromPersistValue -> Right shfId + , fromPersistValue -> Right materialFileResidualMaterial + ] + = (shfId, MaterialFileResidual{..}) + toResidual _ = error "Could not convert MaterialFile to residual" + runConduit $ getMaterialFiles .| C.mapM_ (migrateFromFile @MaterialFile toResidual replaceEntity) + [executeQQ| + ALTER TABLE "material_file" DROP COLUMN "file"; + |] + + whenM (tableExists "course_application_file") $ do + [executeQQ| + ALTER TABLE "course_application_file" ADD COLUMN "title" VARCHAR; + ALTER TABLE "course_application_file" ADD COLUMN "content" BYTEA NULL; + ALTER TABLE "course_application_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE; + ALTER TABLE "course_application_file" DROP CONSTRAINT "unique_application_file"; + ALTER TABLE "course_application_file" ADD CONSTRAINT "unique_course_application_file" UNIQUE("application", "title"); + |] + let getCourseApplicationFiles = [queryQQ|SELECT "file", "course_application_file"."id", "application" FROM "course_application_file" LEFT OUTER JOIN "file" ON "course_application_file"."file" = "file".id ORDER BY "file"."modified" DESC;|] + toResidual [ fromPersistValue -> Right cnfId + , fromPersistValue -> Right courseApplicationFileResidualApplication + ] + = (cnfId, CourseApplicationFileResidual{..}) + toResidual _ = error "Could not convert CourseApplicationFile to residual" + runConduit $ getCourseApplicationFiles .| C.mapM_ (migrateFromFile @CourseApplicationFile toResidual replaceEntity) + [executeQQ| + ALTER TABLE "course_application_file" DROP COLUMN "file"; + |] + + whenM (tableExists "allocation_matching") $ do + [executeQQ| + ALTER TABLE "allocation_matching" ADD COLUMN "log_ref" BYTEA; + |] + let getAllocationMatchingFiles = [queryQQ|SELECT "log", "allocation_matching"."id" FROM "allocation_matching";|] + moveMatchingFile [ fromPersistValue -> Right (fId :: Int64), fromPersistValue -> Right (amId :: AllocationMatchingId) ] = do + insertedContent <- [sqlQQ| + INSERT INTO "file_content" (SELECT digest("content", 'sha3-512') as "hash", "content" FROM "file" WHERE id = #{fId} AND NOT ("content" IS NULL)) ON CONFLICT("hash") DO UPDATE SET "hash" = EXCLUDED."hash" RETURNING "hash"; + |] + let refContent :: Maybe FileContentReference + refContent = listToMaybe $ mapMaybe (preview _Right . fromPersistValue . unSingle) insertedContent + case refContent of + Nothing -> error "AllocationMatching had no fileContent" + Just h -> [executeQQ|UPDATE "allocation_matching" SET "log_ref" = #{h} WHERE "id" = #{amId};|] + moveMatchingFile _ = return () + runConduit $ getAllocationMatchingFiles .| C.mapM_ moveMatchingFile + [executeQQ| + ALTER TABLE "allocation_matching" DROP COLUMN "log"; + ALTER TABLE "allocation_matching" RENAME COLUMN "log_ref" TO "log"; + |] + + whenM (tableExists "session_file") $ + [executeQQ| + TRUNCATE TABLE "session_file"; + ALTER TABLE "session_file" DROP COLUMN "file"; + ALTER TABLE "session_file" ADD COLUMN "content" BYTEA NULL; + |] + ) ] diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 3797b0647..fc3b1662f 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -15,3 +15,4 @@ import Model.Types.Misc as Types import Model.Types.School as Types import Model.Types.Allocation as Types import Model.Types.Languages as Types +import Model.Types.File as Types diff --git a/src/Model/Types/Common.hs b/src/Model/Types/Common.hs index 692b939b7..8577a86fa 100644 --- a/src/Model/Types/Common.hs +++ b/src/Model/Types/Common.hs @@ -55,4 +55,4 @@ type ClusterId = UUID type TokenId = UUID type TermCandidateIncidence = UUID -type SessionFileReference = Digest SHA3_256 +type FileContentReference = Digest SHA3_512 diff --git a/src/Model/Types/File.hs b/src/Model/Types/File.hs new file mode 100644 index 000000000..23993e85e --- /dev/null +++ b/src/Model/Types/File.hs @@ -0,0 +1,37 @@ +module Model.Types.File + ( File(..), _fileTitle, _fileContent, _fileModified + , FileReference(..), _fileReferenceTitle, _fileReferenceContent, _fileReferenceModified + , HasFileReference(..) + ) where + +import Import.NoModel +import Model.Types.Common (FileContentReference) + +import Utils.Lens.TH + + +data File = File + { fileTitle :: FilePath + , fileContent :: Maybe ByteString + , fileModified :: UTCTime + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + +makeLenses_ ''File + +data FileReference = FileReference + { fileReferenceTitle :: FilePath + , fileReferenceContent :: Maybe FileContentReference + , fileReferenceModified :: UTCTime + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + +makeLenses_ ''FileReference + + +class PersistEntity record => HasFileReference record where + data FileReferenceResidual record :: * + + _FileReference :: Iso' record (FileReference, FileReferenceResidual record) + + fileReferenceTitleField :: EntityField record FilePath + fileReferenceContentField :: EntityField record (Maybe FileContentReference) + fileReferenceModifiedField :: EntityField record UTCTime diff --git a/src/Utils.hs b/src/Utils.hs index 2548aea5e..218f2fd1a 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -43,10 +43,10 @@ import qualified Data.List as List import qualified Data.HashMap.Strict as HashMap import qualified Data.Vector as V --- import qualified Data.Conduit.List as C +import qualified Data.Conduit.List as C (mapMaybe) import qualified Data.Conduit.Combinators as C -import Control.Lens +import Control.Lens hiding (uncons) import Control.Lens as Utils (none) import Control.Lens.Extras (is) import Data.Set.Lens @@ -434,6 +434,12 @@ nonEmpty' = maybe empty pure . nonEmpty nubOn :: Eq b => (a -> b) -> [a] -> [a] nubOn = List.nubBy . ((==) `on`) +dropWhileM :: (IsSequence seq, Monad m) => (Element seq -> m Bool) -> seq -> m seq +dropWhileM p xs' + | Just (x, xs) <- uncons xs' + = bool (return xs') (dropWhileM p xs) =<< p x + | otherwise = return xs' + ---------- -- Sets -- ---------- @@ -831,6 +837,9 @@ allMC f = C.mapM f .| andC yieldMMany :: forall mono m a. (Monad m, MonoFoldable mono) => m mono -> ConduitT a (Element mono) m () yieldMMany = C.yieldMany <=< lift +eitherC :: Monad m => ConduitT l o m () -> ConduitT r o m () -> ConduitT (Either l r) o m () +eitherC lC rC = void $ sequenceConduits [C.mapMaybe (preview _Left) .| lC, C.mapMaybe (preview _Right) .| rC] + ----------------- -- Alternative -- ----------------- diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index 5b514261b..8e16ea1a2 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -107,6 +107,13 @@ myReplaceUnique key datumNew = getJust key >>= replaceOriginal changedKeys = uniqueKeysNew List.\\ uniqueKeysOriginal uniqueKeysOriginal = persistUniqueKeys original +replaceEntity :: ( MonadIO m + , PersistRecordBackend record backend + , PersistStoreWrite backend + ) + => Entity record -> ReaderT backend m () +replaceEntity Entity{..} = replace entityKey entityVal + checkUniqueKeys :: ( MonadIO m , PersistUniqueRead backend , PersistRecordBackend record backend diff --git a/src/Utils/Files.hs b/src/Utils/Files.hs new file mode 100644 index 000000000..271d50e3d --- /dev/null +++ b/src/Utils/Files.hs @@ -0,0 +1,36 @@ +module Utils.Files + ( sinkFile, sinkFiles + , sinkFile', sinkFiles' + ) where + +import Import.NoFoundation + +import qualified Crypto.Hash as Crypto (hash) + +import qualified Data.Conduit.Combinators as C + + +sinkFiles :: MonadIO m => ConduitT File FileReference (SqlPersistT m) () +sinkFiles = C.mapM sinkFile + +sinkFile :: MonadIO m => File -> SqlPersistT m FileReference +sinkFile File{..} = do + fileReferenceContent <- for fileContent $ \fileContentContent -> do + let fileContentHash = Crypto.hash fileContentContent + unlessM (exists [ FileContentHash ==. fileContentHash ]) $ + repsert (FileContentKey fileContentHash) FileContent{..} + return fileContentHash + + return FileReference + { fileReferenceContent + , fileReferenceTitle = fileTitle + , fileReferenceModified = fileModified + } + +sinkFiles' :: (MonadIO m, HasFileReference record) => ConduitT (File, FileReferenceResidual record) record (SqlPersistT m) () +sinkFiles' = C.mapM $ uncurry sinkFile' + +sinkFile' :: (MonadIO m, HasFileReference record) => File -> FileReferenceResidual record -> SqlPersistT m record +sinkFile' file residual = do + reference <- sinkFile file + return $ _FileReference # (reference, residual) diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 737f9d713..a08246da3 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -206,8 +206,6 @@ makeLenses_ ''CourseApplication makeLenses_ ''Allocation -makeLenses_ ''File - makeLenses_ ''Submission makeLenses_ ''SubmissionUser diff --git a/src/Utils/Sheet.hs b/src/Utils/Sheet.hs index 31ee278d6..d6baeeaf6 100644 --- a/src/Utils/Sheet.hs +++ b/src/Utils/Sheet.hs @@ -46,15 +46,14 @@ sheetOldUnassigned tid ssh csh = do _ -> error "SQL Query with limit 1 returned more than one result" -- | Return a specfic file from a `Sheet` -sheetFileQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> ConduitT () (Entity File) (SqlPersistT m) () +sheetFileQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> ConduitT () (Entity SheetFile) (SqlPersistT m) () sheetFileQuery tid ssh csh shn sft title = E.selectSource $ E.from $ - \(course `E.InnerJoin` sheet `E.InnerJoin` sFile `E.InnerJoin` file) -> do + \(course `E.InnerJoin` sheet `E.InnerJoin` sFile) -> do -- Restrict to consistent rows that correspond to each other - E.on (file E.^. FileId E.==. sFile E.^. SheetFileFile) E.on (sFile E.^. SheetFileSheet E.==. sheet E.^. SheetId) E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId) -- filter to requested file - E.where_ ((file E.^. FileTitle E.==. E.val title) + E.where_ ((sFile E.^. SheetFileTitle E.==. E.val title) E.&&. (sFile E.^. SheetFileType E.==. E.val sft ) E.&&. (sheet E.^. SheetName E.==. E.val shn ) E.&&. (course E.^. CourseShorthand E.==. E.val csh ) @@ -62,14 +61,13 @@ sheetFileQuery tid ssh csh shn sft title = E.selectSource $ E.from $ E.&&. (course E.^. CourseTerm E.==. E.val tid ) ) -- return file entity - return file + return sFile -- | Return all files of a certain `SheetFileType` for a `Sheet` -sheetFilesAllQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> ConduitT () (Entity File) (SqlPersistT m) () +sheetFilesAllQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> ConduitT () (Entity SheetFile) (SqlPersistT m) () sheetFilesAllQuery tid ssh csh shn sft = E.selectSource $ E.from $ - \(course `E.InnerJoin` sheet `E.InnerJoin` sFile `E.InnerJoin` file) -> do + \(course `E.InnerJoin` sheet `E.InnerJoin` sFile) -> do -- Restrict to consistent rows that correspond to each other - E.on (file E.^. FileId E.==. sFile E.^. SheetFileFile) E.on (sFile E.^. SheetFileSheet E.==. sheet E.^. SheetId) E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId) -- filter to requested file @@ -80,14 +78,13 @@ sheetFilesAllQuery tid ssh csh shn sft = E.selectSource $ E.from $ E.&&. (sFile E.^. SheetFileType E.==. E.val sft ) ) -- return file entity - return file + return sFile -- | Return all files of certain `SheetFileTypes` for a `Sheet` -sheetFilesSFTsQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> [SheetFileType] -> ConduitT () (Entity File) (SqlPersistT m) () +sheetFilesSFTsQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> [SheetFileType] -> ConduitT () (Entity SheetFile) (SqlPersistT m) () sheetFilesSFTsQuery tid ssh csh shn sfts = E.selectSource $ E.from $ - \(course `E.InnerJoin` sheet `E.InnerJoin` sFile `E.InnerJoin` file) -> do + \(course `E.InnerJoin` sheet `E.InnerJoin` sFile) -> do -- Restrict to consistent rows that correspond to each other - E.on (file E.^. FileId E.==. sFile E.^. SheetFileFile) E.on (sFile E.^. SheetFileSheet E.==. sheet E.^. SheetId) E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId) -- filter to requested file @@ -98,7 +95,7 @@ sheetFilesSFTsQuery tid ssh csh shn sfts = E.selectSource $ E.from $ E.&&. (sFile E.^. SheetFileType `E.in_` E.valList sfts ) ) -- return file entity - return file + return sFile -- | Check whether a sheet has any files for a given file type hasSheetFileQuery :: E.SqlExpr (Entity Sheet) -> SheetFileType -> E.SqlExpr (E.Value Bool) diff --git a/stack.yaml b/stack.yaml index a24808702..4b62d1b8a 100644 --- a/stack.yaml +++ b/stack.yaml @@ -114,5 +114,7 @@ extra-deps: - normaldistribution-1.1.0.3 + - unordered-containers-0.2.11.0 + resolver: lts-15.12 allow-newer: true diff --git a/stack.yaml.lock b/stack.yaml.lock index 3d8d3b3a3..e2eee764d 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -318,6 +318,13 @@ packages: sha256: 856818862d12df8b030fa9cfef2c4ffa604d06f0eb057498db245dfffcd60e3c original: hackage: normaldistribution-1.1.0.3 +- completed: + hackage: unordered-containers-0.2.11.0@sha256:ba70b8a9d7eebc2034bf92e5690b2dd71200e76aa9f3f93e0b6be3f27f244d18,4998 + pantry-tree: + size: 1416 + sha256: d9b83f62373f509a441223f22f12e22e39b38ef3275dfca7c190a4795bebfed5 + original: + hackage: unordered-containers-0.2.11.0 snapshots: - completed: size: 494635 diff --git a/templates/course.hamlet b/templates/course.hamlet index b7a269c3c..71192130c 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -165,6 +165,21 @@ $# $if NTop (Just 0) < NTop (courseCapacity course) _{MsgCourseApplicationTemplateApplication} $else _{MsgCourseApplicationTemplateRegistration} + $nothing + $if hasApplicationTemplate +
+ $if courseApplicationsRequired course + _{MsgCourseApplicationInstructionsApplication} + $else + _{MsgCourseApplicationInstructionsRegistration} +
+ + #{iconRegisterTemplate} # + $if courseApplicationsRequired course + _{MsgCourseApplicationTemplateApplication} + $else + _{MsgCourseApplicationTemplateRegistration} + $maybe mGroup <- submissionGroup
_{MsgSubmissionGroup} diff --git a/templates/widgets/genericFileField.hamlet b/templates/widgets/genericFileField.hamlet index 356bbdc57..cb9601e77 100644 --- a/templates/widgets/genericFileField.hamlet +++ b/templates/widgets/genericFileField.hamlet @@ -9,7 +9,7 @@ $if not (null fileInfos) $forall FileUploadInfo{..} <- fileInfos
  • - + $if fuiSession ^{messageTooltip uploadOnlySessionMessage}