Download ratings

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
+  runDB $ do
-    E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFileId)
+    isRating <- maybe False (== submissionID) <$> isRatingFile path
-    E.where_ (sf E.^. SubmissionFileSubmissionId E.==. E.val submissionID)
+    case isRating of
-    E.where_ (f E.^. FileTitle E.==. E.val path)
+      True  -> do
-    E.where_ . E.not_ . E.isNothing $ f E.^. FileContent
+        file <- (ratingFile cID' =<<) <$> getRating submissionID
-    return f
+        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
+        let fileName = Text.pack $ takeFileName path
-  case results of
+        case results of
-    [Entity _ File{ fileContent = Just c }] -> return $ TypedContent (defaultMimeLookup fileName) (toContent c)
+          [Entity _ File{ fileContent = Just c }] -> return $ TypedContent (defaultMimeLookup fileName) (toContent c)
-    _ -> notFound
+          _ -> 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]
+    rating <- getRating submissionID
-    unless (exists == 1) notFound
+    case rating of
-    sqlBackend <- ask
+      Nothing -> notFound
-    let fileEntitySource = E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
+      Just rating' -> do
-          E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFileId)
+        sqlBackend <- ask
-          return f
+        let fileEntitySource = E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
-        fileEntitySource' :: Source (ResourceT IO) File
+              E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFileId)
-        fileEntitySource' = runReaderC sqlBackend fileEntitySource =$= Conduit.map entityVal
+              return f
-        info = ZipInfo { zipComment = Text.encodeUtf8 . tshow $ ciphertext (cUUID :: CryptoUUIDSubmission) }
+            fileEntitySource' :: Source (ResourceT IO) File
-    return . TypedContent "application/zip" . toContent $ fileEntitySource' =$= produceZip info
+            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

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
+  , ratingValues :: Rating'
-  , ratingComment :: Maybe Text
-  , ratingPoints :: Maybe Points
   } deriving (Read, Show, Eq, Generic, Typeable)
 
-type Rating' = ( Maybe Points
+data Rating' = Rating'
-               , Maybe Text -- ^ Rating comment
+  { 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
+  let query = E.select . E.from $ \(submission `E.InnerJoin` sheet `E.InnerJoin` course) -> do
-  Sheet{ sheetCourseId, sheetName = ratingSheetName } <- MaybeT $ get submissionSheetId
+        E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourseId
-  Course{ courseName = ratingCourseName } <- MaybeT $ get sheetCourseId
+        E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheetId
-  cIDKey <- getsYesod appCryptoIDKey
-  ratingSubmissionId <- Base32.encrypt cIDKey submissionId
-  return Rating{..}
 
-formatRating :: Rating -> Lazy.ByteString
+        E.where_ $ submission E.^. SubmissionId E.==. E.val submissionId
-formatRating Rating{..} = let
+
+        -- 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'
+ratingFile :: CryptoFileNameSubmission -> Rating -> Maybe File
-parseRating input = do
+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
+      , isJust fileContent
-        -> yieldM $ Right . (sId, ) <$> parseRating content'
+        -> yieldM $ Right . (sId, ) <$> parseRating f
       | otherwise -> yield $ Left f
 
 isRatingFile :: ( MonadHandler m
-            , HandlerSite m ~ UniWorX
+                , HandlerSite m ~ UniWorX
-            , MonadCatch m
+                , MonadCatch m
-            ) => FilePath -> m (Maybe SubmissionId)
+                ) => 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{..}

templates/submission.hamlet

@@ -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>Bewertet
-      <td>#{tshow points}
+      <td>#{tshow ratingTime'}
-    <tr>
+    $maybe points <- ratingPoints
-      <td>Kommentar
+      <tr>
-      <td>#{text}
+        <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)
+        <span .badge>Korrigiert
-      <br>
+      
-      $maybe content <- fileContent file
-        <pre>
-          #{decodeUtf8 content}
-      $nothing
-        This is a directory