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

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

import Import
import Handler.Exam.CorrectorInvite ()

import Handler.Utils
import Handler.Utils.Invitations
import Handler.Utils.Exam (evalExamModeDNF)

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

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

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

import qualified Data.Text.Lazy as LT

import qualified Data.Conduit.Combinators as C


data ExamForm = ExamForm
  { efName :: ExamName
  , efDescription :: Maybe StoredMarkup
  , efStart :: Maybe UTCTime
  , efEnd :: Maybe UTCTime
  , efVisibleFrom :: Maybe UTCTime
  , efRegisterFrom :: Maybe UTCTime
  , efRegisterTo :: Maybe UTCTime
  , efDeregisterUntil :: Maybe UTCTime
  , efPublishOccurrenceAssignments :: Maybe UTCTime
  , efPartsFrom :: Maybe UTCTime
  , efFinished :: Maybe UTCTime
  , efOccurrences :: Set ExamOccurrenceForm
  , efPublicStatistics :: Bool
  , efGradingRule :: Maybe ExamGradingRule
  , efBonusRule :: Maybe ExamBonusRule
  , efOccurrenceRule :: ExamOccurrenceRule
  , efExamMode :: ExamMode
  , efGradingMode :: ExamGradingMode
  , efOfficeSchools :: Set SchoolId
  , efStaff :: Maybe Text
  , efCorrectors :: Set (Either UserEmail UserId)
  , efExamParts :: Set ExamPartForm
  , efAuthorshipStatement :: Maybe I18nStoredMarkup
  }

data ExamOccurrenceForm = ExamOccurrenceForm
  { eofId :: Maybe CryptoUUIDExamOccurrence
  , eofName :: ExamOccurrenceName
  , eofRoom :: Maybe RoomReference
  , eofRoomHidden :: Bool
  , eofCapacity :: Maybe Word64
  , eofStart :: UTCTime
  , eofEnd :: Maybe UTCTime
  , eofDescription :: Maybe StoredMarkup
  } deriving (Show, Eq, Generic)

instance Ord ExamOccurrenceForm where
  compare = mconcat
    [ comparing eofName
    , comparing eofStart
    , comparing eofRoom
    , comparing eofEnd
    , comparing eofCapacity
    , comparing eofDescription
    , comparing eofRoomHidden
    , comparing eofId
    ]

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

instance Ord ExamPartForm where
  compare = mconcat
    [ comparing epfNumber
    , comparing epfName
    , comparing epfMaxPoints
    , comparing epfWeight
    , comparing epfId
    ]

makeLenses_ ''ExamForm

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

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


examForm :: ( MonadHandler m
            , HandlerSite m ~ UniWorX
            )
         => Entity Course -> Maybe ExamForm -> (Html -> MForm m (FormResult ExamForm, Widget))
