117 lines
5.9 KiB
Haskell
117 lines
5.9 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
|
|
|
module Handler.Submission.Helper.ArchiveTable
|
|
( mkSubmissionArchiveTable
|
|
) where
|
|
|
|
import Import
|
|
import Handler.Utils
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
import qualified Database.Esqueleto.Internal.Internal as E (unsafeSqlFunction)
|
|
|
|
|
|
type SubmissionArchiveExpr = E.SqlExpr (Maybe (Entity SubmissionFile)) `E.FullOuterJoin` E.SqlExpr (Maybe (Entity SubmissionFile))
|
|
|
|
queryOriginal, queryCorrected :: Getter SubmissionArchiveExpr (E.SqlExpr (Maybe (Entity SubmissionFile)))
|
|
queryOriginal = to $(E.sqlFOJproj 2 1)
|
|
queryCorrected = to $(E.sqlFOJproj 2 2)
|
|
|
|
|
|
type SubmissionArchiveData = DBRow ( Maybe (Entity SubmissionFile)
|
|
, Maybe (Entity SubmissionFile)
|
|
)
|
|
|
|
resultOriginal, resultCorrected :: Traversal' SubmissionArchiveData (Entity SubmissionFile)
|
|
resultOriginal = _dbrOutput . _1 . _Just
|
|
resultCorrected = _dbrOutput . _2 . _Just
|
|
|
|
|
|
mkSubmissionArchiveTable :: TermId -> SchoolId -> CourseShorthand -> SheetName
|
|
-> Bool -- ^ @showCorrection@
|
|
-> SubmissionId
|
|
-> DB (Bool, Widget)
|
|
mkSubmissionArchiveTable tid ssh csh shn showCorrection smid = do
|
|
cID <- encrypt smid :: DB CryptoFileNameSubmission -- shouldn't be expensive due to caching
|
|
|
|
let
|
|
dbtIdent :: Text
|
|
dbtIdent = "files"
|
|
|
|
dbtSQLQuery = runReaderT $ do
|
|
original <- view queryOriginal
|
|
corrected <- view queryCorrected
|
|
|
|
lift . E.on $
|
|
original E.?. SubmissionFileTitle E.==. corrected E.?. SubmissionFileTitle
|
|
E.&&. original E.?. SubmissionFileSubmission E.==. corrected E.?. SubmissionFileSubmission
|
|
E.&&. original E.?. SubmissionFileId E.!=. corrected E.?. SubmissionFileId
|
|
E.&&. corrected E.?. SubmissionFileIsDeletion E.==. E.val (Just False)
|
|
E.&&. E.val showCorrection -- Do not correlate files if we don't show correction; together with `may-access` this treats corrected files like they literally don't exist
|
|
|
|
lift . E.where_ $ original E.?. SubmissionFileSubmission E.==. E.val (Just smid)
|
|
E.||. corrected E.?. SubmissionFileSubmission E.==. E.val (Just smid)
|
|
|
|
lift . E.where_ . E.maybe E.true E.not_ $ original E.?. SubmissionFileIsUpdate -- @original@ is unset or not an update
|
|
lift . E.where_ . E.maybe E.true id $ corrected E.?. SubmissionFileIsUpdate -- @corrected@ is unset or an update
|
|
lift . E.where_ . E.maybe E.true E.not_ $ corrected E.?. SubmissionFileIsDeletion -- @corrected@ is unset or not a deletion
|
|
return (original, corrected)
|
|
dbtRowKey = (,) <$> views queryOriginal (E.?. SubmissionFileId) <*> views queryCorrected (E.?. SubmissionFileId)
|
|
|
|
dbtProj = dbtProjId
|
|
|
|
dbtColonnade = mconcat $ catMaybes
|
|
[ Just . sortable (Just "path") (i18nCell MsgTableFileTitle) $ \t -> let
|
|
mOrig = t ^? resultOriginal
|
|
mCorr = t ^? resultCorrected
|
|
fileTitle'' = submissionFileTitle . entityVal <$> (mOrig <|> mCorr)
|
|
origIsFile = fmap (isJust . submissionFileContent . entityVal) mOrig
|
|
corrIsFile = fmap (isJust . submissionFileContent . entityVal) mCorr
|
|
isFile' = origIsFile <|> corrIsFile
|
|
in maybeCell ((,) <$> fileTitle'' <*> isFile') $ \(fileTitle', isFile) -> if
|
|
| Just True <- origIsFile -> anchorCell (subDownloadLink SubmissionOriginal fileTitle') [whamlet|#{fileTitle'}|]
|
|
| otherwise -> stringCell $ bool (<> "/") id isFile fileTitle'
|
|
, guardOn showCorrection . sortable (toNothing "state") (i18nCell MsgTableCorState) $ \t -> case t ^? resultCorrected of
|
|
Nothing -> cell mempty
|
|
Just (Entity _ SubmissionFile{..}) -> tellCell (Any True) $ if
|
|
| isJust submissionFileContent -> anchorCell (subDownloadLink SubmissionCorrected submissionFileTitle) (i18n MsgFileCorrected :: Widget)
|
|
| otherwise -> i18nCell MsgCorrected
|
|
, Just . sortable (Just "time") (i18nCell MsgTableFileModified) $ \t -> let
|
|
mOrig = t ^? resultOriginal
|
|
mCorr = t ^? resultCorrected
|
|
origTime = submissionFileModified . entityVal <$> mOrig
|
|
corrTime = submissionFileModified . entityVal <$> mCorr
|
|
fileTime = (max <$> origTime <*> corrTime) <|> origTime <|> corrTime
|
|
in maybeCell fileTime dateTimeCell
|
|
]
|
|
where
|
|
subDownloadLink sft fileTitle' = CSubmissionR tid ssh csh shn cID $ SubDownloadR sft fileTitle'
|
|
|
|
dbtStyle = def
|
|
|
|
dbtSorting = mconcat
|
|
[ singletonMap "path" . SortColumn $ \r -> (E.unsafeSqlFunction "string_to_array" :: (E.SqlExpr (E.Value (Maybe String)), E.SqlExpr (E.Value String)) -> E.SqlExpr (E.Value [String])) (E.coalesce [views queryOriginal (E.?. SubmissionFileTitle) r, views queryCorrected (E.?. SubmissionFileTitle) r], E.val "/" :: E.SqlExpr (E.Value String))
|
|
, singletonMap "time" . SortColumn $ \r -> (E.unsafeSqlFunction "GREATEST" ([views queryOriginal (E.?. SubmissionFileModified) r, views queryCorrected (E.?. SubmissionFileModified) r] :: [E.SqlExpr (E.Value (Maybe UTCTime))]) :: E.SqlExpr (E.Value (Maybe UTCTime)))
|
|
]
|
|
dbtFilter = mconcat
|
|
[ singletonMap "may-access" . FilterColumn $ \(Any b) r
|
|
-> E.val b E.==. (E.val showCorrection E.||. E.isJust (views queryOriginal (E.?. SubmissionFileId) r))
|
|
]
|
|
|
|
dbtFilterUI = mempty
|
|
|
|
dbtParams = def
|
|
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
dbtExtraReps = []
|
|
|
|
archiveTableValidator = def
|
|
& defaultSorting [SortAscBy "path"]
|
|
& forceFilter "may-access" (Any True)
|
|
in over _1 getAny <$> dbTableWidget archiveTableValidator DBTable{..}
|