module Handler.Exam.Form
  ( ExamForm(..)
  , ExamOccurrenceForm(..)
  , ExamPartForm(..)
  , examForm
  , examFormTemplate, examTemplate
  , validateExam
  ) where

import Import
import Utils.Lens hiding (parts)

import Handler.Exam.CorrectorInvite

import Handler.Utils
import Handler.Utils.Invitations

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

import qualified Database.Esqueleto as E

import qualified Control.Monad.State.Class as State
import Text.Blaze.Html.Renderer.String (renderHtml)


data ExamForm = ExamForm
  { efName :: ExamName
  , efDescription :: Maybe Html
  , efStart :: Maybe UTCTime
  , efEnd :: Maybe UTCTime
  , efVisibleFrom :: Maybe UTCTime
  , efRegisterFrom :: Maybe UTCTime
  , efRegisterTo :: Maybe UTCTime
  , efDeregisterUntil :: Maybe UTCTime
  , efPublishOccurrenceAssignments :: Maybe UTCTime
  , efFinished :: Maybe UTCTime
  , efClosed :: Maybe UTCTime
  , efOccurrences :: Set ExamOccurrenceForm
  , efShowGrades :: Bool
  , efPublicStatistics :: Bool
  , efGradingRule :: ExamGradingRule
  , efBonusRule :: ExamBonusRule
  , efOccurrenceRule :: ExamOccurrenceRule
  , efCorrectors :: Set (Either UserEmail UserId)
  , efExamParts :: Set ExamPartForm
  }

data ExamOccurrenceForm = ExamOccurrenceForm
  { eofId :: Maybe CryptoUUIDExamOccurrence
  , eofName :: ExamOccurrenceName
  , eofRoom :: Text
  , eofCapacity :: Natural
  , eofStart :: UTCTime
  , eofEnd :: Maybe UTCTime
  , eofDescription :: Maybe Html
  } deriving (Read, Show, Eq, Ord, Generic, Typeable)

data ExamPartForm = ExamPartForm
  { epfId :: Maybe CryptoUUIDExamPart
  , epfName :: ExamPartName
  , epfMaxPoints :: Maybe Points
  , epfWeight :: Rational
  } deriving (Read, Show, Eq, Ord, Generic, Typeable)

makeLenses_ ''ExamForm

deriveJSON defaultOptions
  { fieldLabelModifier = camelToPathPiece' 1
  } ''ExamPartForm

deriveJSON defaultOptions
  { fieldLabelModifier = camelToPathPiece' 1
  } ''ExamOccurrenceForm


examForm :: Maybe ExamForm -> Form ExamForm
examForm template html = do
  MsgRenderer mr <- getMsgRenderer

  flip (renderAForm FormStandard) html $ ExamForm
    <$> areq ciField (fslpI MsgExamName (mr MsgExamName) & setTooltip MsgExamNameTip) (efName <$> template)
    <*> (assertM (not . null . renderHtml) <$> aopt htmlField (fslpI MsgExamDescription "Html") (efDescription <$> template))
    <*  aformSection MsgExamFormTimes
    <*> aopt utcTimeField (fslpI MsgExamStart (mr MsgDate) & setTooltip MsgExamTimeTip) (efStart <$> template)
    <*> aopt utcTimeField (fslpI MsgExamEnd (mr MsgDate) & setTooltip MsgExamTimeTip) (efEnd <$> template)
    <*> aopt utcTimeField (fslpI MsgExamVisibleFrom (mr MsgDate) & setTooltip MsgExamVisibleFromTip) (efVisibleFrom <$> template)
    <*> aopt utcTimeField (fslpI MsgExamRegisterFrom (mr MsgDate) & setTooltip MsgExamRegisterFromTip) (efRegisterFrom <$> template)
    <*> aopt utcTimeField (fslpI MsgExamRegisterTo (mr MsgDate)) (efRegisterTo <$> template)
    <*> aopt utcTimeField (fslpI MsgExamDeregisterUntil (mr MsgDate)) (efDeregisterUntil <$> template)
    <*> aopt utcTimeField (fslpI MsgExamPublishOccurrenceAssignments (mr MsgDate) & setTooltip MsgExamPublishOccurrenceAssignmentsTip) (efPublishOccurrenceAssignments <$> template)
    <*> aopt utcTimeField (fslpI MsgExamFinished (mr MsgDate) & setTooltip MsgExamFinishedTip) (efFinished <$> template)
    <*> aopt utcTimeField (fslpI MsgExamClosed (mr MsgDate) & setTooltip MsgExamClosedTip) (efClosed <$> template)
    <*  aformSection MsgExamFormOccurrences
    <*> examOccurrenceForm (efOccurrences <$> template)
    <*  aformSection MsgExamFormAutomaticFunctions
    <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamShowGrades & setTooltip MsgExamShowGradesTip) (Just . efShowGrades <$> template))
    <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (Just . efPublicStatistics <$> template))
    <*> examGradingRuleForm (efGradingRule <$> template)
    <*> examBonusRuleForm (efBonusRule <$> template)
    <*> examOccurrenceRuleForm (efOccurrenceRule <$> template)
    <*  aformSection MsgExamFormCorrection
    <*> examCorrectorsForm (efCorrectors <$> template)
    <*  aformSection MsgExamFormParts
    <*> examPartsForm (efExamParts <$> template)

