216 lines
7.7 KiB
Haskell
216 lines
7.7 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
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 System.FilePath
|
|
import qualified System.FilePath.Cryptographic as FilePath (decrypt)
|
|
|
|
import qualified Database.Esqueleto as E
|
|
|
|
import qualified Data.Conduit.List as Conduit
|
|
|
|
import Utils.Lens hiding ((<.>))
|
|
|
|
|
|
instance HasResolution prec => Pretty (Fixed prec) where
|
|
pretty = pretty . show
|
|
|
|
instance Pretty x => Pretty (CI x) where
|
|
pretty = pretty . CI.original
|
|
|
|
|
|
instance Pretty SheetGrading where
|
|
pretty (Points {..}) = pretty ( (show maxPoints) <> " Punkte" :: String)
|
|
pretty (PassPoints {..}) = pretty ( (show maxPoints) <> " Punkte, bestanden ab " <> (show passingPoints) <> " Punkte" :: String )
|
|
pretty (PassBinary) = pretty ( "Bestanden (1) / Nicht bestanden (0)" :: String )
|
|
|
|
|
|
data Rating = Rating
|
|
{ ratingCourseName :: CourseName
|
|
, ratingSheetName :: SheetName
|
|
, ratingCorrectorName :: Maybe Text
|
|
, ratingSheetType :: SheetType
|
|
, 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 $ \(corrector `E.RightOuterJoin` (submission `E.InnerJoin` sheet `E.InnerJoin` course)) -> do
|
|
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
|
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
|
E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
|
|
|
|
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
|
|
, corrector E.?. UserDisplayName
|
|
, sheet E.^. SheetType
|
|
, submission E.^. SubmissionRatingPoints
|
|
, submission E.^. SubmissionRatingComment
|
|
, submission E.^. SubmissionRatingTime
|
|
)
|
|
|
|
[ ( E.unValue -> ratingCourseName
|
|
, E.unValue -> ratingSheetName
|
|
, E.unValue -> ratingCorrectorName
|
|
, E.unValue -> ratingSheetType
|
|
, 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 ="
|
|
, "============================================="
|
|
, "========== Uni2work Bewertungsdatei ========="
|
|
, "======= diese Datei ist UTF8 encodiert ======"
|
|
, "Informationen zum Übungsblatt:"
|
|
, indent 2 . foldr (<$$>) mempty . catMaybes $
|
|
[ Just $ "Veranstaltung:" <+> pretty ratingCourseName
|
|
, Just $ "Blatt:" <+> pretty ratingSheetName
|
|
, ("Korrektor:" <+>) . pretty <$> ratingCorrectorName
|
|
, ("Bewertung:" <+>) . pretty <$> (ratingSheetType ^? _grading)
|
|
]
|
|
, "Abgabe-Id:" <+> pretty (Text.unpack $ toPathPiece 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 $ toPathPiece (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 (commentSep `Text.isInfixOf`) $ Text.lines inputText
|
|
(reverse -> ratingLines, reverse -> _headerLines) = break (sep' `Text.isInfixOf`) $ reverse headerLines'
|
|
ratingLines' = filter (rating `Text.isInfixOf`) ratingLines
|
|
commentSep = "Beginn der Kommentare"
|
|
sep' = Text.pack $ replicate 40 '='
|
|
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 <$> FilePath.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' (takeFileName -> fName)
|
|
| (bName, ".txt") <- splitExtension fName
|
|
, Just piece <- stripPrefix "bewertung_" bName
|
|
, Just cID <- fromPathPiece $ Text.pack piece
|
|
= Just cID
|
|
| otherwise
|
|
= Nothing
|