examForm (Entity _ Course{..}) template csrf = hoist liftHandler $ do
  mr'@(MsgRenderer mr) <- getMsgRenderer
  (School{..}, mSchoolAuthorshipStatement) <- liftHandler . runDBRead $ do
    school@School{..} <- getJust courseSchool
    mSchoolAuthorshipStatement <- maybe (pure Nothing) getEntity schoolSheetExamAuthorshipStatementDefinition
    return (school, mSchoolAuthorshipStatement)

  flip (renderAForm FormStandard) csrf $ ExamForm
    <$> areq ciField (fslpI MsgTableExamName (mr MsgTableExamName) & setTooltip MsgExamNameTip) (efName <$> template)
    <*> aopt htmlField (fslI MsgExamDescription) (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 MsgExamPartsFrom (mr MsgDate) & setTooltip MsgExamPartsFromTip) (efPartsFrom <$> template)
    <*> aopt utcTimeField (fslpI MsgExamFinished (mr MsgDate) & setTooltip (bool MsgExamFinishedTip MsgExamFinishedTipCloseOnFinished $ is _ExamCloseOnFinished' schoolExamCloseMode)) (efFinished <$> template)
    <*  aformSection MsgExamFormOccurrences
    <*> examOccurrenceForm (efOccurrences <$> template)
    <*  aformSection MsgExamFormAutomaticFunctions
    <*> apopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (efPublicStatistics <$> template <|> Just True)
    <*> optionalActionA (examGradingRuleForm $ efGradingRule =<< template) (fslI MsgExamAutomaticGrading & setTooltip MsgExamAutomaticGradingTip) (is _Just . efGradingRule <$> template)
    <*> optionalActionA (examBonusRuleForm $ efBonusRule =<< template) (fslI MsgExamBonus) (is _Just . efBonusRule <$> template)
    <*> examOccurrenceRuleForm (efOccurrenceRule <$> template)
    <*  aformSection MsgExamFormMode
    <*> examModeForm (efExamMode <$> template)
    <*  aformSection MsgExamFormGrades
    <*> apopt (selectField optionsFinite) (fslI MsgExamGradingMode & setTooltip MsgExamGradingModeTip) (efGradingMode <$> template <|> Just ExamGradingMixed)
    <*> officeSchoolsForm (efOfficeSchools <$> template)
    <*> apreq' (textField & cfStrip) (fslpI MsgExamStaff (mr MsgExamStaff) & setTooltip MsgExamStaffTip) (efStaff <$> template)
    <*  aformSection MsgExamFormCorrection
    <*> examCorrectorsForm (efCorrectors <$> template)
    <*  aformSection MsgExamFormParts
    <*> examPartsForm (efExamParts <$> template)
    <*> let
          reqContentField :: (FieldSettings UniWorX -> FieldSettings UniWorX) -> AForm Handler I18nStoredMarkup
          reqContentField ttip = fmapAForm (formResultUnOpt mr' MsgSheetAuthorshipStatementContent)
                               $ i18nFieldA htmlField True (\_ -> Nothing) ("authorship-statement" :: Text)
                                 (fslI MsgSheetAuthorshipStatementContent & ttip)
                                 True
                                 ( fmap Just $     (efAuthorshipStatement =<< template)
                                               <|> (authorshipStatementDefinitionContent . entityVal <$> mSchoolAuthorshipStatement)
                                 )
          forcedContentField   = aforced forcedAuthorshipStatementField
                                 (fslI MsgExamAuthorshipStatementContent & setTooltip MsgExamAuthorshipStatementContentForcedTip)
          contentField ttipReq
            | not schoolSheetExamAuthorshipStatementAllowOther
            = fmap (fmap authorshipStatementDefinitionContent) . traverse forcedContentField $ entityVal <$> mSchoolAuthorshipStatement
            | otherwise
            = Just <$> reqContentField ttipReq
        in case schoolSheetExamAuthorshipStatementMode of
          SchoolAuthorshipStatementModeNone -> pure Nothing  -- suppress display of whole section incl. header
          otherMode -> aformSection MsgExamAuthorshipStatementSection
                    *> case otherMode of
                         SchoolAuthorshipStatementModeOptional -> optionalActionA (fmapAForm (formResultUnOpt mr' MsgSheetAuthorshipStatementContent) $ contentField id)
                                                                  (fslI MsgExamAuthorshipStatementRequired & setTooltip MsgExamAuthorshipStatementRequiredTip)
                                                                  ((is _Just . efAuthorshipStatement <$> template) <|> Just (is _Just mSchoolAuthorshipStatement))
                         SchoolAuthorshipStatementModeRequired -> contentField $ setTooltip MsgExamAuthorshipStatementRequiredForcedTip
                         _none                                 -> pure Nothing

officeSchoolsForm :: Maybe (Set SchoolId) -> AForm Handler (Set SchoolId)
officeSchoolsForm mPrev = wFormToAForm $ do
  currentRoute <- fromMaybe (error "officeSchoolsForm called from 404-handler") <$> getCurrentRoute

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

    miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([SchoolId] -> FormResult [SchoolId])
    miAdd' nudge submitView csrf = do
      (schoolRes, addView) <- mpopt schoolField ("" & addName (nudge "school")) Nothing
      let schoolRes' = schoolRes <&> \newDat oldDat -> FormSuccess (guardOn (newDat `notElem` oldDat) newDat)
      return (schoolRes', $(widgetFile "exam/schoolMassInput/add"))

    miCell' :: SchoolId -> Widget
    miCell' ssh = do
      School{..} <- liftHandler . runDB $ getJust ssh
      $(widgetFile "exam/schoolMassInput/cell")

    miLayout' :: MassInputLayout ListLength SchoolId ()
    miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "exam/schoolMassInput/layout")

  fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' ("exam-schools" :: Text) (fslI MsgExamExamOfficeSchools & setTooltip MsgExamExamOfficeSchoolsTip) False (Set.toList <$> mPrev)

examCorrectorsForm :: Maybe (Set (Either UserEmail UserId)) -> AForm Handler (Set (Either UserEmail UserId))
examCorrectorsForm mPrev = wFormToAForm $ do
  MsgRenderer mr <- getMsgRenderer
  currentRoute <- fromMaybe (error "examCorrectorForm called from 404-handler") <$> getCurrentRoute
  uid <- liftHandler 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 (multiUserInvitationField . MUILookupAnyUser $ Just corrUserSuggestions) (fslI MsgExamCorrectorEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
      let
        addRes'

          = 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) = do
      invWarnMsg <- messageIconI Info IconEmail MsgEmailInvitationWarning
      $(widgetFile "widgets/massinput/examCorrectors/cellInvitation")
    miCell' (Right userId) = do
      User{..} <- liftHandler . 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 MsgExamCorrectorsTip) False (Set.toList <$> mPrev)

examOccurrenceForm :: Maybe (Set ExamOccurrenceForm) -> AForm Handler (Set ExamOccurrenceForm)
examOccurrenceForm prev = wFormToAForm $ do
  currentRoute <- fromMaybe (error "examOccurrenceForm called from 404-handler") <$> 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) False $ Set.toList <$> prev
  where
    examOccurrenceForm' nudge mPrev csrf = do
      (eofIdRes, eofIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ eofId =<< mPrev)
      (eofNameRes, eofNameView) <- mpreq (textField & cfStrip & cfCI) (fslI MsgExamRoomName & addName (nudge "name")) (eofName <$> mPrev)
      (eofRoomRes', eofRoomView) <- ($ mempty) . renderAForm FormVertical $ (,)
        <$> roomReferenceFormOpt (fslI MsgExamRoomRoom & addName (nudge "room")) (eofRoom <$> mPrev)
        <*> apopt checkBoxField (fslI MsgExamRoomRoomHidden & setTooltip MsgExamRoomRoomHiddenTip & addName (nudge "room-hidden")) (eofRoomHidden <$> mPrev)
      let eofRoomRes = view _1 <$> eofRoomRes'
          eofRoomHiddenRes = view _2 <$> eofRoomRes'
      (eofCapacityRes, eofCapacityView) <- mopt (natFieldI MsgExamRoomCapacityNegative) (fslI MsgExamRoomCapacity & addName (nudge "capacity")) (eofCapacity <$> mPrev)
      (eofStartRes, eofStartView) <- mpreq utcTimeField (fslI MsgExamRoomStart & addName (nudge "start")) (eofStart <$> mPrev)
      (eofEndRes, eofEndView) <- mopt utcTimeField (fslI MsgExamRoomEnd & addName (nudge "end")) (eofEnd <$> mPrev)
      (eofDescRes, eofDescView) <- mopt htmlField (fslI MsgExamRoomDescription & addName (nudge "description")) (eofDescription <$> mPrev)

      return ( ExamOccurrenceForm
                 <$> eofIdRes
                 <*> eofNameRes
                 <*> eofRoomRes
                 <*> eofRoomHiddenRes
                 <*> eofCapacityRes
                 <*> eofStartRes
                 <*> eofEndRes
                 <*> 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
  currentRoute <- fromMaybe (error "examPartsForm called from 404-handler") <$> 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) False $ Set.toList <$> prev
  where
    examPartForm' nudge mPrev csrf = do
      (epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev)
      (epfNumberRes, epfNumberView) <- mpreq (isoField (from _ExamPartNumber) $ textField & cfStrip & cfCI) (fslI MsgExamPartNumber & addName (nudge "number") & addPlaceholder "1, 6a, 3.1.4, ...") (epfNumber <$> mPrev)
      (epfNameRes, epfNameView) <- mopt (textField & cfStrip & cfCI) (fslI MsgExamPartName & addName (nudge "name")) (epfName <$> mPrev)
      (epfMaxPointsRes, epfMaxPointsView) <- mopt pointsField (fslI MsgExamPartMaxPoints & addName (nudge "max-points")) (epfMaxPoints <$> mPrev)
      (epfWeightRes, epfWeightView) <- mpreq (checkBool (>= 0) MsgExamPartWeightNegative rationalField) (fslI MsgExamPartWeight & addName (nudge "weight")) (epfWeight <$> mPrev <|> Just 1)

      return ( ExamPartForm
                 <$> epfIdRes
                 <*> epfNumberRes
                 <*> 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 (\old -> Just True == ((==) <$> epfName newDat <*> epfName old)) 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 :: ( MonadHandler m, HandlerSite m ~ UniWorX
                    , MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey
                    )
                 => Entity Exam -> SqlPersistT m ExamForm
examFormTemplate (Entity eId Exam{..}) = do
  examParts <- selectList [ ExamPartExam ==. eId ] []
  occurrences <- selectList [ ExamOccurrenceExam ==. eId ] []
  correctors <- selectList [ ExamCorrectorExam ==. eId ] []
  invitations <- Map.keysSet <$> sourceInvitationsF @ExamCorrector eId
  extraSchools <- selectList [ ExamOfficeSchoolExam ==. eId ] []

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

  mAuthorshipStatement <- maybe (pure Nothing) getEntity examAuthorshipStatement

  return ExamForm
    { efName             = examName
    , efGradingRule      = examGradingRule
    , efBonusRule        = examBonusRule
    , efOccurrenceRule   = examOccurrenceRule
    , efVisibleFrom      = examVisibleFrom
    , efRegisterFrom     = examRegisterFrom
    , efRegisterTo       = examRegisterTo
    , efDeregisterUntil  = examDeregisterUntil
    , efPublishOccurrenceAssignments = examPublishOccurrenceAssignments
    , efPartsFrom        = examPartsFrom
    , efStart            = examStart
    , efEnd              = examEnd
    , efFinished         = examFinished
    , efGradingMode      = examGradingMode
    , efPublicStatistics = examPublicStatistics
    , efDescription      = examDescription
    , efOccurrences      = Set.fromList $ do
        (Just -> eofId, ExamOccurrence{..}) <- occurrences'
        return ExamOccurrenceForm
          { eofId
          , eofName        = examOccurrenceName
          , eofRoom        = examOccurrenceRoom
          , eofRoomHidden  = examOccurrenceRoomHidden
          , eofCapacity    = examOccurrenceCapacity
          , eofStart       = examOccurrenceStart
          , eofEnd         = examOccurrenceEnd
          , eofDescription = examOccurrenceDescription
          }
    , efExamParts        = Set.fromList $ do
        (Just -> epfId, ExamPart{..}) <- examParts'
        return ExamPartForm
          { epfId
          , epfNumber    = examPartNumber
          , epfName      = examPartName
          , epfMaxPoints = examPartMaxPoints
          , epfWeight    = examPartWeight
          }
    , efCorrectors       = Set.unions
      [ Set.mapMonotonic Left invitations
      , Set.fromList . map Right $ do
          Entity _ ExamCorrector{..} <- correctors
          return examCorrectorUser
      ]
    , efExamMode         = examExamMode
    , efOfficeSchools    = Set.fromList $ examOfficeSchoolSchool . entityVal <$> extraSchools
    , efStaff            = examStaff
    , efAuthorshipStatement = authorshipStatementDefinitionContent . entityVal <$> mAuthorshipStatement
    }

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

  [(Entity _ oldCourse, Entity oldExamId oldExam, mOldExamAuthorshipStatement)] <- lift . E.select . E.from $ \(course `E.InnerJoin` (exam `E.LeftOuterJoin` authorshipStatementDefinition)) -> do
    E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
    E.on $ exam E.^. ExamAuthorshipStatement E.==. authorshipStatementDefinition E.?. AuthorshipStatementDefinitionId
    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, authorshipStatementDefinition)
  
  extraSchools <- lift $ selectList [ ExamOfficeSchoolExam ==. oldExamId ] []

  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
    , efPartsFrom        = dateOffset <$> examPartsFrom oldExam
    , efStart            = dateOffset <$> examStart oldExam
    , efEnd              = dateOffset <$> examEnd oldExam
    , efFinished         = dateOffset <$> examFinished oldExam
    , efGradingMode      = examGradingMode oldExam
    , efPublicStatistics = examPublicStatistics oldExam
    , efDescription      = examDescription oldExam
    , efOccurrences      = Set.empty
    , efExamParts        = Set.empty
    , efCorrectors       = Set.empty
    , efExamMode         = examExamMode oldExam
    , efStaff            = examStaff oldExam
    , efOfficeSchools    = Set.fromList $ examOfficeSchoolSchool . entityVal <$> extraSchools
    , efAuthorshipStatement = authorshipStatementDefinitionContent . entityVal <$> mOldExamAuthorshipStatement
    }


validateExam :: forall m.
                ( MonadHandler m
                , HandlerSite m ~ UniWorX
                , MonadSite UniWorX (SqlPersistT m)
                , MonadCryptoKey m ~ CryptoIDKey
                )
             => CourseId -> Maybe (Entity Exam) -> FormValidator ExamForm (SqlPersistT m) ()
validateExam cId oldExam = do
  ExamForm{..} <- State.get

  guardValidation MsgExamRegisterToMustBeAfterRegisterFrom                 $ NTop efRegisterTo                   >= NTop efRegisterFrom
  guardValidation MsgExamDeregisterUntilMustBeAfterRegisterFrom            $ NTop efDeregisterUntil              >= NTop efRegisterFrom
  guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments      $ Just False /= ((>=) <$> efStart <*> efPublishOccurrenceAssignments)
  guardValidation MsgExamEndMustBeAfterStart                               $ NTop efEnd                          >= NTop efStart
  warnValidation  MsgExamFinishedMustBeAfterEnd                            $ Just False /= ((>=) <$> efFinished <*> efEnd)
  guardValidation MsgExamFinishedMustBeAfterStart                          $ Just False /= ((>=) <$> efFinished <*> efStart)
  guardValidation MsgExamPartsFromMustBeBeforeFinished                     $ NTop efFinished                     >= NTop efPartsFrom
                                                                          || is _Nothing efPartsFrom

  forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do
    guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName)       $ NTop eofEnd >= NTop (Just eofStart)
    guardValidation (MsgExamOccurrenceStartMustBeAfterExamStart eofName) $ NTop (Just eofStart) >= NTop efStart
    warnValidation  (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)

    MsgRenderer mr <- getMsgRenderer
    guardValidation (MsgExamOccurrenceDuplicate (maybe (mr MsgExamOccurrenceRoomIsUnset) roomReferenceText $ eofRoom a) eofRange') $ any (\f -> f a b)
      [ (/=) `on` eofRoom
      , (/=) `on` eofStart
      , (/=) `on` eofEnd
      , (/=) `on` fmap (LT.strip . renderHtml . markupOutput) . eofDescription
      ]

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

  oldOccurrencesWithRegistrations <- for oldExam $ \(Entity eId _) -> lift . E.select . E.from $ \examOccurrence -> do
    E.where_ $ examOccurrence E.^. ExamOccurrenceExam E.==. E.val eId
    E.where_ . E.exists . E.from $ \examRegistration ->
      E.where_ $ examRegistration E.^. ExamRegistrationOccurrence E.==. E.just (examOccurrence E.^. ExamOccurrenceId)
    return ( examOccurrence E.^. ExamOccurrenceId
           , examOccurrence E.^. ExamOccurrenceName
           )
  forM_ (join $ hoistMaybe oldOccurrencesWithRegistrations) $ \(E.Value eoId, E.Value eoName) ->
    guardValidationM (MsgExamOccurrenceCannotBeDeletedDueToRegistrations eoName) . lift . anyM (otoList efOccurrences) $ \ExamOccurrenceForm{..} -> (== Just eoId) <$> traverse decrypt eofId


  oldPartsWithResults <- for oldExam $ \(Entity eId _) -> lift . E.select . E.from $ \examPart -> do
    E.where_ $ examPart E.^. ExamPartExam E.==. E.val eId
    E.where_ . E.exists . E.from $ \examPartResult ->
      E.where_ $ examPartResult E.^. ExamPartResultExamPart E.==. examPart E.^. ExamPartId
    return ( examPart E.^. ExamPartId
           , examPart E.^. ExamPartNumber
           )
  forM_ (join $ hoistMaybe oldPartsWithResults) $ \(E.Value epId, E.Value epNumber) -> do
    guardValidationM (MsgExamPartCannotBeDeletedDueToResults epNumber) . anyM (otoList efExamParts) $ \ExamPartForm{..} -> (== Just epId) <$> traverse decrypt epfId
    runConduit $ transPipe lift (selectSource [] [])
              .| C.filter (has $ _entityVal . _sheetType . _examPart . re _SqlKey . only epId)
              .| C.mapM_ (\(Entity _ Sheet{..}) -> guardValidationM (MsgExamPartCannotBeDeletedDueToSheetReference epNumber sheetName) . anyM (otoList efExamParts) $ \ExamPartForm{..} -> (== Just epId) <$> traverse decrypt epfId)


  mSchool <- liftHandler . runDB . E.selectMaybe . E.from $ \(course `E.InnerJoin` school) -> do
    E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
    E.where_ $ course E.^. CourseId E.==. E.val cId
    return school

  whenIsJust mSchool $ \(Entity _ School{..}) -> do
    whenIsJust schoolExamMinimumRegisterBeforeStart $ \minSep -> do
      let doValidation
            | Just (Entity _ Exam{..}) <- oldExam
            , not . fromMaybe True $ (>=) <$> examStart <*> (addUTCTime minSep <$> examRegisterFrom)
            = warnValidation
            | otherwise
            = guardValidation
      doValidation (MsgExamRegistrationMustFollowSchoolSeparationFromStart . ceiling $ minSep / nominalDay)
        . fromMaybe True $ (>=) <$> efStart <*> (addUTCTime minSep <$> efRegisterFrom)
    whenIsJust schoolExamMinimumRegisterDuration $ \minDur -> do
      let doValidation
            | Just (Entity _ Exam{..}) <- oldExam
            , not . fromMaybe True $ (>=) <$> examRegisterTo <*> (addUTCTime minDur <$> examRegisterFrom)
            = warnValidation
            | otherwise
            = guardValidation
      doValidation (MsgExamRegistrationMustFollowSchoolDuration . ceiling $ minDur / nominalDay)
        . fromMaybe True $ (>=) <$> efRegisterTo <*> (addUTCTime minDur <$> efRegisterFrom)
    when schoolExamRequireModeForRegistration $ do
      let doValidation
            | Just (Entity _ Exam{ examExamMode = ExamMode{..}, .. }) <- oldExam
            , or [ is _Nothing examAids
                 , is _Nothing examOnline
                 , is _Nothing examSynchronicity
                 , is _Nothing examRequiredEquipment
                 ]
            , is _Just examRegisterFrom
            = warnValidation
            | otherwise
            = guardValidation
      let ExamMode{..} = efExamMode
      doValidation MsgExamModeRequiredForRegistration
        $ is _Nothing efRegisterFrom
       || and [ is _Just examAids
              , is _Just examOnline
              , is _Just examSynchronicity
              , is _Just examRequiredEquipment
              ]

    warnValidation MsgExamModeSchoolDiscouraged . not $ evalExamModeDNF schoolExamDiscouragedModes efExamMode

  unless (has (_Just . _entityVal . _examStaff . _Nothing) oldExam) $
    guardValidation MsgExamStaffRequired $ isn't _Nothing efStaff