Clean up structure
This commit is contained in:
Gregor Kleen
parent
cb27038c6b
commit
1afc2b4bad
@ -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
|
||||
|
||||
208
src/Handler/Utils/Rating.hs
Normal file
208
src/Handler/Utils/Rating.hs
Normal file
@ -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
|
||||
@ -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
|
||||
Loading…
Reference in New Issue
Block a user