Finish filtering of ratings from a stream of Files

package.yaml

@@ -65,6 +65,7 @@ dependencies:
 - cryptoids
 - binary
 - mtl
+- sandi
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.

src/Handler/Utils/Zip/Rating.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -22,6 +23,8 @@ module Handler.Utils.Zip.Rating
 
 import Import hiding ((</>))
 
+import qualified Codec.Binary.Base32 as Base32
+
 import Text.PrettyPrint.Leijen.Text hiding ((<$>))
 
 import Control.Monad.Trans.Maybe
@@ -33,6 +36,8 @@ import Data.Text.Encoding.Error (UnicodeException(..))
   
 import qualified Data.Text.Lazy.Encoding as Lazy.Text
 
+import qualified Data.CaseInsensitive as CI
+
 import qualified Data.ByteString.Lazy as Lazy (ByteString)
 import qualified Data.ByteString.Lazy as Lazy.ByteString
 
@@ -41,9 +46,10 @@ import Text.Read (readEither)
 import GHC.Generics (Generic)
 import Data.Typeable (Typeable)
 
-import Data.Binary (encode, decode)
 import qualified Data.CryptoID.Poly as Poly
 
+import System.FilePath
+
 
 instance HasResolution prec => Pretty (Fixed prec) where
   pretty = pretty . show
@@ -52,7 +58,7 @@ instance HasResolution prec => Pretty (Fixed prec) where
 data Rating = Rating
   { ratingCourseName :: Text
   , ratingSheetName :: Text
-  , ratingSubmissionId :: CryptoIDSubmission ByteString -- ^ 'SubmissionId'
+  , ratingSubmissionId :: CryptoIDSubmission String -- ^ 'SubmissionId'
   , ratingComment :: Maybe Text
   , ratingPoints :: Maybe Points
   } deriving (Read, Show, Eq, Generic, Typeable)
@@ -76,8 +82,10 @@ getRating submissionId = runMaybeT $ do
   Sheet{ sheetCourseId, sheetName = ratingSheetName } <- MaybeT $ get submissionSheetId
   Course{ courseName = ratingCourseName } <- MaybeT $ get sheetCourseId
   cIDKey <- getsYesod appCryptoIDKey
-  ratingSubmissionId <- Poly.encrypt cIDKey . Lazy.ByteString.toStrict $ encode submissionId
+  ratingSubmissionId <- Poly.encrypt base32 cIDKey submissionId
   return Rating{..}
+  where
+    base32 = return . CI.foldCase . Text.unpack . Text.dropWhileEnd (== '=') . Text.decodeUtf8 . Base32.encode
 
 formatRating :: Rating -> Lazy.ByteString
 formatRating Rating{..} = let
@@ -91,7 +99,7 @@ formatRating Rating{..} = let
       [ "Veranstaltung:" <+> pretty ratingCourseName
       , "Blatt:" <+> pretty ratingSheetName
       ]
-    , "Abgabe-Id:" <+> pretty (show ratingSubmissionId) -- FIXME
+    , "Abgabe-Id:" <+> pretty (ciphertext ratingSubmissionId)
     , "============================================="
     , "Bewertung:" <+> pretty ratingPoints
     , "=========== Beginn der Kommentare ==========="
@@ -126,11 +134,40 @@ parseRating input = do
   return (rating, comment)
 
 
-extractRatings :: MonadThrow m => (FilePath -> Maybe SubmissionId) -> Conduit File m (Either File (SubmissionId, Rating'))
+extractRatings :: ( MonadHandler m
-extractRatings isRating = void . runMaybeT $ do
+                  , HandlerSite m ~ UniWorX
+                  , MonadCatch m
+                  ) => Conduit File m (Either File (SubmissionId, Rating'))
+extractRatings = void . runMaybeT $ do
   f@(File{..}) <- MaybeT await
+  msId <- isRatingFile fileTitle
   lift $ case () of
-    _ | Just sId <- isRating fileTitle
+    _ | Just sId <- msId
       , Just content' <- fileContent
         -> yieldM $ Right . (sId, ) <$> parseRating content'
       | otherwise -> yield $ Left f
+
+isRatingFile :: ( MonadHandler m
+            , HandlerSite m ~ UniWorX
+            , MonadCatch m
+            ) => FilePath -> m (Maybe SubmissionId)
+isRatingFile fName
+  | Just cID <- isRatingFile' fName = do
+      cIDKey <- getsYesod appCryptoIDKey
+      (Just <$> Poly.decrypt unbase32 cIDKey cID) `catch` decryptErrors
+  | otherwise = return Nothing
+  where
+    unbase32 = either (const $ throwM CiphertextConversionFailed) return . Base32.decode . Text.encodeUtf8 . Text.pack . toUpper . (<> "===")
+
+    decryptErrors CiphertextConversionFailed = return Nothing
+    decryptErrors InvalidNamespaceDetected   = return Nothing
+    decryptErrors (DeserializationError _)   = return Nothing
+    decryptErrors err                        = throwM err
+
+isRatingFile' :: FilePath -> Maybe (CryptoIDSubmission String)
+isRatingFile' (takeFileName -> fName)
+  | (bName, ".txt") <- splitExtension fName
+  , Just ciphertext <- stripPrefix "bewertung_" bName
+  = Just CryptoID{..}
+  | otherwise
+  = Nothing

stack.yaml

@@ -10,7 +10,7 @@ extra-deps:
 - colonnade-1.1.1
 - yesod-colonnade-1.1.0
 - zip-stream-0.1.0.1
-- uuid-crypto-1.1.0
+- uuid-crypto-1.1.1.0
-- cryptoids-0.1.0
+- cryptoids-0.2.0.0
 - cryptoids-types-0.0.0
 resolver: lts-9.3