{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE ParallelListComp #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE MultiWayIf #-} module Handler.Submission where import Import hiding (joinPath) -- import Yesod.Form.Bootstrap3 import Handler.Utils import Handler.Utils.Table.Cells import Network.Mime -- import Control.Monad.Trans.Maybe -- import Control.Monad.State.Class -- import Control.Monad.Trans.State.Strict (StateT) import Data.Monoid (Any(..)) import Data.Maybe (fromJust) -- import qualified Data.Maybe import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.CaseInsensitive (CI) -- import qualified Data.CaseInsensitive as CI import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Internal.Sql as E (unsafeSqlFunction) import qualified Data.Conduit.List as Conduit -- import Data.Conduit.ResumableSink -- import Data.Set (Set) import qualified Data.Set as Set import Data.Map (Map) import qualified Data.Map as Map -- import Data.Bifunctor import System.FilePath -- import Colonnade hiding (bool, fromMaybe) -- import qualified Yesod.Colonnade as Yesod -- import qualified Text.Blaze.Html5.Attributes as HA -- DEPRECATED: We always show all edits! -- numberOfSubmissionEditDates :: Int64 -- numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production. makeSubmissionForm :: Maybe SubmissionId -> UploadMode -> SheetGroup -> [UserEmail] -> Form (Maybe (Source Handler File), [UserEmail]) makeSubmissionForm msmid uploadMode grouping buddies = identForm FIDsubmission $ \html -> do let fileUpload = case uploadMode of NoUpload -> pure Nothing (Upload unpackZips) -> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing flip (renderAForm FormStandard) html $ (,) <$> fileUpload <*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies (ciField textField) (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy | g <- [1..(max groupNr $ length buddies)] -- groupNr might have decreased meanwhile | buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies ]) <* submitButton where (groupNr, editableBuddies) | Arbitrary{..} <- grouping = (pred maxParticipants, True) -- pred to account for the person submitting | otherwise = (0, False) aforced' f fs (Just (Just v)) = Just <$> aforced f fs v aforced' _ _ _ = error "Cannot happen since groupNr==0 if grouping/=Arbitrary" getSubmissionNewR, postSubmissionNewR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSubmissionNewR = postSubmissionNewR postSubmissionNewR tid ssh csh shn = submissionHelper tid ssh csh shn NewSubmission getSubShowR, postSubShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html getSubShowR = postSubShowR postSubShowR tid ssh csh shn cid = submissionHelper tid ssh csh shn $ ExistingSubmission cid getSubmissionOwnR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSubmissionOwnR tid ssh csh shn = do authId <- requireAuthId sid <- runDB $ do shid <- fetchSheetId tid ssh csh shn submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission) E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val authId E.&&. submission E.^. SubmissionSheet E.==. E.val shid return $ submission E.^. SubmissionId case submissions of ((E.Value sid):_) -> return sid [] -> notFound cID <- encrypt sid redirect $ CSubmissionR tid ssh csh shn cID SubShowR submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SubmissionMode -> Handler Html submissionHelper tid ssh csh shn (SubmissionMode mcid) = do uid <- requireAuthId msmid <- traverse decrypt mcid actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute maySubmit <- (== Authorized) <$> isAuthorized actionUrl True -- affects visibility of Edit-Dates, Submission-Button, etc. (Entity shid Sheet{..}, buddies, lastEdits) <- runDB $ do csheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn case msmid of Nothing -> do submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission) E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid E.&&. submission E.^. SubmissionSheet E.==. E.val shid return $ submission E.^. SubmissionId -- $logDebugS "Submission.DUPLICATENEW" (tshow submissions) case submissions of [] -> do -- fetch buddies from previous submission in this course buddies <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId) let oldids = E.subList_select . E.from $ \(sheet `E.InnerJoin` submission `E.InnerJoin` subUser `E.InnerJoin` submissionEdit) -> do E.on (submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId) E.on (subUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId) E.on (sheet E.^. SheetId E.==. submission E.^. SubmissionSheet) E.where_ $ subUser E.^. SubmissionUserUser E.==. E.val uid E.&&. sheet E.^. SheetCourse E.==. E.val sheetCourse E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime] E.limit 1 return $ submission E.^. SubmissionId E.where_ $ submissionUser E.^. SubmissionUserSubmission `E.in_` oldids E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid E.orderBy [E.asc $ user E.^. UserEmail] return $ user E.^. UserEmail return (csheet, map E.unValue buddies, []) (E.Value smid:_) -> do cID <- encrypt smid addMessageI "info" $ MsgSubmissionAlreadyExists redirect $ CSubmissionR tid ssh csh shn cID SubShowR (Just smid) -> do void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid) shid' <- submissionSheet <$> get404 smid -- fetch buddies from current submission (Any isOwner, buddies) <- do submittors <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId) E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smid E.orderBy [E.asc $ user E.^. UserEmail] return $ (user E.^. UserId, user E.^. UserEmail) let breakUserFromBuddies (E.Value userID, E.Value email) | uid == userID = (Any True , []) | otherwise = (Any False, [email]) return $ foldMap breakUserFromBuddies submittors lastEdits <- do raw <- E.select . E.from $ \(user `E.InnerJoin` submissionEdit) -> do E.on (user E.^. UserId E.==. submissionEdit E.^. SubmissionEditUser) E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. E.val smid E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime] -- E.limit numberOfSubmissionEditDates -- DEPRECATED we always show all edit times let userName = if isOwner || maySubmit then E.just $ user E.^. UserDisplayName else E.nothing return $ (userName, submissionEdit E.^. SubmissionEditTime) forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time return (csheet,buddies,lastEdits) ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid sheetUploadMode sheetGrouping buddies mCID <- runDB $ do res' <- case res of (FormMissing ) -> return $ FormMissing (FormFailure failmsgs) -> return $ FormFailure failmsgs (FormSuccess (mFiles,[])) -> return $ FormSuccess (mFiles,[]) -- Type change (FormSuccess (mFiles,gEMails@(_:_))) -- Validate AdHoc Group Members | (Arbitrary {..}) <- sheetGrouping -> do -- , length gEMails < maxParticipants -> do -- < since submitting user is already accounted for let prep :: [(E.Value UserEmail, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map (CI Text) (Maybe (UserId, Bool, Bool)) prep ps = Map.filter (maybe True $ \(i,_,_) -> i /= uid) . Map.fromList $ map (, Nothing) gEMails ++ [(m, Just (i,p,s))|(E.Value m, (E.Value i, E.Value p, E.Value s)) <- ps] participants <- fmap prep . E.select . E.from $ \user -> do E.where_ $ (user E.^. UserEmail) `E.in_` E.valList gEMails let isParticipant = E.sub_select . E.from $ \courseParticipant -> do E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val sheetCourse return $ E.countRows E.>. E.val (0 :: Int64) hasSubmitted = E.sub_select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId E.where_ $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId E.&&. submission E.^. SubmissionSheet E.==. E.val shid case msmid of -- Multiple `E.where_`-Statements are merged with `&&` in esqueleto 2.5.3 Nothing -> return () Just smid -> E.where_ $ submission E.^. SubmissionId E.!=. E.val smid return $ E.countRows E.>. E.val (0 :: Int64) return (user E.^. UserEmail, (user E.^. UserId, isParticipant, hasSubmitted)) $logDebugS "SUBMISSION.AdHocGroupValidation" $ tshow participants mr <- getMessageRender let failmsgs = (concat :: [[Text]] -> [Text]) [ flip Map.foldMapWithKey participants $ \email -> \case Nothing -> pure . mr $ MsgEMailUnknown email (Just (_,False,_)) -> pure . mr $ MsgNotAParticipant email tid csh (Just (_,_, True)) -> pure . mr $ MsgSubmissionAlreadyExistsFor email _other -> mempty , case length participants `compare` maxParticipants of LT -> mempty _ -> pure $ mr MsgTooManyParticipants ] return $ if null failmsgs then FormSuccess (mFiles, foldMap (\(Just (i,_,_)) -> [i]) participants) else FormFailure failmsgs | otherwise -> return $ FormFailure ["Mismatching number of group participants"] case res' of (FormSuccess (mFiles,(setFromList -> adhocIds))) -> do now <- liftIO $ getCurrentTime smid <- do smid <- case (mFiles, msmid) of (Nothing, Just smid) -- no new files, existing submission partners updated -> return smid (Just files, _) -- new files -> runConduit $ transPipe lift files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False (Nothing, Nothing) -- new submission, no file upload requested -> insert Submission { submissionSheet = shid , submissionRatingPoints = Nothing , submissionRatingComment = Nothing , submissionRatingBy = Nothing , submissionRatingTime = Nothing } -- Determine members of pre-registered group groupUids <- fmap (setFromList . map E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroup E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid E.&&. submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse return $ submissionGroupUser' E.^. SubmissionGroupUserUser -- SubmissionUser for all group members (pre-registered & ad-hoc) let subUsers = Set.insert uid $ groupUids `Set.union` adhocIds -- remove obsolete old entries deleteWhere [SubmissionUserSubmission ==. smid, SubmissionUserUser /<-. setToList subUsers] -- maybe add current users forM_ subUsers $ \uid' -> void . insertUnique $ SubmissionUser uid' smid return smid cID <- encrypt smid return $ Just cID (FormFailure msgs) -> Nothing <$ forM_ msgs (addMessage "warning" . toHtml) _other -> return Nothing case mCID of Just cID -> redirect $ CSubmissionR tid ssh csh shn cID SubShowR Nothing -> return () -- Maybe construct a table to display uploaded archive files let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (HandlerT UniWorX IO) ()) colonnadeFiles cid = mconcat [ 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 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' , sortable (toNothing "state") (i18nCell MsgCorState) $ \(coalesce -> (_, mCorr)) -> case mCorr of Nothing -> cell mempty Just (_, Entity _ File{..}) | isJust fileContent -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionCorrected fileTitle) ([whamlet|_{MsgFileCorrected}|]) | otherwise -> i18nCell MsgCorrected , sortable (Just "time") (i18nCell MsgFileModified) $ \(coalesce -> (mOrig, mCorr)) -> let origTime = fileModified . entityVal . snd <$> mOrig corrTime = fileModified . entityVal . snd <$> mCorr Just fileTime = (max <$> origTime <*> corrTime) <|> origTime <|> corrTime in timeCell 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 E.&&. sf1 E.?. SubmissionFileSubmission E.==. sf2 E.?. SubmissionFileSubmission E.&&. sf1 E.?. SubmissionFileId E.!=. sf2 E.?. SubmissionFileId 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.&&. (sf1 E.?. SubmissionFileSubmission E.==. E.val (Just smid) E.||. sf2 E.?. SubmissionFileSubmission E.==. E.val (Just smid)) return ((sf1, f1), (sf2, f2)) smid2ArchiveTable (smid,cid) = DBTable { dbtSQLQuery = submissionFiles smid , dbtColonnade = colonnadeFiles cid , dbtProj = return . dbrOutput , dbtStyle = def , dbtIdent = "files" :: Text , dbtSorting = [ ( "path" , SortColumn $ \((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) -> E.coalesce [f1 E.?. FileTitle, f2 E.?. FileTitle] ) , ( "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))) ) ] , dbtFilter = [] } mFileTable <- traverse (fmap snd . dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid defaultLayout $ do setTitleI $ MsgSubmissionEditHead tid ssh csh shn let urlArchive cID = CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionCorrected)) urlOriginal cID = CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionOriginal)) $(widgetFile "submission") getSubDownloadR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do runDB $ do submissionID <- submissionMatchesSheet tid ssh csh shn cID isRating <- maybe False (== submissionID) <$> isRatingFile path when (isUpdate || isRating) $ guardAuthResult =<< evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) False case isRating of True | isUpdate -> do file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID) maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file | otherwise -> notFound False -> do results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile) E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID E.&&. f E.^. FileTitle 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 let fileName = Text.pack $ takeFileName path case results of [Entity _ File{ fileContent = Just c, fileTitle }] -> do whenM downloadFiles $ addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|] return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent c) [Entity _ File{ fileContent = Nothing }] -> sendResponseStatus noContent204 () other -> do $logErrorS "SubDownloadR" $ "Multiple matching files: " <> tshow other error "Multiple matching files found." getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do when (sfType == SubmissionCorrected) $ guardAuthResult =<< evalAccess (CSubmissionR tid ssh csh shn cID CorrectionR) False let filename | SubmissionOriginal <- sfType = ZIPArchiveName $ toPathPiece cID <> "-" <> toPathPiece sfType | otherwise = ZIPArchiveName $ toPathPiece cID addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece filename}"|] respondSourceDB "application/zip" $ do submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID rating <- lift $ getRating submissionID let fileSource = case sfType of SubmissionOriginal -> E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> do E.on $ f E.^. FileId E.==. sf E.^. SubmissionFileFile E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val False return f _ -> submissionFileSource submissionID fileSource' = do fileSource .| Conduit.map entityVal when (sfType == SubmissionCorrected) $ maybe (return ()) (yieldM . ratingFile cID) rating zipComment = Text.encodeUtf8 $ toPathPiece cID fileSource' .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder