{-# OPTIONS_GHC -Wwarn #-}

module Handler.Sheet.Form
  ( SheetForm(..), SheetPersonalisedFilesForm(..), Loads
  , makeSheetForm
  , getFtIdMap
  ) where

import Import

import Handler.Utils
import Handler.Utils.Invitations

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

import qualified Data.Set as Set
import qualified Data.Map as Map

import Data.Map ((!))

import qualified Control.Monad.State.Class as State


import Handler.Sheet.CorrectorInvite


type Loads = Map (Either UserEmail UserId) (InvitationData SheetCorrector)

data SheetForm = SheetForm
      { sfName         :: SheetName
      , sfDescription  :: Maybe StoredMarkup
      , sfRequireExamRegistration :: Maybe ExamId
      , sfSheetF, sfHintF, sfSolutionF, sfMarkingF :: Maybe FileUploads
      , sfPersonalF :: Maybe SheetPersonalisedFilesForm
      , sfVisibleFrom  :: Maybe UTCTime
      , sfActiveFrom   :: Maybe UTCTime
      , sfActiveTo     :: Maybe UTCTime
      , sfHintFrom     :: Maybe UTCTime
      , sfSolutionFrom :: Maybe UTCTime
      , sfSubmissionMode :: SubmissionMode
      , sfGrouping     :: SheetGroup
      , sfType         :: SheetType ExamPartId
      , sfAutoDistribute :: Bool
      , sfMarkingText  :: Maybe StoredMarkup
      , sfAnonymousCorrection :: Bool
      , sfCorrectors   :: Loads
      , sfAuthorshipStatementMode :: SheetAuthorshipStatementMode
      , sfAuthorshipStatementExam :: Maybe ExamId
      , sfAuthorshipStatement :: Maybe I18nStoredMarkup
      }

data SheetPersonalisedFilesForm = SheetPersonalisedFilesForm
  { spffFiles :: Maybe FileUploads
  , spffFilesKeepExisting :: Bool
  , spffAllowNonPersonalisedSubmission :: Bool
  }

  
getFtIdMap :: Key Sheet -> DB (SheetFileType -> Set FileReference)
getFtIdMap sId = do
  allSheetFiles <- E.select . E.from $ \sheetFile -> do
      E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sId
      return sheetFile
  return $ partitionFileType [ (sheetFileType, sf ^. _FileReference . _1) | Entity _ sf@SheetFile{..} <- allSheetFiles ]

makeSheetForm :: CourseId -> Maybe SheetId -> Maybe SheetForm -> Form SheetForm
makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateSheet $ \html -> do
    oldFileIds <- (return.) <$> case msId of
      Nothing    -> return $ partitionFileType mempty
      (Just sId) -> liftHandler $ runDB $ getFtIdMap sId
    mr'@(MsgRenderer mr) <- getMsgRenderer
    ctime <- ceilingQuarterHour <$> liftIO getCurrentTime
    ((School{..}, mSchoolAuthorshipStatement), _course) <- liftHandler . runDB $ do
      course@Course{courseSchool} <- get404 cId
      school@School{..} <- get404 courseSchool
      mSchoolAuthorshipStatement <- runMaybeT $ do
        statementId <- MaybeT . return $ schoolSheetAuthorshipStatementDefinition
        MaybeT . getEntity $ statementId
      return ((school, mSchoolAuthorshipStatement), course)
    sheetPersonalisedFilesForm <- makeSheetPersonalisedFilesForm $ template >>= sfPersonalF

    let mkSheetForm 
          sfName
          sfDescription
          sfRequireExamRegistration
          sfSheetF sfHintF sfSolutionF sfMarkingF
          sfPersonalF sfVisibleFrom sfActiveFrom sfActiveTo sfHintFrom sfSolutionFrom
          sfSubmissionMode sfGrouping sfType
          sfAutoDistribute sfMarkingText sfAnonymousCorrection sfCorrectors
          (sfAuthorshipStatementMode, sfAuthorshipStatementExam, sfAuthorshipStatement)
            = SheetForm{..}

    flip (renderAForm FormStandard) html $ mkSheetForm
      <$> areq (textField & cfStrip & cfCI) (fslI MsgSheetName) (sfName <$> template)
      <*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template)
      <*> optionalActionA (apreq (examField Nothing cId) (fslI MsgSheetRequiredExam) (sfRequireExamRegistration =<< template)) (fslI MsgSheetRequireExam & setTooltip MsgSheetRequireExamTip) (is _Just . sfRequireExamRegistration <$> template)

      <*  aformSection MsgSheetFormFiles
      <*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
      <*> aopt (multiFileField $ oldFileIds SheetHint) (fslI MsgSheetHint) (sfHintF <$> template)
      <*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template)
      <*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarkingFiles & setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template)
      <*> optionalActionA sheetPersonalisedFilesForm (fslI MsgSheetPersonalisedFiles & setTooltip MsgSheetPersonalisedFilesTip) (is _Just . sfPersonalF <$> template)

      <*  aformSection MsgSheetFormTimes
      <*> aopt utcTimeField (fslI MsgSheetVisibleFrom & setTooltip MsgSheetVisibleFromTip) ((sfVisibleFrom <$> template) <|> pure (Just ctime))
      <*> aopt utcTimeField (fslI MsgSheetActiveFrom & setTooltip MsgSheetActiveFromTip) (sfActiveFrom <$> template)
      <*> aopt utcTimeField (fslI MsgSheetActiveTo & setTooltip MsgSheetActiveToTip) (sfActiveTo <$> template)
      <*> aopt utcTimeField (fslpI MsgSheetHintFrom (mr MsgSheetHintFromPlaceholder) & setTooltip MsgSheetHintFromTip) (sfHintFrom <$> template)
      <*> aopt utcTimeField (fslpI MsgSheetSolutionFrom (mr MsgSheetSolutionFromPlaceholder) & setTooltip MsgSheetSolutionFromTip) (sfSolutionFrom <$> template)

      <*  aformSection MsgSheetFormType
      <*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction False))
      <*> sheetGroupAFormReq (fslI MsgSheetGroup) ((sfGrouping <$> template) <|> pure NoGroups)
      <*> sheetTypeAFormReq cId (fslI MsgSheetSheetType) (sfType <$> template)

      <*> apopt checkBoxField (fslI MsgAutoAssignCorrs) (sfAutoDistribute <$> template)
      <*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template)
      <*> apopt checkBoxField (fslI MsgSheetAnonymousCorrection & setTooltip MsgSheetAnonymousCorrectionTip) (sfAnonymousCorrection <$> template)
      <*> correctorForm (maybe mempty sfCorrectors template)

      <*> let sfAuthorshipStatementExam' = sfAuthorshipStatementExam =<< template
              sfAuthorshipStatement' = sfAuthorshipStatement =<< template
           in wFormToAForm $ (\res -> (,,) <$> view _1 res <*> view _2 res <*> view _3 res) <$>
                if | isn't _SchoolAuthorshipStatementModeNone schoolSheetAuthorshipStatementMode -> do
                       wformSection MsgSheetAuthorshipStatementSection

                       let 
                         reqContentField :: AForm Handler I18nStoredMarkup
                         reqContentField = formResultUnOpt mr' MsgSheetAuthorshipStatementContent
                               `fmapAForm` i18nFieldA htmlField True (\_ -> Nothing) ("authorship-statement" :: Text)
                                           (fslI MsgSheetAuthorshipStatementContent)
                                           True
                                           ( fmap Just $     (sfAuthorshipStatement =<< template)
                                                         <|> (authorshipStatementDefinitionContent . entityVal <$> mSchoolAuthorshipStatement)
                                           )
                         forcedContentField = wforced forcedAuthorshipStatementField (fslI MsgSheetAuthorshipStatementContent & setTooltip MsgSheetAuthorshipStatementContentForcedTip)

                       if | not schoolSheetAuthorshipStatementAllowOther
                            -> (pure SheetAuthorshipStatementModeEnabled, pure sfAuthorshipStatementExam', )
                               <$> (fmap (traverse $ fmap authorshipStatementDefinitionContent) . traverse forcedContentField $ entityVal <$> mSchoolAuthorshipStatement)
                          | otherwise -> do
                              examOpts <-
                                let examFieldQuery = E.from $ \exam -> do
                                      E.where_ $ exam E.^. ExamCourse E.==. E.val cId
                                      when (is _SchoolAuthorshipStatementModeRequired schoolSheetAuthorshipStatementMode) $
                                        E.where_ . E.isJust $ exam E.^. ExamAuthorshipStatement
                                      return exam
                                 in liftHandler $ optionsCryptoIdE examFieldQuery examName

                              let modeOpts = case schoolSheetAuthorshipStatementMode of
                                    SchoolAuthorshipStatementModeNone -> Set.singleton SheetAuthorshipStatementModeDisabled
                                    SchoolAuthorshipStatementModeOptional -> Set.fromList universeF
                                    SchoolAuthorshipStatementModeRequired -> Set.fromList universeF
                                      & Set.delete SheetAuthorshipStatementModeDisabled
                                      & bool id (Set.delete SheetAuthorshipStatementModeExam) (hasn't (_olOptions . folded) examOpts)
                                  modeOpts' = explainOptionList (optionsPathPiece . map (id &&& id) $ Set.toList modeOpts) $ \case
                                    SheetAuthorshipStatementModeDisabled -> return $(i18nWidgetFile "sheet-authorship-statement-mode-tip/disabled")
                                    SheetAuthorshipStatementModeExam -> return $(i18nWidgetFile "sheet-authorship-statement-mode-tip/exam")
                                    SheetAuthorshipStatementModeEnabled -> return $(i18nWidgetFile "sheet-authorship-statement-mode-tip/enabled")
                                  examField' = selectField' (Just $ SomeMessage MsgSheetAuthorshipStatementExamNone) . return $ entityKey <$> examOpts
                                  examField'' :: AForm Handler (Maybe ExamId)
                                  examField''
                                    | isn't _SchoolAuthorshipStatementModeRequired schoolSheetAuthorshipStatementMode
                                    = aopt examField' (fslI MsgSheetAuthorshipStatementExam) (sfAuthorshipStatementExam <$> template)
                                    | otherwise
                                    = Just <$> apreq examField' (fslI MsgSheetAuthorshipStatementExam) (sfAuthorshipStatementExam =<< template)
                                  modeForms = flip Map.fromSet modeOpts $ \case
                                    SheetAuthorshipStatementModeDisabled -> pure
                                      ( SheetAuthorshipStatementModeDisabled
                                      , sfAuthorshipStatementExam'
                                      , sfAuthorshipStatement'
                                      )
                                    SheetAuthorshipStatementModeExam -> (SheetAuthorshipStatementModeExam,, )
                                      <$> examField''
                                      <*> pure sfAuthorshipStatement'
                                    SheetAuthorshipStatementModeEnabled -> (SheetAuthorshipStatementModeEnabled, sfAuthorshipStatementExam', )
                                      <$> fmap Just reqContentField

                                  massage res = (view _1 <$> res, view _2 <$> res, view _3 <$> res)

                              massage <$> explainedMultiActionW modeForms modeOpts' (fslI MsgSheetAuthorshipStatementRequired & setTooltip (bool MsgSheetAuthorshipStatementRequiredTip MsgSheetAuthorshipStatementRequiredForcedTip $ is _SchoolAuthorshipStatementModeRequired schoolSheetAuthorshipStatementMode)) (sfAuthorshipStatementMode <$> template)
                   | otherwise -> return
                       ( pure SheetAuthorshipStatementModeDisabled
                       , pure sfAuthorshipStatementExam'
                       , pure sfAuthorshipStatement'
                       )
  where
    makeSheetPersonalisedFilesForm :: Maybe SheetPersonalisedFilesForm -> MForm Handler (AForm Handler SheetPersonalisedFilesForm)
    makeSheetPersonalisedFilesForm template' = do
      templateDownloadMessage <- runMaybeT . hoist (liftHandler . runDB) $ do
        mbSheet <- maybe (return Nothing) (fmap Just . hoistMaybe) =<< traverse (lift . get) msId
        Course{..} <- MaybeT $ get cId
        let downloadRoute = case mbSheet of
              Just Sheet{..} -> CSheetR courseTerm courseSchool courseShorthand sheetName SPersonalFilesR
              Nothing -> CourseR courseTerm courseSchool courseShorthand CPersonalFilesR
            downloadTrigger
              = [whamlet|
                  $newline never
                  #{iconFileZip}
                  \ _{MsgSheetPersonalisedFilesDownload}
                |]
        listRoute <- for mbSheet $ \(sheetName -> shn) -> toTextUrl 
          ( CourseR courseTerm courseSchool courseShorthand CUsersR
          , [ ("courseUsers-has-personalised-sheet-files"
              , toPathPiece shn
              )
            ]
          )
        guardM . lift $ hasReadAccessTo downloadRoute
        messageIconWidget Info IconFileUser
          [whamlet|
            $newline never
            <div>
              _{MsgSheetPersonalisedFilesDownloadTemplateHere}
              <br />
              ^{modal downloadTrigger (Left (SomeRoute downloadRoute))}
            $maybe lRoute <- listRoute
              <p .explanation>
                <a href=#{lRoute} target="_blank">
                  _{MsgSheetPersonalisedFilesUsersList}
          |]
      return $ SheetPersonalisedFilesForm
        <$  maybe (pure ()) aformMessage templateDownloadMessage
        <*> aopt (zipFileField True Nothing True) (fslI MsgSheetPersonalisedFilesUpload & setTooltip MsgSheetPersonalisedFilesUploadTip) Nothing
        <*> apopt checkBoxField (fslI MsgSheetPersonalisedFilesKeepExisting & setTooltip MsgSheetPersonalisedFilesKeepExistingTip) (fmap spffFilesKeepExisting template' <|> Just True)
        <*> apopt checkBoxField (fslI MsgSheetPersonalisedFilesAllowNonPersonalisedSubmission & setTooltip MsgSheetPersonalisedFilesAllowNonPersonalisedSubmissionTip) (fmap spffAllowNonPersonalisedSubmission template' <|> Just True)

    validateSheet :: FormValidator SheetForm Handler ()
    validateSheet = do
      SheetForm{..} <- State.get

      guardValidation MsgSheetErrVisibility    $ NTop sfVisibleFrom  <= NTop sfActiveFrom
      guardValidation MsgSheetErrDeadlineEarly $ NTop sfActiveFrom   <= NTop sfActiveTo
      guardValidation MsgSheetErrHintEarly     $ NTop sfHintFrom     >= NTop sfActiveFrom
      guardValidation MsgSheetErrSolutionEarly $ NTop sfSolutionFrom >= NTop sfActiveTo

      guardValidation MsgSheetErrVisibleWithoutActive $ is _Just sfActiveFrom || is _Nothing sfVisibleFrom

      warnValidation MsgSheetWarnNoActiveTo $ is _Just sfActiveTo || is _Nothing sfActiveFrom

      warnValidation MsgSheetSubmissionModeNoneWithoutNotGraded
        $ classifySubmissionMode sfSubmissionMode /= SubmissionModeNone
       || sfType == NotGraded

correctorForm :: Loads -> AForm Handler Loads
correctorForm loads' = wFormToAForm $ do
  currentRoute <- fromMaybe (error "correctorForm called from 404-handler") <$> liftHandler getCurrentRoute
  userId <- liftHandler requireAuthId
  MsgRenderer mr <- getMsgRenderer

  let
    loads :: Map (Either UserEmail UserId) (CorrectorState, Load)
    loads = loads' <&> \(InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector) -> (cState, load)

  countTutRes <- wpopt checkBoxField (fslI MsgCountTutProp & setTooltip MsgCountTutPropTip) . Just . any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads

  let
    previousCorrectors :: E.SqlQuery (E.SqlExpr (Entity User))
    previousCorrectors = E.from $ \(user `E.InnerJoin` sheetCorrector `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` lecturer) -> do
      E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
      E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
      E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
      E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
      E.where_ $ lecturer E.^. LecturerUser E.==. E.val userId
      E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
      return user

    miAdd :: ListPosition
          -> Natural
          -> ListLength
          -> (Text -> Text)
          -> FieldView UniWorX
          -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
    miAdd _ _ _ nudge submitView = Just $ \csrf -> do
      (addRes, addView) <- mpreq (multiUserInvitationField . MUILookupAnyUser $ Just previousCorrectors) (fslpI MsgSheetCorrector (mr MsgLdapIdentificationOrEmail) & setTooltip MsgMultiEmailFieldTip & addName (nudge "corrector")) Nothing
      let addRes' = addRes <&> \nCorrs oldData@(maybe 0 (succ . fst) . Map.lookupMax -> kStart) -> if
            | existing <- Set.intersection nCorrs . Set.fromList $ Map.elems oldData
            , not $ null existing
              -> FormFailure [mr MsgCorrectorExists]
            | otherwise
              -> FormSuccess . Map.fromList . zip [kStart..] $ Set.toList nCorrs
      return (addRes', $(widgetFile "sheetCorrectors/add"))

    miCell :: ListPosition
           -> Either UserEmail UserId
           -> Maybe (CorrectorState, Load)
           -> (Text -> Text)
           -> Form (CorrectorState, Load)
    miCell _ userIdent initRes nudge csrf = do
      (stateRes, stateView) <- mreq (selectField optionsFinite) (fslI MsgSheetCorrectorState & addName (nudge "state")) $ (fst <$> initRes) <|> Just CorrectorNormal
      (byTutRes, byTutView) <- mreq checkBoxField ("" & addName (nudge "bytut")) $ (isJust . byTutorial . snd <$> initRes) <|> Just False
      (deficitRes, deficitView) <- mreq checkBoxField ("" & addName (nudge "deficit")) $ ((/= 0) . byDeficit . snd <$> initRes) <|> Just True
      (propRes, propView) <- mreq (checkBool (>= 0) MsgProportionNegative rationalField) (fslI MsgSheetCorrectorProportion & addName (nudge "prop")) $ (byProportion . snd <$> initRes) <|> Just 0
      let
        res :: FormResult (CorrectorState, Load)
        res = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes <*> deficitRes')
        tutRes'
          | FormSuccess True <- byTutRes  = Just <$> countTutRes
          | otherwise                     = Nothing <$ byTutRes
        deficitRes' = bool 0 1 <$> deficitRes
      identWidget <- case userIdent of
        Left email -> return . toWidget $ mailtoHtml email
        Right uid -> do
          User{userEmail, userDisplayName, userSurname} <- liftHandler . runDB $ getJust uid
          return $ nameEmailWidget userEmail userDisplayName userSurname
      invWarnMsg <- messageIconI Info IconEmail MsgEmailInvitationWarning
      return (res, $(widgetFile "sheetCorrectors/cell"))


    miDelete :: Map ListPosition (Either UserEmail UserId)
             -> ListPosition
             -> MaybeT (MForm Handler) (Map ListPosition ListPosition)
    miDelete = miDeleteList

    miAddEmpty :: ListPosition
               -> Natural
               -> ListLength
               -> Set ListPosition
    miAddEmpty _ _ _ = Set.empty

    miButtonAction :: forall p.
                      PathPiece p
                   => p
                   -> Maybe (SomeRoute UniWorX)
    miButtonAction frag = Just . SomeRoute $ currentRoute :#: frag

    miLayout :: ListLength
             -> Map ListPosition (Either UserEmail UserId, FormResult (CorrectorState, Load))
             -> Map ListPosition Widget
             -> Map ListPosition (FieldView UniWorX)
             -> Map (Natural, ListPosition) Widget
             -> Widget
    miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "sheetCorrectors/layout")

    miIdent :: Text
    miIdent = "correctors"

    postProcess :: Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)) -> Loads
    postProcess = Map.fromList . map postProcess' . Map.elems
      where
        postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> (Either UserEmail UserId, (InvitationDBData SheetCorrector, InvitationTokenData SheetCorrector))
        postProcess' = over _2 $ \(cState, load) -> (InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector)

    filledData :: Maybe (Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)))
    filledData = Just . Map.fromList . zip [0..] $ Map.toList loads -- TODO orderBy Name?!

  fmap postProcess <$> massInputW MassInput{..} (fslI MsgCorrectors) False filledData
