diff --git a/package.yaml b/package.yaml index 718e77e3b..eb57855af 100644 --- a/package.yaml +++ b/package.yaml @@ -69,6 +69,7 @@ dependencies: - esqueleto - mime-types - generic-deriving +- blaze-html # The library contains all of our application code. The executable # defined below is just a thin wrapper. diff --git a/routes b/routes index d10b4dd13..25e51ee2a 100644 --- a/routes +++ b/routes @@ -20,6 +20,7 @@ /submission SubmissionListR GET /submission/#CryptoUUIDSubmission SubmissionR GET POST +/submissions.zip SubmissionDownloadMultiArchiveR POST !/submission/archive/#FilePath SubmissionDownloadArchiveR GET !/submission/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET diff --git a/src/Foundation.hs b/src/Foundation.hs index 726a21146..b162056aa 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -177,6 +177,7 @@ instance Yesod UniWorX where isAuthorized (SubmissionR _) _ = return Authorized isAuthorized (SubmissionDownloadSingleR _ _) _ = return Authorized isAuthorized (SubmissionDownloadArchiveR _) _ = return Authorized + isAuthorized SubmissionDownloadMultiArchiveR _ = return Authorized -- TODO: change to Assistants isAuthorized TermEditR _ = return Authorized isAuthorized (TermEditExistR _) _ = return Authorized diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 9cded6284..8a38fe96d 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -33,15 +33,43 @@ import qualified Data.Conduit.List as Conduit import System.FilePath +import Colonnade +import Yesod.Colonnade +import qualified Text.Blaze.Html5.Attributes as HA + +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) + + cIDKey <- getsYesod appCryptoIDKey + cryptedSubs <- forM subs $ \s@(Entity submissionId _, _, _) -> + (,,) <$> Base32.encrypt cIDKey submissionId <*> UUID.encrypt cIDKey submissionId <*> pure s + + let + anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseShowR (unTermKey courseTermId) courseShorthand + courseText (_, _, (_, _, Entity _ Course{..})) = toWidget courseName + anchorSubmission (_, cUUID, _) = SubmissionR 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 = UUID.decrypt cIDKey + headedRowSelector toExternal fromExternal (HA.class_ "table table-striped table-hover") colonnade cryptedSubs + getSubmissionListR :: Handler Html getSubmissionListR = do - entityList <- runDB $ selectList [] [] - cIDKey <- getsYesod appCryptoIDKey - let - cryptEntity :: Entity Submission -> Handler (CryptoUUIDSubmission, Submission) - cryptEntity (Entity key val) = (, val) <$> UUID.encrypt cIDKey key - submissionList <- mapM cryptEntity entityList + (submissionTable, selectEncoding) <- generateFormPost . withFragment $ submissionTable + defaultLayout $(widgetFile "submission-list") getSubmissionDownloadSingleR :: CryptoUUIDSubmission -> FilePath -> Handler TypedContent @@ -71,6 +99,56 @@ getSubmissionDownloadSingleR cID path = do [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 <- lift $ do + cIDKey <- getsYesod appCryptoIDKey + Base32.encrypt cIDKey submissionID + + let + directoryName = Text.unpack . CI.foldedCase $ ciphertext (cID :: CryptoFileNameSubmission) + + fileEntitySource = do + submissionFileSource submissionID =$= Conduit.map entityVal + yieldM (ratingFile cID rating) + + withinDirectory f@File{..} = f { fileTitle = directoryName fileTitle } + + yield $ File + { fileModified = submissionChanged + , 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 @@ -85,13 +163,8 @@ getSubmissionDownloadArchiveR path = do case rating of Nothing -> lift notFound Just rating' -> do - let fileEntitySource = 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_ . E.not_ $ sf E.^. SubmissionFileIsDeletion - E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] - return f - fileEntitySource' :: Source (YesodDB UniWorX) File - fileEntitySource' = fileEntitySource =$= Conduit.map entityVal >> yieldM (ratingFile cID rating') + 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 diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index b6c116086..277310908 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} module Handler.Utils ( module Handler.Utils @@ -16,6 +17,12 @@ import Handler.Utils.Zip as Handler.Utils import Handler.Utils.Rating as Handler.Utils import Handler.Utils.Submission as Handler.Utils +import Text.Blaze (Markup) + tickmark :: IsString a => a tickmark = fromString "✔" + +withFragment :: ( Monad m + ) => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ()) +withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >> widget) diff --git a/src/Handler/Utils/Table.hs b/src/Handler/Utils/Table.hs index 3ed97eb88..6679f2f8b 100644 --- a/src/Handler/Utils/Table.hs +++ b/src/Handler/Utils/Table.hs @@ -1,5 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeFamilies #-} module Handler.Utils.Table where -- General Utilities for Tables @@ -8,11 +10,16 @@ import Import hiding ((<>)) -- import Data.Monoid ((<>)) import Data.Profunctor +import Control.Monad.Except + import Text.Blaze as B import Colonnade import Yesod.Colonnade +import Data.List ((!!)) +import Data.Either + -- Table design tableDefault :: Attribute @@ -34,4 +41,50 @@ encodeHeadedWidgetTableNumbered attrs colo tdata = numberCol :: Colonnade Headed (Int,a) (WidgetT site IO ()) numberCol = headed "Nr" (fromString.show.fst) +headedRowSelector :: ( PathPiece b + , Eq b + ) + => (a -> Handler b) + -> (b -> Handler c) + -> Attribute + -> Colonnade Headed a (Cell UniWorX) + -> [a] + -> MForm Handler (FormResult [c], Widget) +headedRowSelector toExternal fromExternal attrs colonnade tdata = do + externalIds <- mapM (lift . toExternal) tdata + + let + checkbox externalId = Field parse view UrlEncoded + where + parse [] _ = return $ Right Nothing + parse optlist _ = runExceptT $ do + externalIds <- maybe (throwError "Error parsing values") return $ mapM fromPathPiece optlist + case () of + _ | externalId `elem` externalIds + -> Just <$> (lift $ fromExternal externalId) + | otherwise + -> return Nothing + + view _ name attrs val _ = do + [whamlet| +