module Handler.Exam.Show
  ( getEShowR
  ) where

import Import
import Handler.Exam.Register

import Utils.Lens hiding (parts)

import Data.Map ((!?))
import qualified Data.Map as Map

import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E

import qualified Data.CaseInsensitive as CI

import Handler.Utils
import Handler.Utils.Exam


getEShowR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
getEShowR tid ssh csh examn = do
  cTime <- liftIO getCurrentTime
  mUid <- maybeAuthId

  (Entity _ Exam{..}, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown) <- runDB $ do
    exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn

    let examVisible = NTop (Just cTime) >= NTop examVisibleFrom

    let gradingVisible = NTop (Just cTime) >= NTop examFinished
    gradingShown <- or2M (return gradingVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR

    let occurrenceAssignmentsVisible = NTop (Just cTime) >= NTop examPublishOccurrenceAssignments
    occurrenceAssignmentsShown <- or2M (return occurrenceAssignmentsVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR

    parts <- selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ]

    resultsRaw <- for mUid $ \uid ->
      E.select . E.from $ \examPartResult -> do
        E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val uid
             E.&&. examPartResult E.^. ExamPartResultExamPart `E.in_` E.valList (map entityKey parts)
        return examPartResult
    let results = maybe Map.empty (\rs -> Map.fromList [ (examPartResultExamPart, res) | res@(Entity _ ExamPartResult{..}) <- rs ]) resultsRaw

    result <- fmap join . for mUid $ getBy . UniqueExamResult eId

    occurrencesRaw <- E.select . E.from $ \examOccurrence -> do
      E.where_ $ examOccurrence E.^. ExamOccurrenceExam E.==. E.val eId
      let
        registered
          | Just uid <- mUid
          = E.exists . E.from $ \examRegistration ->
              E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eId
                   E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val uid
                   E.&&. examRegistration E.^. ExamRegistrationOccurrence E.==. E.just (examOccurrence E.^. ExamOccurrenceId)
          | otherwise = E.false
      E.orderBy [E.desc registered, E.asc $ examOccurrence E.^. ExamOccurrenceStart, E.asc $ examOccurrence E.^. ExamOccurrenceRoom]
      return (examOccurrence, registered)

    let occurrences = map (over _2 E.unValue) occurrencesRaw

    registered <- for mUid $ existsBy . UniqueExamRegistration eId
    mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True

    occurrenceNamesShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR

    return (exam, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown)

  let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences
      registerWidget
        | Just isRegistered <- registered
        , mayRegister = Just $ do
            (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered
            [whamlet|
              <p>
                $if isRegistered
                  _{MsgExamRegistered}
                $else
                  _{MsgExamNotRegistered}
            |]
            wrapForm examRegisterForm def
              { formAction = Just . SomeRoute $ CExamR tid ssh csh examName ERegisterR
              , formEncoding = examRegisterEnctype
              , formSubmit = FormNoSubmit
            }
        | fromMaybe False registered = Just [whamlet|_{MsgExamRegistered}|]
        | otherwise = Nothing

  let heading = prependCourseTitle tid ssh csh $ CI.original examName

  siteLayoutMsg heading $ do
    setTitleI heading
    let
      gradingKeyW :: [Points] -> Widget
      gradingKeyW bounds
        = let boundWidgets :: [Widget]
              boundWidgets = toWidget . (pack :: String -> Text) . showFixed True <$> 0 : bounds
              grades :: [ExamGrade]
              grades = universeF
           in $(widgetFile "widgets/gradingKey")

      examBonusW :: ExamBonusRule -> Widget
      examBonusW bonusRule = $(widgetFile "widgets/bonusRule")
    $(widgetFile "exam-show")