examCorrectorsForm :: Maybe (Set (Either UserEmail UserId)) -> AForm Handler (Set (Either UserEmail UserId))
examCorrectorsForm mPrev = wFormToAForm $ do
  MsgRenderer mr <- getMsgRenderer
  Just currentRoute <- getCurrentRoute
  uid <- liftHandlerT requireAuthId

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

    miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId])
    miAdd' nudge submitView csrf = do
      (addRes, addView) <- mpreq (multiUserField False $ Just corrUserSuggestions) ("" & addName (nudge "email")) Nothing
      let
        addRes'
          | otherwise
          = addRes <&> \newDat oldDat -> if
              | existing <- newDat `Set.intersection` Set.fromList oldDat
              , not $ Set.null existing
                -> FormFailure [mr MsgExamCorrectorAlreadyAdded]
              | otherwise
                -> FormSuccess $ Set.toList newDat
      return (addRes', $(widgetFile "widgets/massinput/examCorrectors/add"))

    corrUserSuggestions :: E.SqlQuery (E.SqlExpr (Entity User))
    corrUserSuggestions = E.from $ \(lecturer `E.InnerJoin` course `E.InnerJoin` exam `E.InnerJoin` corrector `E.InnerJoin` corrUser) -> do
      E.on $ corrUser E.^. UserId E.==. corrector E.^. ExamCorrectorUser
      E.on $ corrector E.^. ExamCorrectorExam E.==. exam E.^. ExamId
      E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId
      E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
      E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
      return corrUser


    miCell' :: Either UserEmail UserId -> Widget
    miCell' (Left email) =
      $(widgetFile "widgets/massinput/examCorrectors/cellInvitation")
    miCell' (Right userId) = do
      User{..} <- liftHandlerT . runDB $ get404 userId
      $(widgetFile "widgets/massinput/examCorrectors/cellKnown")

    miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) ()
    miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examCorrectors/layout")

  fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' ("correctors" :: Text) (fslI MsgExamCorrectors & setTooltip MsgMassInputTip) False (Set.toList <$> mPrev)

examOccurrenceForm :: Maybe (Set ExamOccurrenceForm) -> AForm Handler (Set ExamOccurrenceForm)
examOccurrenceForm prev = wFormToAForm $ do
  Just currentRoute <- getCurrentRoute
  let
    miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
    miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag

  fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamOccurrences & setTooltip MsgMassInputTip) False $ Set.toList <$> prev
  where
    examOccurrenceForm' nudge mPrev csrf = do
      (eofIdRes, eofIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ eofId =<< mPrev)
      (eofNameRes, eofNameView) <- mpreq ciField ("" & addName (nudge "name")) (eofName <$> mPrev)
      (eofRoomRes, eofRoomView) <- mpreq textField ("" & addName (nudge "room")) (eofRoom <$> mPrev)
      (eofCapacityRes, eofCapacityView) <- mpreq (natFieldI MsgExamRoomCapacityNegative) ("" & addName (nudge "capacity")) (eofCapacity <$> mPrev)
      (eofStartRes, eofStartView) <- mpreq utcTimeField ("" & addName (nudge "start")) (eofStart <$> mPrev)
      (eofEndRes, eofEndView) <- mopt utcTimeField ("" & addName (nudge "end")) (eofEnd <$> mPrev)
      (eofDescRes, eofDescView) <- mopt htmlFieldSmall ("" & addName (nudge "description")) (eofDescription <$> mPrev)

      return ( ExamOccurrenceForm
                 <$> eofIdRes
                 <*> eofNameRes
                 <*> eofRoomRes
                 <*> eofCapacityRes
                 <*> eofStartRes
                 <*> eofEndRes
                 <*> (assertM (not . null . renderHtml) <$> eofDescRes)
             , $(widgetFile "widgets/massinput/examRooms/form")
             )

    miAdd' nudge submitView csrf = do
      MsgRenderer mr <- getMsgRenderer
      (res, formWidget) <- examOccurrenceForm' nudge Nothing csrf
      let
        addRes = res <&> \newDat (Set.fromList -> oldDat) -> if
          | newDat `Set.member` oldDat -> FormFailure [mr MsgExamRoomAlreadyExists]
          | otherwise -> FormSuccess $ pure newDat
      return (addRes, $(widgetFile "widgets/massinput/examRooms/add"))
    miCell' nudge dat = examOccurrenceForm' nudge (Just dat)
    miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examRooms/layout")
    miIdent' :: Text
    miIdent' = "exam-occurrences"

