{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# 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 System.FilePath import Colonnade hiding (bool) import Yesod.Colonnade import qualified Text.Blaze.Html5.Attributes as HA makeSubmissionForm :: Bool -> SheetGroup -> Form (Source Handler File, [Text]) makeSubmissionForm unpackZips grouping = identForm FIDsubmission $ \html -> do flip (renderAForm FormStandard) html $ (,) <$> areq (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing <*> (catMaybes <$> sequenceA [aopt textField (fsm $ MsgSubmissionMember g) Nothing | g <- [1..groupNr] ]) -- TODO: Convenience: preselect last buddies <* submitButton where groupNr | Arbitrary{..} <- grouping = pred maxParticipants -- pred to account for the person submitting | otherwise = 0 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{..}) <- runDB $ do sheet@(Entity shid _) <- 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.^. SubmissionUserSubmissionId) E.where_ $ submissionUser E.^. SubmissionUserUserId E.==. E.val uid E.&&. submission E.^. SubmissionSheetId E.==. E.val shid return $ submission E.^. SubmissionId $logDebugS "Submission.DUPLICATENEW" (tshow submissions) case submissions of [] -> return shid (E.Value smid:_) -> do cID <- encrypt smid addMessageI "info" $ MsgSubmissionAlreadyExists redirect $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID return sheet (Just smid) -> do shid' <- submissionSheetId <$> get404 smid when (shid /= shid') $ invalidArgsI [MsgSubmissionWrongSheet] return sheet let unpackZips = True -- undefined -- TODO ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm unpackZips sheetGrouping 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.^. CourseParticipantUserId E.&&. courseParticipant E.^. CourseParticipantCourseId E.==. E.val sheetCourseId return $ E.countRows E.>. E.val (0 :: Int64) hasSubmitted = E.sub_select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do E.on $ submissionUser E.^. SubmissionUserSubmissionId E.==. submission E.^. SubmissionId E.where_ $ submissionUser E.^. SubmissionUserUserId E.==. user E.^. UserId E.&&. submission E.^. SubmissionSheetId 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) insertUnique $ SubmissionUser uid smid -- insert $ SubmissionEdit uid now smid -- sinkSubmission already does this -- 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.^. SubmissionGroupUserSubmissionGroupId E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroupId E.==. submissionGroup E.^. SubmissionGroupId E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUserId E.==. E.val uid E.&&. submissionGroup E.^. SubmissionGroupCourseId E.==. E.val sheetCourseId return $ submissionGroupUser' E.^. SubmissionGroupUserUserId -- SubmissionUser for all group members (pre-registered & ad-hoc) forM_ (groupUids `Set.union` adhocIds) $ \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 () 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") ----------------------------------------------------------------------------------------------- ------------------------- 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.^. SheetCourseId E.on $ sheet E.^. SheetId E.==. sub E.^. SubmissionSheetId return (sub, sheet, course) cryptedSubs <- forM subs $ \s@(Entity submissionId _, _, _) -> (,,) <$> encrypt submissionId <*> encrypt submissionId <*> pure s let anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseR courseTermId 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 submissionSheetId 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") 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.^. SubmissionFileFileId) E.where_ (sf E.^. SubmissionFileSubmissionId 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 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.^. SubmissionFileFileId) E.where_ $ sf E.^. SubmissionFileSubmissionId E.==. E.val submissionID E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] return f 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 getSubmissionDownloadArchiveR :: FilePath -> Handler TypedContent getSubmissionDownloadArchiveR path = do let (baseName, ext) = splitExtension path cID :: CryptoFileNameSubmission cID = CryptoID $ CI.mk baseName unless (ext == ".zip") notFound 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 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 submissionSheetId 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.^. SubmissionFileFileId) E.where_ (sf E.^. SubmissionFileSubmissionId 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")