fradrive/src/Handler/Utils/Sheet.hs

-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

module Handler.Utils.Sheet where

import Import

import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Internal.Internal as E

import qualified Data.Map.Strict as Map

import Text.Hamlet


-- | Map sheet file types to their visibily dates of a given sheet, for convenience
sheetFileTypeDates :: Sheet -> SheetFileType -> Maybe UTCTime
sheetFileTypeDates Sheet{..} = \case
  SheetExercise -> sheetActiveFrom
  SheetHint     -> sheetHintFrom
  SheetSolution -> sheetSolutionFrom
  SheetMarking  -> Nothing


fetchSheetAux ::  ( E.SqlSelect b a
                  , Typeable a, MonadHandler m
                  )
  =>  (E.SqlExpr (Entity Sheet) -> E.SqlExpr (Entity Course) -> b)
      -> TermId -> SchoolId -> CourseShorthand -> SheetName -> SqlReadT m a
fetchSheetAux prj tid ssh csh shn =
    let cachId = encodeUtf8 $ tshow (tid, ssh, csh, shn)
    in  cachedBy cachId $ do
    -- Mit Yesod:
    -- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
    -- getBy404 $ CourseSheet cid shn
    -- Mit Esqueleto:
        sheetList <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
            E.on     $ course E.^. CourseId E.==. sheet E.^. SheetCourse
            E.where_ $ course E.^. CourseTerm      E.==. E.val tid
                E.&&.  course E.^. CourseSchool    E.==. E.val ssh
                E.&&.  course E.^. CourseShorthand E.==. E.val csh
                E.&&.  sheet  E.^. SheetName       E.==. E.val shn
            return $ prj sheet course
        case sheetList of
          [sheet] -> return sheet
          _other  -> notFound

fetchSheet :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Entity Sheet)
fetchSheet = fetchSheetAux const

fetchSheetCourse :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Entity Sheet, Entity Course)
fetchSheetCourse = fetchSheetAux (,)

fetchSheetId :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet)
fetchSheetId tid ssh cid shn = E.unValue <$> fetchSheetAux (\sheet _ -> sheet E.^. SheetId) tid ssh cid shn

fetchSheetIdCourseId :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet, Key Course)
fetchSheetIdCourseId tid ssh cid shn = bimap E.unValue E.unValue <$> fetchSheetAux (\sheet course -> (sheet E.^. SheetId, course E.^. CourseId)) tid ssh cid shn


data ResolveSheetTypeException
  = ResolveSheetTypeExamPartUnavailable SqlBackendKey
  | ResolveSheetTypeForeignExam
  deriving (Eq, Ord, Read, Show, Generic)
  deriving anyclass (Exception)
  
resolveSheetType :: ( MonadThrow m
                    , MonadIO m
                    )
                 => CourseId
                 -> SheetType SqlBackendKey
                 -> ReaderT SqlBackend m (SheetType (Entity ExamPart))
resolveSheetType cId = traverse $ \epId'@(review _SqlKey -> epId) -> do
  ep@(Entity _ ExamPart{..}) <- maybe (throwM $ ResolveSheetTypeExamPartUnavailable epId') return =<< getEntity epId
  Exam{..} <- getJust examPartExam
  if | examCourse /= cId -> throwM ResolveSheetTypeForeignExam
     | otherwise         -> return ep

resolveSheetTypeRating :: ( MonadThrow m
                          , MonadIO m
                          )
                       => CourseId
                       -> SheetType SqlBackendKey
                       -> ReaderT SqlBackend m (SheetType RatingExamPartReference)
resolveSheetTypeRating cId dbST = do
  eST <- resolveSheetType cId dbST
  case matching _ExamPartPoints eST of
    Left t -> return t
    Right (Entity _ ExamPart{..}, weight, grading) -> do
      Exam{..} <- getJust examPartExam
      return ExamPartPoints
        { examPart = RatingExamPartReference examName examPartNumber
        , ..
        }

sheetTypeDescription :: forall m.
                        ( MonadHandler m, HandlerSite m ~ UniWorX
                        )
                     => CourseId
                     -> SheetType SqlBackendKey
                     -> ReaderT SqlBackend m (HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX))
sheetTypeDescription cId dbST = hoist liftHandler $ do
  sType' <- resolveSheetType cId dbST
  sType <- for sType' $ \(Entity _epId ExamPart{..}) -> do
    Exam{..} <- getJust examPartExam
    Course{..} <- getJust examCourse
    cTime <- liftIO getCurrentTime
    lecturerInfo <- hasReadAccessTo $ CExamR courseTerm courseSchool courseShorthand examName EEditR
    let partVisible = gradingVisible
                   || NTop (Just cTime) >= NTop examPartsFrom
                   || lecturerInfo
        gradingVisible = NTop (Just cTime) >= NTop examPartsFrom
                      || lecturerInfo
    return (examName, examPartName, examPartNumber, partVisible, gradingVisible, CExamR courseTerm courseSchool courseShorthand examName EShowR)
  return $(ihamletFile "templates/widgets/sheetType.hamlet")



sheetExamResult :: SheetTypeSummary ExamPartId -> Entity ExamPart -> Maybe ExamResultPoints
sheetExamResult SheetTypeSummary{ examSummary = MergeMap examSummary'' } (Entity epId ExamPart{..}) = Map.lookup epId examSummary'' <&> \examSummary' ->
  let
    sumOfWeights = getSum $ foldMap (views _1 Sum) examSummary'
    weightRescale = recip sumOfWeights

    toExamPoints :: (Rational, SheetGradeSummary) -> Maybe Rational
    toExamPoints (weight, summary)
      | sumOfWeights <= 0 = Nothing
      | otherwise = Just . (* weight) $ case examPartMaxPoints of
          Just maxPoints -> toRational maxPoints * bonusProp
          Nothing        -> bonusProp * possible
      where
        bonusProp :: Rational
        bonusProp | possible <= 0 = 1
                  | otherwise     = achieved / possible

        achieved = toRational (getSum $ achievedPoints  summary - achievedPassPoints  summary) + scalePasses (getSum $ achievedPasses  summary)
        possible = toRational (getSum $ sumSheetsPoints summary - sumSheetsPassPoints summary) + scalePasses (getSum $ numSheetsPasses summary)

        scalePasses :: Integer -> Rational
        scalePasses passes
          | pointsPossible <= 0
          , Just maxPoints <- examPartMaxPoints = fromInteger passes * toRational maxPoints / fromInteger passesPossible
          | pointsPossible <= 0 = 0
          | passesPossible <= 0 = 0
          | otherwise = fromInteger passes / (fromInteger passesPossible * passesWeights) * (toRational pointsPossible * pointsWeights)
          where
            passesPossible = getSum $ numSheetsPasses summary
            pointsPossible = getSum $ sumSheetsPoints summary - sumSheetsPassPoints summary

            pointsWeights = getSum $ foldMap (\(sWeight, gradeSummary) -> guardMonoid (sumSheetsPoints gradeSummary - sumSheetsPassPoints gradeSummary > 0) $ Sum sWeight) examSummary'
            passesWeights = getSum $ foldMap (\(sWeight, gradeSummary) -> guardMonoid (numSheetsPasses gradeSummary > 0) $ Sum sWeight) examSummary'
   in if | SheetGradeSummary{numMarked} <- foldOf (folded . _2) examSummary'
         , numMarked <= 0
           -> ExamNoShow
         | otherwise
           -> ExamAttended . roundToPoints . (* examPartWeight) . (* weightRescale) . getSum . fold $ foldMapM (fmap Sum . toExamPoints) examSummary'