From 1afc2b4bad1eda2203a0e701aa419d3a7f5e1842 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 12 Oct 2017 19:43:41 +0200 Subject: [PATCH] Clean up structure --- src/Handler/Utils.hs | 3 +- src/Handler/Utils/Rating.hs | 208 ++++++++++++++++++ .../Utils/{Zip/Rating.hs => Submission.hs} | 196 +---------------- 3 files changed, 215 insertions(+), 192 deletions(-) create mode 100644 src/Handler/Utils/Rating.hs rename src/Handler/Utils/{Zip/Rating.hs => Submission.hs} (58%) diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 27d04a8b0..b6c116086 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -13,7 +13,8 @@ import Handler.Utils.Form as Handler.Utils import Handler.Utils.Table as Handler.Utils import Handler.Utils.Zip as Handler.Utils -import Handler.Utils.Zip.Rating as Handler.Utils +import Handler.Utils.Rating as Handler.Utils +import Handler.Utils.Submission as Handler.Utils tickmark :: IsString a => a diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs new file mode 100644 index 000000000..696cbd2b6 --- /dev/null +++ b/src/Handler/Utils/Rating.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +module Handler.Utils.Rating + ( Rating(..), Rating'(..) + , getRating + , formatRating + , ratingFile + , RatingException(..) + , UnicodeException(..) + , isRatingFile + , parseRating + , SubmissionContent + , extractRatings + ) where + +import Import hiding (()) + + +import Text.PrettyPrint.Leijen.Text hiding ((<$>)) + +import Control.Monad.Trans.Maybe + +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 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) + +import GHC.Generics (Generic) +import Data.Typeable (Typeable) + +import CryptoID.Base32 as Base32 + +import System.FilePath + +import qualified Database.Esqueleto as E + +import qualified Data.Conduit.List as Conduit + + +instance HasResolution prec => Pretty (Fixed prec) where + pretty = pretty . show + +instance Pretty x => Pretty (CI x) where + pretty = pretty . CI.original + + +data Rating = Rating + { ratingCourseName :: Text + , ratingSheetName :: Text + , ratingValues :: Rating' + } deriving (Read, Show, Eq, Generic, Typeable) + +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 + + +getRating :: SubmissionId -> YesodDB UniWorX (Maybe Rating) +getRating submissionId = runMaybeT $ do + 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 + + 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 =" + , "=============================================" + , "========== UniWorx Bewertungsdatei ==========" + , "======= diese Datei ist UTF8 encodiert ======" + , "Informationen zum Übungsblatt:" + , indent 2 $ foldr (<$$>) mempty + [ "Veranstaltung:" <+> pretty ratingCourseName + , "Blatt:" <+> pretty ratingSheetName + ] + , "Abgabe-Id:" <+> pretty (ciphertext cID) + , "=============================================" + , "Bewertung:" <+> pretty ratingPoints + , "=========== Beginn der Kommentare ===========" + , pretty ratingComment + ] + in Lazy.Text.encodeUtf8 . (<> "\n") $ displayT doc + +ratingFile :: MonadIO m => CryptoFileNameSubmission -> Rating -> m File +ratingFile cID rating@(Rating{ ratingValues = Rating'{..}, .. }) = do + fileModified <- maybe (liftIO getCurrentTime) return 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 + ratingLines = filter (rating `Text.isInfixOf`) headerLines + sep = "Beginn der Kommentare" + rating = "Bewertung:" + comment' <- case commentLines of + (_:commentLines') -> return . Text.strip $ Text.unlines commentLines' + _ -> throw RatingMissingSeparator + let + ratingComment + | Text.null comment' = Nothing + | otherwise = Just comment' + ratingLine' <- case ratingLines of + [l] -> return l + _ -> throw RatingMultiple + let + (_, ratingLine) = Text.breakOnEnd rating ratingLine' + ratingStr = Text.unpack $ Text.strip ratingLine + ratingPoints <- case () of + _ | null ratingStr -> return Nothing + | otherwise -> either (throw . RatingInvalid) return $ Just <$> readEither ratingStr + return Rating'{ ratingTime = Just fileModified, .. } +parseRating _ = throwM RatingFileIsDirectory + + +type SubmissionContent = Either File (SubmissionId, Rating') + +extractRatings :: ( MonadHandler m + , HandlerSite m ~ UniWorX + , MonadCatch m + ) => Conduit File m SubmissionContent +extractRatings = Conduit.mapM $ \f@File{..} -> do + msId <- isRatingFile fileTitle + case () of + _ | Just sId <- msId + , isJust fileContent + -> Right . (sId, ) <$> parseRating f + | otherwise -> return $ 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 <$> Base32.decrypt cIDKey cID) `catch` decryptErrors + | otherwise = return Nothing + where + + decryptErrors (CiphertextConversionFailed _) = return Nothing + decryptErrors InvalidNamespaceDetected = return Nothing + decryptErrors DeserializationError = return Nothing + decryptErrors err = throwM err + +isRatingFile' :: FilePath -> Maybe CryptoFileNameSubmission +isRatingFile' (normalise -> fName) + | (bName, ".txt") <- splitExtension fName + , Just (CI.mk . Text.pack -> ciphertext) <- stripPrefix "bewertung_" bName + = Just CryptoID{..} + | otherwise + = Nothing diff --git a/src/Handler/Utils/Zip/Rating.hs b/src/Handler/Utils/Submission.hs similarity index 58% rename from src/Handler/Utils/Zip/Rating.hs rename to src/Handler/Utils/Submission.hs index 968ce1504..62c55fcf7 100644 --- a/src/Handler/Utils/Zip/Rating.hs +++ b/src/Handler/Utils/Submission.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NamedFieldPuns #-} @@ -9,214 +8,29 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -module Handler.Utils.Zip.Rating - ( Rating(..), Rating'(..) - , getRating - , formatRating - , ratingFile - , RatingException(..) - , UnicodeException(..) - , isRatingFile - , parseRating - , SubmissionContent - , extractRatings - , SubmissionSinkException(..) +module Handler.Utils.Submission + ( SubmissionSinkException(..) , sinkSubmission ) where -import Import hiding (()) +import Import - -import Text.PrettyPrint.Leijen.Text hiding ((<$>)) - -import Control.Monad.Trans.Maybe import Control.Monad.State hiding (forM_) -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import Data.Text.Encoding.Error (UnicodeException(..)) - import Data.Set (Set) import qualified Data.Set as Set - + import Data.Monoid (Monoid, Any(..)) import Generics.Deriving.Monoid (memptydefault, mappenddefault) - -import qualified Data.Text.Lazy.Encoding as Lazy.Text -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) - -import GHC.Generics (Generic) -import Data.Typeable (Typeable) - -import CryptoID.Base32 as Base32 - -import System.FilePath +import Handler.Utils.Rating import qualified Database.Esqueleto as E import qualified Data.Conduit.List as Conduit -instance HasResolution prec => Pretty (Fixed prec) where - pretty = pretty . show - -instance Pretty x => Pretty (CI x) where - pretty = pretty . CI.original - - -data Rating = Rating - { ratingCourseName :: Text - , ratingSheetName :: Text - , ratingValues :: Rating' - } deriving (Read, Show, Eq, Generic, Typeable) - -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 - - -getRating :: SubmissionId -> YesodDB UniWorX (Maybe Rating) -getRating submissionId = runMaybeT $ do - 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 - - 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 =" - , "=============================================" - , "========== UniWorx Bewertungsdatei ==========" - , "======= diese Datei ist UTF8 encodiert ======" - , "Informationen zum Übungsblatt:" - , indent 2 $ foldr (<$$>) mempty - [ "Veranstaltung:" <+> pretty ratingCourseName - , "Blatt:" <+> pretty ratingSheetName - ] - , "Abgabe-Id:" <+> pretty (ciphertext cID) - , "=============================================" - , "Bewertung:" <+> pretty ratingPoints - , "=========== Beginn der Kommentare ===========" - , pretty ratingComment - ] - in Lazy.Text.encodeUtf8 . (<> "\n") $ displayT doc - -ratingFile :: MonadIO m => CryptoFileNameSubmission -> Rating -> m File -ratingFile cID rating@(Rating{ ratingValues = Rating'{..}, .. }) = do - fileModified <- maybe (liftIO getCurrentTime) return 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 - ratingLines = filter (rating `Text.isInfixOf`) headerLines - sep = "Beginn der Kommentare" - rating = "Bewertung:" - comment' <- case commentLines of - (_:commentLines') -> return . Text.strip $ Text.unlines commentLines' - _ -> throw RatingMissingSeparator - let - ratingComment - | Text.null comment' = Nothing - | otherwise = Just comment' - ratingLine' <- case ratingLines of - [l] -> return l - _ -> throw RatingMultiple - let - (_, ratingLine) = Text.breakOnEnd rating ratingLine' - ratingStr = Text.unpack $ Text.strip ratingLine - ratingPoints <- case () of - _ | null ratingStr -> return Nothing - | otherwise -> either (throw . RatingInvalid) return $ Just <$> readEither ratingStr - return Rating'{ ratingTime = Just fileModified, .. } -parseRating _ = throwM RatingFileIsDirectory - - -type SubmissionContent = Either File (SubmissionId, Rating') - -extractRatings :: ( MonadHandler m - , HandlerSite m ~ UniWorX - , MonadCatch m - ) => Conduit File m SubmissionContent -extractRatings = Conduit.mapM $ \f@File{..} -> do - msId <- isRatingFile fileTitle - case () of - _ | Just sId <- msId - , isJust fileContent - -> Right . (sId, ) <$> parseRating f - | otherwise -> return $ 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 <$> Base32.decrypt cIDKey cID) `catch` decryptErrors - | otherwise = return Nothing - where - - decryptErrors (CiphertextConversionFailed _) = return Nothing - decryptErrors InvalidNamespaceDetected = return Nothing - decryptErrors DeserializationError = return Nothing - decryptErrors err = throwM err - -isRatingFile' :: FilePath -> Maybe CryptoFileNameSubmission -isRatingFile' (normalise -> fName) - | (bName, ".txt") <- splitExtension fName - , Just (CI.mk . Text.pack -> ciphertext) <- stripPrefix "bewertung_" bName - = Just CryptoID{..} - | otherwise - = Nothing - - data SubmissionSinkState = SubmissionSinkState { sinkSeenRating :: Any , sinkSubmissionTouched :: Any