fradrive/src/Handler/Utils/Rating.hs

{-# 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 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


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_" <> (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 <$> 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 (CI.mk -> ciphertext) <- stripPrefix "bewertung_" bName
  = Just CryptoID{..}
  | otherwise
  = Nothing