examPartsForm :: Maybe (Set ExamPartForm) -> AForm Handler (Set ExamPartForm)
examPartsForm prev = wFormToAForm $ do
  Just currentRoute <- getCurrentRoute
  let
    miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
    miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag

  fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamParts & setTooltip MsgMassInputTip) False $ Set.toList <$> prev
  where
    examPartForm' nudge mPrev csrf = do
      (epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev)
      (epfNameRes, epfNameView) <- mpreq ciField ("" & addName (nudge "name")) (epfName <$> mPrev)
      (epfMaxPointsRes, epfMaxPointsView) <- mopt pointsField ("" & addName (nudge "max-points")) (epfMaxPoints <$> mPrev)
      (epfWeightRes, epfWeightView) <- mpreq (checkBool (>= 0) MsgExamPartWeightNegative rationalField) ("" & addName (nudge "weight")) (epfWeight <$> mPrev <|> Just 1)

      return ( ExamPartForm
                 <$> epfIdRes
                 <*> epfNameRes
                 <*> epfMaxPointsRes
                 <*> epfWeightRes
             , $(widgetFile "widgets/massinput/examParts/form")
             )

    miAdd' nudge submitView csrf = do
      MsgRenderer mr <- getMsgRenderer
      (res, formWidget) <- examPartForm' nudge Nothing csrf
      let
        addRes = res <&> \newDat (Set.fromList -> oldDat) -> if
          | any (((==) `on` epfName) newDat) oldDat -> FormFailure [mr MsgExamPartAlreadyExists]
          | otherwise -> FormSuccess $ pure newDat
      return (addRes, $(widgetFile "widgets/massinput/examParts/add"))
    miCell' nudge dat = examPartForm' nudge (Just dat)
    miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examParts/layout")
    miIdent' :: Text
    miIdent' = "exam-parts"

examFormTemplate :: Entity Exam -> DB ExamForm
examFormTemplate (Entity eId Exam{..}) = do
  parts <- selectList [ ExamPartExam ==. eId ] []
  occurrences <- selectList [ ExamOccurrenceExam ==. eId ] []
  correctors <- selectList [ ExamCorrectorExam ==. eId ] []
  invitations <- map (\(email, InvDBDataExamCorrector) -> email) <$> sourceInvitationsList eId

  parts' <- forM parts $ \(Entity pid part) -> (,) <$> encrypt pid <*> pure part
  occurrences' <- forM occurrences $ \(Entity oid occ) -> (,) <$> encrypt oid <*> pure occ

  return ExamForm
    { efName             = examName
    , efGradingRule      = examGradingRule
    , efBonusRule        = examBonusRule
    , efOccurrenceRule   = examOccurrenceRule
    , efVisibleFrom      = examVisibleFrom
    , efRegisterFrom     = examRegisterFrom
    , efRegisterTo       = examRegisterTo
    , efDeregisterUntil  = examDeregisterUntil
    , efPublishOccurrenceAssignments = examPublishOccurrenceAssignments
    , efStart            = examStart
    , efEnd              = examEnd
    , efFinished         = examFinished
    , efClosed           = examClosed
    , efShowGrades       = examShowGrades
    , efPublicStatistics = examPublicStatistics
    , efDescription      = examDescription
    , efOccurrences      = Set.fromList $ do
        (Just -> eofId, ExamOccurrence{..}) <- occurrences'
        return ExamOccurrenceForm
          { eofId
          , eofName        = examOccurrenceName
          , eofRoom        = examOccurrenceRoom
          , eofCapacity    = examOccurrenceCapacity
          , eofStart       = examOccurrenceStart
          , eofEnd         = examOccurrenceEnd
          , eofDescription = examOccurrenceDescription
          }
    , efExamParts        = Set.fromList $ do
        (Just -> epfId, ExamPart{..}) <- parts'
        return ExamPartForm
          { epfId
          , epfName      = examPartName
          , epfMaxPoints = examPartMaxPoints
          , epfWeight    = examPartWeight
          }
    , efCorrectors       = Set.unions
      [ Set.fromList $ map Left invitations
      , Set.fromList . map Right $ do
          Entity _ ExamCorrector{..} <- correctors
          return examCorrectorUser
      ]
    }

