refactor(files): store content separately from metadata
This commit is contained in:
Gregor Kleen
parent
a8b96a6f95
commit
14be8f61b4
@ -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
|
||||
|
||||
12
minio-file-uploads.md
Normal file
12
minio-file-uploads.md
Normal file
@ -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
|
||||
@ -30,7 +30,7 @@ AllocationMatching
|
||||
allocation AllocationId
|
||||
fingerprint AllocationFingerprint
|
||||
time UTCTime
|
||||
log FileId
|
||||
log FileContentReference
|
||||
|
||||
AllocationCourse
|
||||
allocation AllocationId
|
||||
|
||||
@ -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`
|
||||
info Value -- JSON-encoded `Transaction`
|
||||
deriving Eq Read Show Generic Typeable
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
title FilePath
|
||||
content FileContentReference Maybe
|
||||
modified UTCTime
|
||||
UniqueMaterialFile material title
|
||||
@ -7,6 +7,8 @@ CourseNews
|
||||
summary Html Maybe
|
||||
lastEdit UTCTime
|
||||
CourseNewsFile
|
||||
news CourseNewsId
|
||||
file FileId
|
||||
UniqueCourseNewsFile news file
|
||||
news CourseNewsId
|
||||
title FilePath
|
||||
content FileContentReference Maybe
|
||||
modified UTCTime
|
||||
UniqueCourseNewsFile news title
|
||||
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -58,7 +58,6 @@ instance {-# OVERLAPPING #-} MonadThrow m => MonadCrypto (ReaderT CryptoIDKey m)
|
||||
|
||||
-- Generates CryptoUUID... and CryptoFileName... Datatypes
|
||||
decCryptoIDs [ ''SubmissionId
|
||||
, ''FileId
|
||||
, ''UserId
|
||||
, ''SheetId
|
||||
, ''SystemMessageId
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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}|]
|
||||
|
||||
|
||||
@ -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
|
||||
}
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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,
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
|
||||
45
src/Handler/Utils/Files.hs
Normal file
45
src/Handler/Utils/Files.hs
Normal file
@ -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)
|
||||
@ -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
|
||||
}
|
||||
|
||||
|
||||
@ -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
|
||||
}
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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"]
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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(..))
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
]
|
||||
|
||||
184
src/Model.hs
184
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
|
||||
|
||||
|
||||
@ -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;
|
||||
|]
|
||||
)
|
||||
]
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -55,4 +55,4 @@ type ClusterId = UUID
|
||||
type TokenId = UUID
|
||||
type TermCandidateIncidence = UUID
|
||||
|
||||
type SessionFileReference = Digest SHA3_256
|
||||
type FileContentReference = Digest SHA3_512
|
||||
|
||||
37
src/Model/Types/File.hs
Normal file
37
src/Model/Types/File.hs
Normal file
@ -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
|
||||
13
src/Utils.hs
13
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 --
|
||||
-----------------
|
||||
|
||||
@ -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
|
||||
|
||||
36
src/Utils/Files.hs
Normal file
36
src/Utils/Files.hs
Normal file
@ -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)
|
||||
@ -206,8 +206,6 @@ makeLenses_ ''CourseApplication
|
||||
|
||||
makeLenses_ ''Allocation
|
||||
|
||||
makeLenses_ ''File
|
||||
|
||||
makeLenses_ ''Submission
|
||||
makeLenses_ ''SubmissionUser
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -114,5 +114,7 @@ extra-deps:
|
||||
|
||||
- normaldistribution-1.1.0.3
|
||||
|
||||
- unordered-containers-0.2.11.0
|
||||
|
||||
resolver: lts-15.12
|
||||
allow-newer: true
|
||||
|
||||
@ -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
|
||||
|
||||
@ -165,6 +165,21 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
|
||||
_{MsgCourseApplicationTemplateApplication}
|
||||
$else
|
||||
_{MsgCourseApplicationTemplateRegistration}
|
||||
$nothing
|
||||
$if hasApplicationTemplate
|
||||
<dt .deflist__dt>
|
||||
$if courseApplicationsRequired course
|
||||
_{MsgCourseApplicationInstructionsApplication}
|
||||
$else
|
||||
_{MsgCourseApplicationInstructionsRegistration}
|
||||
<dd .deflist__dd>
|
||||
<a href=@{CourseR tid ssh csh CRegisterTemplateR}>
|
||||
#{iconRegisterTemplate} #
|
||||
$if courseApplicationsRequired course
|
||||
_{MsgCourseApplicationTemplateApplication}
|
||||
$else
|
||||
_{MsgCourseApplicationTemplateRegistration}
|
||||
|
||||
$maybe mGroup <- submissionGroup
|
||||
<dt .deflist__dt>
|
||||
_{MsgSubmissionGroup}
|
||||
|
||||
@ -9,7 +9,7 @@ $if not (null fileInfos)
|
||||
$forall FileUploadInfo{..} <- fileInfos
|
||||
<li>
|
||||
<div .file-container>
|
||||
<input type=checkbox id=#{fuiHtmlId} name=#{fieldName} :fuiChecked:checked value=#{toPathPiece fuiId} :fuiForced:readonly>
|
||||
<input type=checkbox id=#{fuiHtmlId} name=#{fieldName} :fuiChecked:checked value=#{review _FileTitle fuiTitle} :fuiForced:readonly>
|
||||
$if fuiSession
|
||||
^{messageTooltip uploadOnlySessionMessage}
|
||||
<label for=#{fuiHtmlId}>
|
||||
|
||||
@ -35,11 +35,11 @@ testdataDir :: FilePath
|
||||
testdataDir = "testdata"
|
||||
|
||||
|
||||
insertFile :: FilePath -> DB FileId
|
||||
insertFile fileTitle = do
|
||||
insertFile :: ( HasFileReference fRef, PersistRecordBackend fRef SqlBackend ) => FileReferenceResidual fRef -> FilePath -> DB (Key fRef)
|
||||
insertFile residual fileTitle = do
|
||||
fileContent <- liftIO . fmap Just . BS.readFile $ testdataDir </> fileTitle
|
||||
fileModified <- liftIO getCurrentTime
|
||||
insert File{..}
|
||||
sinkFile' File{..} residual >>= insert
|
||||
|
||||
fillDb :: DB ()
|
||||
fillDb = do
|
||||
@ -832,12 +832,9 @@ fillDb = do
|
||||
void . insert $ SheetCorrector jost shId (Load (Just True) 0) CorrectorNormal
|
||||
void . insert $ SheetCorrector gkleen shId (Load (Just True) 1) CorrectorNormal
|
||||
void . insert $ SheetCorrector svaupel shId (Load (Just True) 1) CorrectorNormal
|
||||
h102 <- insertFile "H10-2.hs"
|
||||
h103 <- insertFile "H10-3.hs"
|
||||
pdf10 <- insertFile "ProMo_Uebung10.pdf"
|
||||
void . insert $ SheetFile shId h102 SheetHint
|
||||
void . insert $ SheetFile shId h103 SheetSolution
|
||||
void . insert $ SheetFile shId pdf10 SheetExercise
|
||||
void $ insertFile (SheetFileResidual shId SheetHint) "H10-2.hs"
|
||||
void $ insertFile (SheetFileResidual shId SheetSolution) "H10-3.hs"
|
||||
void $ insertFile (SheetFileResidual shId SheetExercise) "ProMo_Uebung10.pdf"
|
||||
|
||||
forM_ [fhamann, maxMuster, tinaTester] $ \uid -> do
|
||||
subId <- insert $ Submission
|
||||
@ -850,8 +847,7 @@ fillDb = do
|
||||
}
|
||||
void . insert $ SubmissionEdit (Just uid) now subId
|
||||
void . insert $ SubmissionUser uid subId
|
||||
fId <- insertFile "AbgabeH10-1.hs"
|
||||
void . insert $ SubmissionFile subId fId False False
|
||||
void $ insertFile (SubmissionFileResidual subId False False) "AbgabeH10-1.hs"
|
||||
tut1 <- insert Tutorial
|
||||
{ tutorialName = "Di08"
|
||||
, tutorialCourse = pmo
|
||||
@ -1017,7 +1013,7 @@ fillDb = do
|
||||
, (jost, CourseParticipantActive)
|
||||
]
|
||||
|
||||
void $ insertFile "H10-2.hs" -- unreferenced
|
||||
-- void $ insertFile "H10-2.hs" -- unreferenced
|
||||
|
||||
-- -- betriebssysteme
|
||||
bs <- insert' Course
|
||||
|
||||
Loading…
Reference in New Issue
Block a user