fradrive/src/Handler/Utils/Rating.hs

{-# OPTIONS_GHC -fno-warn-orphans #-}

module Handler.Utils.Rating
  ( Rating(..), Rating'(..)
  , validateRating
  , getRating
  , formatRating
  , ratingFile
  , RatingException(..)
  , UnicodeException(..)
  , isRatingFile
  , parseRating
  , SubmissionContent
  , extractRatings
  ) where

import Import

import Text.PrettyPrint.Leijen.Text hiding ((<$>))

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 System.FilePath
import qualified System.FilePath.Cryptographic as FilePath (decrypt)

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


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 )


validateRating :: SheetType -> Rating' -> [RatingException]
validateRating ratingSheetType Rating'{ ratingPoints=Just rp, .. }
  | rp < 0
    = [RatingNegative]
  | NotGraded <- ratingSheetType
    = [RatingNotExpected]
  | (Just maxPoints ) <- ratingSheetType ^?  _grading . _maxPoints
  , rp > maxPoints
    = [RatingExceedsMax]
  | (Just PassBinary) <- ratingSheetType ^? _grading
  , not (rp == 0 || rp == 1)
    = [RatingBinaryExpected]
validateRating ratingSheetType Rating'{ .. }
  | has _grading ratingSheetType
  , is _Nothing ratingPoints
  , isn't _Nothing ratingTime
  = [RatingPointsRequired]
validateRating _ _ = []

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) <.> "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 . pack) 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