Download ratings
This commit is contained in:
Gregor Kleen
parent
b552e2a0e3
commit
252168e61c
@ -44,18 +44,26 @@ getSubmissionDownloadSingleR :: CryptoUUIDSubmission -> FilePath -> Handler Type
|
||||
getSubmissionDownloadSingleR cID path = do
|
||||
cIDKey <- getsYesod appCryptoIDKey
|
||||
submissionID <- UUID.decrypt cIDKey cID
|
||||
cID' <- Base32.encrypt cIDKey submissionID
|
||||
|
||||
results <- runDB . E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOn [E.don $ 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
|
||||
return f
|
||||
runDB $ do
|
||||
isRating <- maybe False (== submissionID) <$> isRatingFile path
|
||||
case isRating of
|
||||
True -> do
|
||||
file <- (ratingFile cID' =<<) <$> getRating submissionID
|
||||
maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file
|
||||
False -> do
|
||||
results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOn [E.don $ 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
|
||||
return f
|
||||
|
||||
let fileName = Text.pack $ takeFileName path
|
||||
case results of
|
||||
[Entity _ File{ fileContent = Just c }] -> return $ TypedContent (defaultMimeLookup fileName) (toContent c)
|
||||
_ -> notFound
|
||||
let fileName = Text.pack $ takeFileName path
|
||||
case results of
|
||||
[Entity _ File{ fileContent = Just c }] -> return $ TypedContent (defaultMimeLookup fileName) (toContent c)
|
||||
_ -> notFound
|
||||
|
||||
getSubmissionDownloadArchiveR :: FilePath -> Handler TypedContent
|
||||
getSubmissionDownloadArchiveR path = do
|
||||
@ -67,16 +75,18 @@ getSubmissionDownloadArchiveR path = do
|
||||
submissionID <- Base32.decrypt cIDKey cID
|
||||
cUUID <- UUID.encrypt cIDKey submissionID
|
||||
runDB $ do
|
||||
exists <- count [SubmissionId ==. submissionID]
|
||||
unless (exists == 1) notFound
|
||||
sqlBackend <- ask
|
||||
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)
|
||||
return f
|
||||
fileEntitySource' :: Source (ResourceT IO) File
|
||||
fileEntitySource' = runReaderC sqlBackend fileEntitySource =$= Conduit.map entityVal
|
||||
info = ZipInfo { zipComment = Text.encodeUtf8 . tshow $ ciphertext (cUUID :: CryptoUUIDSubmission) }
|
||||
return . TypedContent "application/zip" . toContent $ fileEntitySource' =$= produceZip info
|
||||
rating <- getRating submissionID
|
||||
case rating of
|
||||
Nothing -> notFound
|
||||
Just rating' -> do
|
||||
sqlBackend <- ask
|
||||
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)
|
||||
return f
|
||||
fileEntitySource' :: Source (ResourceT IO) File
|
||||
fileEntitySource' = runReaderC sqlBackend fileEntitySource =$= Conduit.map entityVal >> maybe (return ()) yield (ratingFile cID rating')
|
||||
info = ZipInfo { zipComment = Text.encodeUtf8 . tshow $ ciphertext (cUUID :: CryptoUUIDSubmission) }
|
||||
return . TypedContent "application/zip" . toContent $ fileEntitySource' =$= produceZip info
|
||||
|
||||
getSubmissionR, postSubmissionR :: CryptoUUIDSubmission -> Handler Html
|
||||
getSubmissionR = postSubmissionR
|
||||
@ -91,7 +101,11 @@ postSubmissionR cID = do
|
||||
return $ (submission, files)
|
||||
|
||||
let
|
||||
rating = (,) <$> submissionRatingPoints submission <*> submissionRatingComment submission
|
||||
rating@(Rating'{..}) = Rating'
|
||||
{ ratingPoints = submissionRatingPoints submission
|
||||
, ratingComment = submissionRatingComment submission
|
||||
, ratingTime = submissionRatingTime submission
|
||||
}
|
||||
|
||||
cID' <- Base32.encrypt cIDKey submissionID
|
||||
let
|
||||
|
||||
@ -12,11 +12,13 @@
|
||||
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
||||
|
||||
module Handler.Utils.Zip.Rating
|
||||
( Rating(..)
|
||||
( Rating(..), Rating'(..)
|
||||
, getRating
|
||||
, formatRating
|
||||
, ratingFile
|
||||
, RatingException(..)
|
||||
, UnicodeException(..)
|
||||
, isRatingFile
|
||||
, parseRating
|
||||
, extractRatings
|
||||
) where
|
||||
@ -39,6 +41,7 @@ import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Data.ByteString.Lazy as Lazy (ByteString)
|
||||
import qualified Data.ByteString.Lazy as Lazy.ByteString
|
||||
|
||||
import Text.Read (readEither)
|
||||
|
||||
@ -49,6 +52,8 @@ import CryptoID.Base32 as Base32
|
||||
|
||||
import System.FilePath
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
|
||||
instance HasResolution prec => Pretty (Fixed prec) where
|
||||
pretty = pretty . show
|
||||
@ -60,19 +65,20 @@ instance Pretty x => Pretty (CI x) where
|
||||
data Rating = Rating
|
||||
{ ratingCourseName :: Text
|
||||
, ratingSheetName :: Text
|
||||
, ratingSubmissionId :: CryptoFileNameSubmission
|
||||
, ratingComment :: Maybe Text
|
||||
, ratingPoints :: Maybe Points
|
||||
, ratingValues :: Rating'
|
||||
} deriving (Read, Show, Eq, Generic, Typeable)
|
||||
|
||||
type Rating' = ( Maybe Points
|
||||
, Maybe Text -- ^ Rating comment
|
||||
)
|
||||
data Rating' = Rating'
|
||||
{ ratingPoints :: Maybe Points
|
||||
, ratingComment :: Maybe Text
|
||||
, ratingTime :: Maybe UTCTime
|
||||
} deriving (Read, Show, Eq, Generic, Typeable)
|
||||
|
||||
data RatingException = RatingNotUnicode UnicodeException -- ^ Rating failed to parse as unicode
|
||||
| RatingMissingSeparator -- ^ Could not split rating header from comments
|
||||
| RatingMultiple -- ^ Encountered multiple point values in rating
|
||||
| RatingInvalid String -- ^ Failed to parse rating point value
|
||||
| RatingFileIsDirectory -- ^ We do not expect this to, it's included for totality
|
||||
deriving (Show, Eq, Generic, Typeable)
|
||||
|
||||
instance Exception RatingException
|
||||
@ -80,15 +86,31 @@ instance Exception RatingException
|
||||
|
||||
getRating :: SubmissionId -> YesodDB UniWorX (Maybe Rating)
|
||||
getRating submissionId = runMaybeT $ do
|
||||
Submission{ submissionSheetId, submissionRatingComment = ratingComment, submissionRatingPoints = ratingPoints } <- MaybeT $ get submissionId
|
||||
Sheet{ sheetCourseId, sheetName = ratingSheetName } <- MaybeT $ get submissionSheetId
|
||||
Course{ courseName = ratingCourseName } <- MaybeT $ get sheetCourseId
|
||||
cIDKey <- getsYesod appCryptoIDKey
|
||||
ratingSubmissionId <- Base32.encrypt cIDKey submissionId
|
||||
return Rating{..}
|
||||
let query = E.select . E.from $ \(submission `E.InnerJoin` sheet `E.InnerJoin` course) -> do
|
||||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourseId
|
||||
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheetId
|
||||
|
||||
formatRating :: Rating -> Lazy.ByteString
|
||||
formatRating Rating{..} = let
|
||||
E.where_ $ submission E.^. SubmissionId E.==. E.val submissionId
|
||||
|
||||
-- Yes, we can only pass a tuple through 'E.select'
|
||||
return ( course E.^. CourseName
|
||||
, sheet E.^. SheetName
|
||||
, submission E.^. SubmissionRatingPoints
|
||||
, submission E.^. SubmissionRatingComment
|
||||
, submission E.^. SubmissionRatingTime
|
||||
)
|
||||
|
||||
[ ( E.unValue -> ratingCourseName
|
||||
, E.unValue -> ratingSheetName
|
||||
, E.unValue -> ratingPoints
|
||||
, E.unValue -> ratingComment
|
||||
, E.unValue -> ratingTime
|
||||
) ] <- lift query
|
||||
|
||||
return Rating{ ratingValues = Rating'{..}, .. }
|
||||
|
||||
formatRating :: CryptoFileNameSubmission -> Rating -> Lazy.ByteString
|
||||
formatRating cID Rating{ ratingValues = Rating'{..}, ..} = let
|
||||
doc = renderPretty 1 45 $ foldr (<$$>) mempty
|
||||
[ "= Bitte nur Bewertung und Kommentare ändern ="
|
||||
, "============================================="
|
||||
@ -99,16 +121,24 @@ formatRating Rating{..} = let
|
||||
[ "Veranstaltung:" <+> pretty ratingCourseName
|
||||
, "Blatt:" <+> pretty ratingSheetName
|
||||
]
|
||||
, "Abgabe-Id:" <+> pretty (ciphertext ratingSubmissionId)
|
||||
, "Abgabe-Id:" <+> pretty (ciphertext cID)
|
||||
, "============================================="
|
||||
, "Bewertung:" <+> pretty ratingPoints
|
||||
, "=========== Beginn der Kommentare ==========="
|
||||
, pretty ratingComment
|
||||
]
|
||||
in Lazy.Text.encodeUtf8 $ displayT doc
|
||||
in Lazy.Text.encodeUtf8 . (<> "\n") $ displayT doc
|
||||
|
||||
parseRating :: MonadThrow m => ByteString -> m Rating'
|
||||
parseRating input = do
|
||||
ratingFile :: CryptoFileNameSubmission -> Rating -> Maybe File
|
||||
ratingFile cID rating@(Rating{ ratingValues = Rating'{..}, .. }) = do
|
||||
fileModified <- ratingTime
|
||||
let
|
||||
fileTitle = "bewertung_" <> (Text.unpack . CI.foldedCase $ ciphertext (cID :: CryptoFileNameSubmission)) <.> "txt"
|
||||
fileContent = Just . Lazy.ByteString.toStrict $ formatRating cID rating
|
||||
return File{..}
|
||||
|
||||
parseRating :: MonadThrow m => File -> m Rating'
|
||||
parseRating File{ fileContent = Just input, .. } = do
|
||||
inputText <- either (throw . RatingNotUnicode) return $ Text.decodeUtf8' input
|
||||
let
|
||||
(headerLines, commentLines) = break (sep `Text.isInfixOf`) $ Text.lines inputText
|
||||
@ -119,7 +149,7 @@ parseRating input = do
|
||||
(_:commentLines') -> return . Text.strip $ Text.unlines commentLines'
|
||||
_ -> throw RatingMissingSeparator
|
||||
let
|
||||
comment
|
||||
ratingComment
|
||||
| Text.null comment' = Nothing
|
||||
| otherwise = Just comment'
|
||||
ratingLine' <- case ratingLines of
|
||||
@ -128,10 +158,11 @@ parseRating input = do
|
||||
let
|
||||
(_, ratingLine) = Text.breakOnEnd rating ratingLine'
|
||||
ratingStr = Text.unpack $ Text.strip ratingLine
|
||||
rating <- case () of
|
||||
ratingPoints <- case () of
|
||||
_ | null ratingStr -> return Nothing
|
||||
| otherwise -> either (throw . RatingInvalid) return $ Just <$> readEither ratingStr
|
||||
return (rating, comment)
|
||||
return Rating'{ ratingTime = Just fileModified, .. }
|
||||
parseRating _ = throwM RatingFileIsDirectory
|
||||
|
||||
|
||||
extractRatings :: ( MonadHandler m
|
||||
@ -143,14 +174,14 @@ extractRatings = void . runMaybeT $ do
|
||||
msId <- isRatingFile fileTitle
|
||||
lift $ case () of
|
||||
_ | Just sId <- msId
|
||||
, Just content' <- fileContent
|
||||
-> yieldM $ Right . (sId, ) <$> parseRating content'
|
||||
, isJust fileContent
|
||||
-> yieldM $ Right . (sId, ) <$> parseRating f
|
||||
| otherwise -> yield $ Left f
|
||||
|
||||
isRatingFile :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, MonadCatch m
|
||||
) => FilePath -> m (Maybe SubmissionId)
|
||||
, HandlerSite m ~ UniWorX
|
||||
, MonadCatch m
|
||||
) => FilePath -> m (Maybe SubmissionId)
|
||||
isRatingFile fName
|
||||
| Just cID <- isRatingFile' fName = do
|
||||
cIDKey <- getsYesod appCryptoIDKey
|
||||
@ -164,7 +195,7 @@ isRatingFile fName
|
||||
decryptErrors err = throwM err
|
||||
|
||||
isRatingFile' :: FilePath -> Maybe CryptoFileNameSubmission
|
||||
isRatingFile' (takeFileName -> fName)
|
||||
isRatingFile' (normalise -> fName)
|
||||
| (bName, ".txt") <- splitExtension fName
|
||||
, Just (CI.mk . Text.pack -> ciphertext) <- stripPrefix "bewertung_" bName
|
||||
= Just CryptoID{..}
|
||||
|
||||
@ -1,34 +1,38 @@
|
||||
<pre style="display:none">
|
||||
#{tshow submissionID}
|
||||
#{tshow submission}
|
||||
|
||||
<table .table .table-striped>
|
||||
$maybe (points, text) <- rating
|
||||
$maybe ratingTime' <- ratingTime
|
||||
<tr>
|
||||
<td>Punkte
|
||||
<td>#{tshow points}
|
||||
<tr>
|
||||
<td>Kommentar
|
||||
<td>#{text}
|
||||
<td>Bewertet
|
||||
<td>#{tshow ratingTime'}
|
||||
$maybe points <- ratingPoints
|
||||
<tr>
|
||||
<td>Punkte
|
||||
<td>#{tshow points}
|
||||
$maybe comment <- ratingComment
|
||||
<tr>
|
||||
<td>Kommentar
|
||||
<td>
|
||||
<pre style="margin-bottom:0">#{comment}
|
||||
$nothing
|
||||
<tr>
|
||||
<td colspan="2">Noch nicht bewertet
|
||||
|
||||
<a href=@{SubmissionDownloadArchiveR archiveName} download>Submission archive
|
||||
|
||||
<ul>
|
||||
$forall (Entity _ file, Entity _ sFile) <- files
|
||||
<li>
|
||||
<pre style="display:none">
|
||||
#{tshow file}
|
||||
<pre style="display:none">
|
||||
#{tshow sFile}
|
||||
|
||||
<b>#{fileTitle file}
|
||||
<div .container-fluid>
|
||||
<div .row>
|
||||
<div .col-md-6 .text-center style="margin-bottom:21px">
|
||||
<a href=@{SubmissionDownloadArchiveR archiveName} download .btn .btn-lg .btn-default>
|
||||
<span .glyphicon .glyphicon-cloud-download aria-hidden="true"> ZIP-Archive
|
||||
<div .col-md-6 .panel .panel-default>
|
||||
<div .panel-body>
|
||||
Upload goes here…
|
||||
|
||||
<div .list-group>
|
||||
$forall (Entity _ file, Entity _ sFile) <- files
|
||||
<a href=@{SubmissionDownloadSingleR cID $ fileTitle file} download .list-group-item>
|
||||
#{fileTitle file}
|
||||
$if submissionFileIsUpdate sFile
|
||||
(Korrektur)
|
||||
<br>
|
||||
$maybe content <- fileContent file
|
||||
<pre>
|
||||
#{decodeUtf8 content}
|
||||
$nothing
|
||||
This is a directory
|
||||
<span .badge>Korrigiert
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user