{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ParallelListComp #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternGuards #-} module Handler.Submission where import Import hiding (joinPath) -- import Yesod.Form.Bootstrap3 import Handler.Utils import Network.Mime import Control.Monad.Trans.Maybe import Control.Monad.State.Class import Control.Monad.Trans.State.Strict (StateT) 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 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) import Yesod.Colonnade import qualified Text.Blaze.Html5.Attributes as HA makeSubmissionForm :: Bool -> SheetGroup -> [Text] -> Form (Source Handler File, [Text]) makeSubmissionForm unpackZips grouping buddies = identForm FIDsubmission $ \html -> do flip (renderAForm FormStandard) html $ (,) <$> areq (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing <*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies textField (fsm $ MsgSubmissionMember g) 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" getSubmissionR, postSubmissionR :: TermId -> Text -> Text -> SubmissionMode -> Handler Html getSubmissionR = postSubmissionR postSubmissionR tid csh shn (SubmissionMode mcid) = do uid <- requireAuthId msmid <- traverse decrypt mcid (Entity shid Sheet{..}, buddies, oldfiles,lastEdits) <- runDB $ do sheet@(Entity shid Sheet{..}) <- fetchSheet tid 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` submissionUser `E.InnerJoin` submissionEdit) -> do E.on (submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId) E.on (submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId) E.on (sheet E.^. SheetId E.==. submission E.^. SubmissionSheet) E.where_ $ submissionUser 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 (sheet,buddies,[],[]) (E.Value smid:_) -> do cID <- encrypt smid addMessageI "info" $ MsgSubmissionAlreadyExists redirect $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID (Just smid) -> do shid' <- submissionSheet <$> get404 smid when (shid /= shid') $ invalidArgsI [MsgSubmissionWrongSheet] -- fetch buddies from current submission buddies <- 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.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid E.orderBy [E.asc $ user E.^. UserEmail] return $ user E.^. UserEmail oldfiles <- sourceToList $ submissionFileSource smid -- mLastEdit <- selectFirst [SubmissionEditSubmission ==. smid] [Desc SubmissionEditTime] lastEditValues <- 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 10 return $ (user E.^. UserDisplayName, submissionEdit E.^. SubmissionEditTime) let lastEdits = map (bimap E.unValue E.unValue) lastEditValues return (sheet,buddies,oldfiles,lastEdits) let unpackZips = True -- undefined -- TODO ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm unpackZips sheetGrouping $ map E.unValue buddies mCID <- runDB $ do res' <- case res of (FormMissing ) -> return $ FormMissing (FormFailure failmsgs) -> return $ FormFailure failmsgs (FormSuccess (files,[])) -> return $ FormSuccess (files,[]) -- Type change (FormSuccess (files, (map CI.mk -> gEMails@(_:_)))) -- Validate AdHoc Group Members | (Arbitrary {..}) <- sheetGrouping , length gEMails < maxParticipants -> do -- < since submitting user is already accounted for let gemails = map CI.foldedCase gEMails prep :: [(E.Value Text, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map (CI Text) (Maybe (UserId, Bool, Bool)) prep ps = Map.fromList $ map (, Nothing) gEMails ++ [(CI.mk 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_ $ (E.lower_ $ 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 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 = flip Map.foldMapWithKey participants $ \email -> \case Nothing -> [mr $ MsgEMailUnknown $ CI.original email] (Just (_,False,_)) -> [mr $ MsgNotAParticipant (CI.original email) (unTermKey tid) csh] (Just (_,_, True)) -> [mr $ MsgSubmissionAlreadyExistsFor (CI.original email)] _other -> mempty return $ if null failmsgs then FormSuccess (files, foldMap (\(Just (i,_,_)) -> [i]) participants) else FormFailure failmsgs | otherwise -> return $ FormFailure ["Mismatching number of group participants"] case res' of (FormSuccess (files,(setFromList -> adhocIds))) -> do now <- liftIO $ getCurrentTime smid <- do smid <- runConduit $ transPipe lift files .| Conduit.map Left .| sinkSubmission shid uid ((,False) <$> msmid) -- 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 $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID Nothing -> return () mArCid <- fmap ZIPArchiveName <$> traverse encrypt msmid let pageTitle = MsgSubmissionTitle (unTermKey tid) csh shn let formTitle = pageTitle let formText = Nothing :: Maybe UniWorXMessage actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute defaultLayout $ do setTitleI pageTitle $(widgetFile "formPageI18n") [whamlet| $maybe arCid <- mArCid

Archiv $forall (name,time) <- lastEdits
last edited by #{name} at #{formatTimeGerDTlong time} $maybe cid <- mcid

Enthaltene Dateien: $forall (Entity _ File{..}) <- oldfiles #{fileTitle} |] submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File) submissionFileSource submissionID = E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile) E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] return f getSubmissionDownloadSingleR :: CryptoUUIDSubmission -> FilePath -> Handler TypedContent getSubmissionDownloadSingleR cID path = do submissionID <- decrypt cID cID' <- encrypt submissionID runDB $ do isRating <- maybe False (== submissionID) <$> isRatingFile path case isRating of True -> do file <- runMaybeT $ lift . ratingFile cID' =<< MaybeT (getRating submissionID) maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file False -> do results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile) E.where_ (sf E.^. SubmissionFileSubmission E.==. E.val submissionID) E.where_ (f E.^. FileTitle E.==. E.val path) E.where_ . E.not_ . E.isNothing $ f E.^. FileContent E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] return f let fileName = Text.pack $ takeFileName path case results of [Entity _ File{ fileContent = Just c }] -> return $ TypedContent (defaultMimeLookup fileName) (toContent c) _ -> notFound getSubmissionDownloadArchiveR :: ZIPArchiveName SubmissionId -> Handler TypedContent getSubmissionDownloadArchiveR (ZIPArchiveName cID) = do submissionID <- decrypt cID cUUID <- encrypt submissionID respondSourceDB "application/zip" $ do rating <- lift $ getRating submissionID case rating of Nothing -> lift notFound Just rating' -> do let fileEntitySource' :: Source (YesodDB UniWorX) File fileEntitySource' = submissionFileSource submissionID =$= Conduit.map entityVal >> yieldM (ratingFile cID rating') info = ZipInfo { zipComment = Text.encodeUtf8 . tshow $ ciphertext (cUUID :: CryptoUUIDSubmission) } fileEntitySource' =$= produceZip info =$= Conduit.map toFlushBuilder ----------------------------------------------------------------------------------------------- ------------------------- DEMO BELOW submissionTable :: MForm Handler (FormResult [SubmissionId], Widget) submissionTable = do subs <- lift . runDB $ E.select . E.from $ \(sub `E.InnerJoin` sheet `E.InnerJoin` course) -> do E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.on $ sheet E.^. SheetId E.==. sub E.^. SubmissionSheet return (sub, sheet, course) cryptedSubs <- forM subs $ \s@(Entity submissionId _, _, _) -> (,,) <$> encrypt submissionId <*> encrypt submissionId <*> pure s let anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseR courseTerm courseShorthand CourseShowR courseText (_, _, (_, _, Entity _ Course{..})) = toWidget courseName anchorSubmission (_, cUUID, _) = SubmissionDemoR cUUID submissionText (cID, _, _) = toWidget . toPathPiece . CI.foldedCase $ ciphertext cID colonnade = mconcat [ headed "Abgabe-ID" $ anchorCell anchorSubmission submissionText , headed "Kurs" $ anchorCell anchorCourse courseText , headed "Blatt" $ \(_, _, (_, Entity _ Sheet{..}, _)) -> textCell $ sheetName ] toExternal :: (CryptoFileNameSubmission, CryptoUUIDSubmission, a) -> Handler CryptoUUIDSubmission toExternal (_, cID, _) = return cID fromExternal :: CryptoUUIDSubmission -> Handler SubmissionId fromExternal = decrypt headedRowSelector toExternal fromExternal (HA.class_ "table table-striped table-hover") colonnade cryptedSubs getSubmissionListR, postSubmissionListR :: Handler Html getSubmissionListR = postSubmissionListR postSubmissionListR = do ((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderAForm FormStandard $ (,) <$> areq checkBoxField "Dies sind Korrekturen" (Just False) <*> fileAFormReq "Archiv" <* submitButton runDB $ do case uploadResult of FormMissing -> return () FormFailure _ -> addMessage "warning" "Bitte Eingabe korrigieren." FormSuccess (isUpdate, fInfo) -> do userId <- lift requireAuthId let feed :: SubmissionId -> SubmissionContent -> StateT (Map SubmissionId (ResumableSink SubmissionContent (YesodDB UniWorX) SubmissionId)) (YesodDB UniWorX) () feed sId val = do mSink <- gets $ Map.lookup sId sink <- case mSink of Just sink -> return sink Nothing -> do Submission{..} <- lift $ get404 sId return . newResumableSink $ sinkSubmission submissionSheet userId (Just (sId, isUpdate)) sink' <- lift $ yield val ++$$ sink case sink' of Left _ -> error "sinkSubmission returned prematurely" Right nSink -> modify $ Map.insert sId nSink sinkSubmissions :: Sink SubmissionContent (YesodDB UniWorX) () sinkSubmissions = do sinks <- execStateC Map.empty . awaitForever $ \case v@(Right (sId, _)) -> lift $ feed sId v (Left f@File{..}) -> case splitDirectories fileTitle of (cID:rest) | not (null rest) -> do sId <- decrypt (CryptoID $ CI.mk cID :: CryptoFileNameSubmission) lift . feed sId $ Left f{ fileTitle = joinPath rest } | otherwise -> return () [] -> invalidArgs ["Encountered file/directory with empty name"] lift $ mapM_ (void . closeResumableSink) sinks runConduit $ fileSource fInfo =$= void consumeZip =$= extractRatings =$= void sinkSubmissions (subTable, selectEncoding) <- generateFormPost . identifyForm "selection" . withFragment $ submissionTable defaultLayout $(widgetFile "submission-list") postSubmissionDownloadMultiArchiveR :: Handler TypedContent postSubmissionDownloadMultiArchiveR = do ((selectResult, _), _) <- runFormPost . withFragment $ submissionTable case selectResult of FormMissing -> invalidArgs ["Missing submission numbers"] FormFailure errs -> invalidArgs errs FormSuccess ids -> do (dbrunner, cleanup) <- getDBRunner ratedSubmissions <- runDBRunner dbrunner $ do submissions <- selectList [ SubmissionId <-. ids ] [] forM submissions $ \s@(Entity submissionId _) -> maybe (invalidArgs ["Invalid submission numbers"]) (return . (, s)) =<< getRating submissionId (<* cleanup) . respondSource "application/zip" . transPipe (runDBRunner dbrunner) $ do let fileEntitySource' :: (Rating, Entity Submission) -> Source (YesodDB UniWorX) File fileEntitySource' (rating, Entity submissionID Submission{..}) = do cID <- encrypt submissionID let directoryName = CI.foldedCase $ ciphertext (cID :: CryptoFileNameSubmission) fileEntitySource = do submissionFileSource submissionID =$= Conduit.map entityVal yieldM (ratingFile cID rating) withinDirectory f@File{..} = f { fileTitle = directoryName fileTitle } lastEditMb <- lift $ selectList [SubmissionEditSubmission ==. submissionID] [Desc SubmissionEditTime, LimitTo 1] lastEditTime <- case lastEditMb of [(submissionEditTime.entityVal -> time)] -> return time _other -> liftIO getCurrentTime yield $ File { fileModified = lastEditTime , fileTitle = directoryName , fileContent = Nothing } fileEntitySource =$= mapC withinDirectory mapM_ fileEntitySource' ratedSubmissions =$= produceZip def =$= Conduit.map toFlushBuilder getSubmissionDemoR, postSubmissionDemoR :: CryptoUUIDSubmission -> Handler Html getSubmissionDemoR = postSubmissionDemoR postSubmissionDemoR cID = do submissionId <- decrypt cID ((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderAForm FormStandard $ (,) <$> areq checkBoxField "Dies ist eine Korrektur" (Just False) <*> fileAFormReq "Datei" <* submitButton (submission, files) <- runDB $ do submission <- do submission@Submission{..} <- get404 submissionId case uploadResult of FormMissing -> return submission FormFailure _ -> submission <$ addMessage "warning" "Bitte Eingabe korrigieren." FormSuccess (isUpdate, fInfo) -> do userId <- lift requireAuthId let mimeType = defaultMimeLookup (fileName fInfo) source | mimeType == "application/zip" = fileSource fInfo =$= void consumeZip | otherwise = do let fileTitle = Text.unpack $ fileName fInfo fileModified <- liftIO getCurrentTime yieldM $ do fileContent <- Just <$> runConduit (fileSource fInfo =$= foldC) return File{..} submissionId' <- runConduit $ source =$= extractRatings =$= sinkSubmission submissionSheet userId (Just (submissionId, isUpdate)) get404 submissionId' files <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile) E.where_ (sf E.^. SubmissionFileSubmission E.==. E.val submissionId) E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] return (f, sf) return (submission, files) let Rating'{..} = Rating' { ratingPoints = submissionRatingPoints submission , ratingComment = submissionRatingComment submission , ratingTime = submissionRatingTime submission } cID' <- encrypt submissionId let archiveBaseName = CI.foldedCase $ ciphertext (cID' :: CryptoFileNameSubmission) archiveName = archiveBaseName <.> "zip" defaultLayout $(widgetFile "submission")