diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs
index 52d9633b8..cd932a393 100644
--- a/src/Handler/Submission.hs
+++ b/src/Handler/Submission.hs
@@ -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
diff --git a/src/Handler/Utils/Zip/Rating.hs b/src/Handler/Utils/Zip/Rating.hs
index 1cd1bd9fb..9570a9089 100644
--- a/src/Handler/Utils/Zip/Rating.hs
+++ b/src/Handler/Utils/Zip/Rating.hs
@@ -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{..}
diff --git a/templates/submission.hamlet b/templates/submission.hamlet
index 41274cdb6..38ec2baed 100644
--- a/templates/submission.hamlet
+++ b/templates/submission.hamlet
@@ -1,34 +1,38 @@
+ #{tshow submissionID}
#{tshow submission}