examTemplate :: CourseId -> DB (Maybe ExamForm)
examTemplate cid = runMaybeT $ do
  newCourse <- MaybeT $ get cid

  [(Entity _ oldCourse, Entity _ oldExam)] <- lift . E.select . E.from $ \(course `E.InnerJoin` exam) -> do
    E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
    E.where_ $ (       course E.^. CourseShorthand E.==. E.val (courseShorthand newCourse)
                 E.||. course E.^. CourseName E.==. E.val (courseName newCourse)
               )
         E.&&. course E.^. CourseSchool E.==. E.val (courseSchool newCourse)
    E.where_ . E.not_ . E.exists . E.from $ \exam' -> do
      E.where_ $ exam' E.^. ExamCourse E.==. E.val cid
      E.where_ $ exam E.^. ExamName E.==. exam' E.^. ExamName
    E.where_ . E.not_ . E.isNothing $ exam E.^. ExamVisibleFrom
    E.limit 1
    E.orderBy [ E.desc $ course E.^. CourseTerm, E.asc $ exam E.^. ExamVisibleFrom ]
    return (course, exam)

  oldTerm <- MaybeT . get $ courseTerm oldCourse
  newTerm <- MaybeT . get $ courseTerm newCourse

  let
    dateOffset = over _utctDay . addDays $ (diffDays `on` termLectureEnd) newTerm oldTerm

  return ExamForm
    { efName             = examName oldExam
    , efGradingRule      = examGradingRule oldExam
    , efBonusRule        = examBonusRule oldExam
    , efOccurrenceRule   = examOccurrenceRule oldExam
    , efVisibleFrom      = dateOffset <$> examVisibleFrom oldExam
    , efRegisterFrom     = dateOffset <$> examRegisterFrom oldExam
    , efRegisterTo       = dateOffset <$> examRegisterTo oldExam
    , efDeregisterUntil  = dateOffset <$> examDeregisterUntil oldExam
    , efPublishOccurrenceAssignments = dateOffset <$> examPublishOccurrenceAssignments oldExam
    , efStart            = dateOffset <$> examStart oldExam
    , efEnd              = dateOffset <$> examEnd oldExam
    , efFinished         = dateOffset <$> examFinished oldExam
    , efClosed           = dateOffset <$> examClosed oldExam
    , efShowGrades       = examShowGrades oldExam
    , efPublicStatistics = examPublicStatistics oldExam
    , efDescription      = examDescription oldExam
    , efOccurrences      = Set.empty
    , efExamParts        = Set.empty
    , efCorrectors       = Set.empty
    }


validateExam :: (MonadHandler m, HandlerSite m ~ UniWorX) => FormValidator ExamForm m ()
validateExam = do
  ExamForm{..} <- State.get

  guardValidation MsgExamRegisterToMustBeAfterRegisterFrom                 $ NTop efRegisterTo                   >= NTop efRegisterFrom
  guardValidation MsgExamDeregisterUntilMustBeAfterRegisterFrom            $ NTop efDeregisterUntil              >= NTop efRegisterFrom
  guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments      . fromMaybe True $ (>=) <$> efStart <*> efPublishOccurrenceAssignments
  guardValidation MsgExamEndMustBeAfterStart                               $ NTop efEnd                          >= NTop efStart
  guardValidation MsgExamFinishedMustBeAfterEnd                            . fromMaybe True $ (>=) <$> efFinished <*> efEnd
  guardValidation MsgExamFinishedMustBeAfterStart                          $ NTop efFinished                     >= NTop efStart
  guardValidation MsgExamClosedMustBeAfterFinished                         . fromMaybe True $ (>=) <$> efClosed <*> efFinished
  guardValidation MsgExamClosedMustBeAfterStart                            $ NTop efClosed                       >= NTop efStart
  guardValidation MsgExamClosedMustBeAfterEnd                              . fromMaybe True $ (>=) <$> efClosed <*> efEnd

  forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do
    guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName)       $ NTop eofEnd >= NTop (Just eofStart)
    guardValidation (MsgExamOccurrenceStartMustBeAfterExamStart eofName) $ NTop (Just eofStart) >= NTop efStart
    warn_Validation (MsgExamOccurrenceEndMustBeBeforeExamEnd eofName)    $ NTop eofEnd <= NTop efEnd

  forM_ [ (a, b) | a <- Set.toAscList efOccurrences, b <- Set.toAscList efOccurrences, b > a ] $ \(a, b) -> do
    eofRange' <- formatTimeRange SelFormatDateTime (eofStart a) (eofEnd a)

    guardValidation (MsgExamOccurrenceDuplicate (eofRoom a) eofRange') $ any (\f -> f a b)
      [ (/=) `on` eofRoom
      , (/=) `on` eofStart
      , (/=) `on` eofEnd
      , (/=) `on` fmap renderHtml . eofDescription
      ]

    guardValidation (MsgExamOccurrenceDuplicateName $ eofName a) $ ((/=) `on` eofName) a b