module Handler.Submission.Correction
  ( getCorrectionR, postCorrectionR
  , getCorrectionUserR
  ) where

import Import hiding (link)
-- import System.FilePath (takeFileName)

import Jobs
import Handler.Utils hiding (colSchool)
import Handler.Utils.Submission

import qualified Data.Text as Text

import qualified Control.Monad.State.Class as State

import qualified Database.Esqueleto as E

import qualified Data.Conduit.List as C


correctionData :: TermId -> SchoolId -> CourseShorthand -> SheetName -> _ -- CryptoFileNameSubmission -> _
correctionData tid ssh csh shn sub = E.select . E.from $ \((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> do
  E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
  E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
  E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
  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
       E.&&. submission E.^. SubmissionId E.==. E.val sub
  return (course, sheet, submission, corrector)

getCorrectionR, getCorrectionUserR, postCorrectionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
getCorrectionR tid ssh csh shn cid = do
  mayPost <- isAuthorized (CSubmissionR tid ssh csh shn cid CorrectionR) True
  bool getCorrectionUserR postCorrectionR (mayPost == Authorized) tid ssh csh shn cid
postCorrectionR tid ssh csh shn cid = do
  sub <- decrypt cid

  (results, isLecturer) <- runDB $ (,)
    <$> correctionData tid ssh csh shn sub
    <*> hasWriteAccessTo (CSheetR tid ssh csh shn SSubsR)

  MsgRenderer mr <- getMsgRenderer
  case results of
    [(Entity cId Course{..}, Entity shId Sheet{..}, Entity _ subm@Submission{..}, corrector)] -> do
      let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
          pointsForm = case sheetType of
            NotGraded
              -> pure Nothing
            (preview _grading -> Just PassBinary)
              -> Just <$> apopt (convertField (bool 0 1) (/= 0) checkBoxField) (fslI MsgPassed) submissionRatingPoints
            (preview _grading -> Just PassAlways)
              -> Just <$> aforced (convertField (bool 0 1) (/= 0) checkBoxField) (fslI MsgPassed) 1
            _otherwise
              -> aopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType)
                      (fslpI MsgRatingPoints (mr MsgPointsPlaceholder) & setTooltip sheetType)
                      (Just submissionRatingPoints)
          correctorForm
            | not isLecturer = wFormToAForm $ pure . Just <$> requireAuthId
            | otherwise = wFormToAForm $ do
                let correctors = E.from $ \user -> do
                      let isCorrector = E.exists . E.from $ \sheetCorrector -> 
                            E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
                                 E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. E.val shId
                          isLecturer'  = E.exists . E.from $ \lecturer ->
                            E.where_ $ lecturer E.^. LecturerUser E.==. user E.^. UserId
                                 E.&&. lecturer E.^. LecturerCourse E.==. E.val cId
                      E.where_ $ isCorrector E.||. isLecturer'
                      return user
                wopt (selectField' (Just $ SomeMessage MsgSubmissionNoCorrector) $ userOptionsE correctors) (fslI MsgSubmissionCorrector & setTooltip MsgSubmissionCorrectorTip) (Just submissionRatingBy)
          validateCorr = do
            (now, ratingBy', rated, ratingPoints', ratingComment') <- State.get
            mapM_ tellValidationError $ validateRating sheetType Rating'
              { ratingPoints  = ratingPoints'
              , ratingComment = ratingComment'
              , ratingTime    = guardOn rated now
              , ratingDone    = rated
              }
            guardValidation MsgSubmissionCannotBeRatedWithoutCorrector $ isn't _Nothing ratingBy' || not rated

      ((corrResult, corrForm'), corrEncoding) <- runFormPost . validateForm validateCorr . identifyForm FIDcorrection . renderAForm FormStandard $ (,,,,)
        <$> wFormToAForm (pure <$> liftIO getCurrentTime)
        <*> correctorForm
        <*> apopt checkBoxField (fslI MsgRatingDone & setTooltip MsgRatingDoneTip) (Just $ submissionRatingDone Submission{..})
        <*> pointsForm
        <*> aopt (textareaField & isoField _Wrapped & cfStrip) (fslI MsgRatingComment) (Just submissionRatingComment)
      let corrForm = wrapForm' BtnSave corrForm' def
            { formAction = Just . SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR
            , formEncoding = corrEncoding
            }

      ((uploadResult, uploadForm'), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionUpload . renderAForm FormStandard $
            apopt (zipFileField True Nothing) (fslI MsgRatingFiles & setTooltip MsgRatingFilesTip) Nothing
      let uploadForm = wrapForm uploadForm' def
            { formAction = Just . SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR
            , formEncoding = uploadEncoding
            }

      formResult corrResult $ \(now, ratingBy', rated, ratingPoints', ratingComment') -> do
        runDBJobs $ do
          update sub  [ SubmissionRatingBy      =. ratingBy'
                      , SubmissionRatingTime    =. (now <$ guard rated)
                      , SubmissionRatingPoints  =. ratingPoints'
                      , SubmissionRatingComment =. ratingComment'
                      ]

          when (rated && is _Nothing submissionRatingTime) $ do
            $logDebugS "CorrectionR" [st|Rated #{tshow sub}|]
            queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub

        addMessageI Success $ if
          | rated -> MsgRatingUpdated
          | is _Nothing ratingComment'
          , is _Nothing ratingPoints'
          , is _Nothing ratingBy' -> MsgRatingDeleted
          | is _Nothing ratingComment'
          , is _Nothing ratingPoints' -> MsgCorrectorUpdated
          | otherwise -> MsgRatingDraftUpdated
        redirect $ CSubmissionR tid ssh csh shn cid CorrectionR

      formResult uploadResult $ \fileUploads -> do
        uid <- maybeAuthId

        res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| C.mapM (either get404 return) .| extractRatingsMsg .| sinkSubmission uid (Right sub) True

        when (is _Just res) $ do
          addMessageI Success MsgRatingFilesUpdated
          redirect $ CSubmissionR tid ssh csh shn cid CorrectionR

      let heading = MsgCorrectionHead tid ssh csh shn cid
          headingWgt = [whamlet|
              $newline never
              _{heading}
              $if not (submissionRatingDone subm)
                \ ^{isVisibleWidget False}
            |]
      siteLayout headingWgt $ do
        setTitleI heading
        let userCorrection = $(widgetFile "correction-user")
        $(widgetFile "correction")
    _ -> notFound


getCorrectionUserR tid ssh csh shn cid = do
  sub <- decrypt cid

  results <- runDB $ correctionData tid ssh csh shn sub

  case results of
    [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _))] ->
      let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
       in defaultLayout $(widgetFile "correction-user")
    _ -> notFound