137 lines
4.7 KiB
Haskell
137 lines
4.7 KiB
Haskell
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
|
|
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
|
|
|
module Handler.Utils.Zip.Rating
|
|
( Rating(..)
|
|
, getRating
|
|
, formatRating
|
|
, RatingException(..)
|
|
, UnicodeException(..)
|
|
, parseRating
|
|
, 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 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 Data.Binary (encode, decode)
|
|
import qualified Data.CryptoID.Poly as Poly
|
|
|
|
|
|
instance HasResolution prec => Pretty (Fixed prec) where
|
|
pretty = pretty . show
|
|
|
|
|
|
data Rating = Rating
|
|
{ ratingCourseName :: Text
|
|
, ratingSheetName :: Text
|
|
, ratingSubmissionId :: CryptoIDSubmission ByteString -- ^ 'SubmissionId'
|
|
, ratingComment :: Maybe Text
|
|
, ratingPoints :: Maybe Points
|
|
} deriving (Read, Show, Eq, Generic, Typeable)
|
|
|
|
type Rating' = ( Maybe Points
|
|
, Maybe Text -- ^ Rating comment
|
|
)
|
|
|
|
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
|
|
deriving (Show, Eq, Generic, Typeable)
|
|
|
|
instance Exception RatingException
|
|
|
|
|
|
getRating :: SubmissionId -> YesodDB UniWorX (Maybe Rating)
|
|
getRating submissionId = runMaybeT $ do
|
|
Submission{ submissionSheetId, submissionRatingComment = ratingComment, submissionRatingPoints = ratingPoints } <- MaybeT $ get submissionId
|
|
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
|
|
return Rating{..}
|
|
|
|
formatRating :: Rating -> Lazy.ByteString
|
|
formatRating 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 (show ratingSubmissionId) -- FIXME
|
|
, "============================================="
|
|
, "Bewertung:" <+> pretty ratingPoints
|
|
, "=========== Beginn der Kommentare ==========="
|
|
, pretty ratingComment
|
|
]
|
|
in Lazy.Text.encodeUtf8 $ displayT doc
|
|
|
|
parseRating :: MonadThrow m => ByteString -> m Rating'
|
|
parseRating 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
|
|
comment
|
|
| 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
|
|
rating <- case () of
|
|
_ | null ratingStr -> return Nothing
|
|
| otherwise -> either (throw . RatingInvalid) return $ Just <$> readEither ratingStr
|
|
return (rating, comment)
|
|
|
|
|
|
extractRatings :: MonadThrow m => (FilePath -> Maybe SubmissionId) -> Conduit File m (Either File (SubmissionId, Rating'))
|
|
extractRatings isRating = void . runMaybeT $ do
|
|
f@(File{..}) <- MaybeT await
|
|
lift $ case () of
|
|
_ | Just sId <- isRating fileTitle
|
|
, Just content' <- fileContent
|
|
-> yieldM $ Right . (sId, ) <$> parseRating content'
|
|
| otherwise -> yield $ Left f
|