diff --git a/package.yaml b/package.yaml index 6f8c2b650..bb170951a 100644 --- a/package.yaml +++ b/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. diff --git a/src/Handler/Utils/Zip/Rating.hs b/src/Handler/Utils/Zip/Rating.hs index 06a43c2da..1f48e0e5e 100644 --- a/src/Handler/Utils/Zip/Rating.hs +++ b/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 @@ -30,9 +33,11 @@ import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text 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 isRating = void . runMaybeT $ do +extractRatings :: ( MonadHandler m + , 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 diff --git a/stack.yaml b/stack.yaml index b4070ab13..098f9e359 100644 --- a/stack.yaml +++ b/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 -- cryptoids-0.1.0 +- uuid-crypto-1.1.1.0 +- cryptoids-0.2.0.0 - cryptoids-types-0.0.0 resolver: lts-9.3