fradrive-old/src/Handler/Utils/Rating.hs

module Handler.Utils.Rating
  ( Rating(..), Rating'(..)
  , validateRating
  , getRating
  , ratingFile
  , isRatingFile
  , SubmissionContent
  , extractRatings
  , module Handler.Utils.Rating.Format
  ) where

import Import

import Handler.Utils.Files
import Handler.Utils.DateTime (getDateTimeFormatter)
import Handler.Utils.Sheet (resolveSheetTypeRating)

import qualified Data.Text as Text

import qualified Database.Esqueleto.Legacy as E

import qualified Data.Conduit.Combinators as C

import Handler.Utils.Rating.Format

import qualified Data.Set as Set
import qualified Data.CaseInsensitive as CI

import qualified Data.Char as Char


validateRating :: SheetType a -> Rating' -> [RatingValidityException]
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
  , ratingDone
  , hasn't (_grading . _PassAlways) ratingSheetType
  = [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 `E.InnerJoin` school)) -> do
        E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
        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.^. CourseId
               , course E.^. CourseTerm
               , school E.^. SchoolName
               , course E.^. CourseName
               , sheet E.^. SheetName
               , corrector E.?. UserDisplayName
               , sheet E.^. SheetType
               , submission
               )

  [ ( E.unValue -> cId
    , unTermKey . E.unValue -> ratingCourseTerm
    , E.unValue -> ratingCourseSchool
    , E.unValue -> ratingCourseName
    , E.unValue -> ratingSheetName
    , E.unValue -> ratingCorrectorName
    , E.unValue -> ratingSheetType'
    , E.Entity _ sub@Submission{..}
    ) ] <- lift query
  ratingSheetType <- lift $ resolveSheetTypeRating cId ratingSheetType'

  let ratingPoints = submissionRatingPoints
      ratingComment = submissionRatingComment
      ratingTime = submissionRatingTime
      ratingDone = submissionRatingDone sub

  return Rating{ ratingValues = Rating'{..}, .. }

extensionRating :: String
extensionRating = "txt"

ratingFile :: ( MonadHandler m
              , HandlerSite m ~ UniWorX
              , Monad m'
              )
           => CryptoFileNameSubmission -> Rating -> m (File m')
ratingFile cID rating@Rating{ ratingValues = Rating'{..} } = do
  mr'@(MsgRenderer mr) <- getMsgRenderer
  dtFmt <- getDateTimeFormatter
  fileModified <- maybe (liftIO getCurrentTime) return ratingTime
  let
    fileTitle = ensureExtension extensionRating . unpack . mr $ MsgRatingFileTitle cID
    fileContent = Just . C.sourceLazy $ formatRating mr' dtFmt cID rating
  return File{..}

type SubmissionContent = Either FileReference (SubmissionId, Rating')

extractRatings :: ( MonadHandler m
                  , HandlerSite m ~ UniWorX
                  ) => ConduitT FileReference SubmissionContent m ()
extractRatings = C.mapM $ \fRef@FileReference{..} -> liftHandler $ do
  msId <- isRatingFile fileReferenceTitle
  if
    | Just sId <- msId
    , isJust fileReferenceContent -> do
        (rating, cID) <- handle (throwM . RatingFileException fileReferenceTitle) . runDB . parseRating $ sourceFile fRef
        sId' <- traverse decrypt cID
        unless (maybe (const True) (==) sId' sId) $
          throwM $ RatingFileException fileReferenceTitle RatingSubmissionIDIncorrect
        return $ Right (sId, rating)
    | otherwise -> return $ Left fRef

isRatingFile :: forall m.
                ( MonadHandler m
                , HandlerSite m ~ UniWorX
                ) => FilePath -> m (Maybe SubmissionId)
isRatingFile (takeFileName -> fName) = liftHandler . runMaybeT $ do
  app <- getYesod
  (cID, subId) <- MaybeT . fmap getFirst . flip foldMapM segments' $ fmap First . tryDecrypt
  guard $ isRatingFileName app cID
  return subId
  where
    tryDecrypt :: Text -> Handler (Maybe (CryptoFileNameSubmission, SubmissionId))
    tryDecrypt ciphertext
      | Just cID <- fromPathPiece ciphertext
      = (Just . (cID, ) <$> decrypt cID) `catch` decryptErrors
      | otherwise
      = return Nothing

    decryptErrors (CiphertextConversionFailed _) = return Nothing
    decryptErrors InvalidNamespaceDetected       = return Nothing
    decryptErrors DeserializationError           = return Nothing
    decryptErrors err                            = throwM err

    segments' = filter (not . Text.null) . Text.split (flip Set.notMember cryptoIdChars . CI.mk) . Text.pack $ takeFileName fName

    cryptoIdChars :: Set (CI Char)
    cryptoIdChars = Set.fromList . map CI.mk $ "uwa" ++ "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"

    isRatingFileName app cID = is _Just $ do
      [CI.mk -> dWord, number, CI.mk -> extension] <- pure . filter (not . Text.null) . Text.split (not . Char.isAlphaNum) $ Text.pack fName
      guard $ Text.all (flip Set.member cryptoIdChars . CI.mk) number
      cID' <- fromPathPiece number
      guard $ cID' == cID
      let ratingTexts = map (flip (renderMessage app) (MsgRatingFileTitle cID) . pure) $ toList appLanguages
          ratingWords = Set.fromList $ do
            (pack . ensureExtension extensionRating . unpack -> ratingText) <- ratingTexts
            (CI.mk -> dWord') : _ <- pure . filter (not . Text.null) . Text.split (not . Char.isAlphaNum) $ Text.pack ratingText
            return dWord'
      guard $ dWord `Set.member` ratingWords
      let canonExtension = Set.singleton $ CI.mk (pack extensionRating)
          validExtensions = foldMap (Set.map CI.mk . mimeExtensions) ["application/json", "text/vnd.yaml"]
      guard $ extension `Set.member` Set.union canonExtension validExtensions