-- 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
  , examOccurrenceMultiForm, examOccurrenceForm
  , upsertExamOccurrences, copyExamOccurrences
  , 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.Experimental as Ex
import qualified Database.Esqueleto.Utils as Ex

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

import Text.Pandoc.Shared (toRomanNumeral)
import qualified Data.Char      as Char
import qualified Data.Text      as Text
import qualified Data.Text.Lazy as LT
import qualified Data.CaseInsensitive as CI

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 :: Maybe ExamOccurrenceName
  , eofExaminer :: Maybe UserId
  , 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 eofExaminer
    , 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 (someMessages [MsgExamTimeTip,MsgExamTimeFilterTip])) (efStart <$> template)
    <*> aopt utcTimeField (fslpI MsgExamEnd             (mr MsgDate) & setTooltip (someMessages [MsgExamTimeTip,MsgExamTimeFilterTip])) (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
    <*> examOccurrenceMultiForm (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
      usr <- 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 :: (Text -> Text) -> Maybe ExamOccurrenceForm -> Form ExamOccurrenceForm
examOccurrenceForm nudge mPrev csrf = do
      (eofIdRes, eofIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ eofId =<< mPrev)
      (eofNameRes, eofNameView) <- mopt (textField & cfStrip & cfCI) (fslI MsgExamRoomName & addName (nudge "name")) (eofName <$> mPrev)
      (eofExaminerRes, eofExaminerView) <- mopt examinerField (fslI MsgExamStaff & addName (nudge "examiner")) (eofExaminer <$> mPrev) -- TODO: restrict suggestions!
      (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
                 <*> eofExaminerRes
                 <*> eofRoomRes
                 <*> eofRoomHiddenRes
                 <*> eofCapacityRes
                 <*> eofStartRes
                 <*> eofEndRes
                 <*> eofDescRes
             , $(widgetFile "widgets/massinput/examRooms/form")
             )
  where
    examinerField = knownUserField True $ Just $ E.from $ \usr -> do
      E.where_ $
        (E.exists . E.from $ \exCorr -> E.where_ $ exCorr E.^. ExamCorrectorUser          E.==.         usr E.^. UserId
        ) E.||.
        (E.exists . E.from $ \exOccr -> E.where_ $ exOccr E.^. ExamOccurrenceExaminer     E.==. E.just (usr E.^. UserId)
        )
      pure usr

examOccurrenceMultiForm :: Maybe (Set ExamOccurrenceForm) -> AForm Handler (Set ExamOccurrenceForm)
examOccurrenceMultiForm prev = wFormToAForm $ do
  currentRoute <- fromMaybe (error "examOccurrenceMultiForm 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
    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"


examOccurrenceTemplate :: ExamOccurrence -> ExamOccurrenceForm
examOccurrenceTemplate ExamOccurrence{..} = ExamOccurrenceForm{..}
  where
    eofId           = Nothing
    eofName         = Just examOccurrenceName
    eofExaminer     = examOccurrenceExaminer
    eofRoom         = examOccurrenceRoom
    eofRoomHidden   = examOccurrenceRoomHidden
    eofCapacity     = examOccurrenceCapacity
    eofStart        = examOccurrenceStart
    eofEnd          = examOccurrenceEnd
    eofDescription  = examOccurrenceDescription

-- | copy all exam occurrences of an exam, that start on a specified day, to another day, preserving everything else
--   if the occurrence name contains the day it is replaced, otherwise guessExamOccurrenceName is invoked
copyExamOccurrences :: forall backend m . (PersistUniqueRead backend, PersistQueryRead backend
                                        , PersistUniqueWrite backend,  BaseBackend backend ~ SqlBackend, BackendCompatible SqlBackend backend
                                        , MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX)
                         => Key Exam -> Day -> Day -> ReaderT backend m Int
copyExamOccurrences eId dfrom dto = do
  let dfts = ["%d.%m.%Y", "%d.%m.%y", "%Y-%m-%d", "%y-%m-%d", "%d.%m", "%d-%m", "%m-%d"]
      fts fs = (,) <$> formatTime' fs dfrom <*> formatTime' fs dto
      shiftDay :: Day -> Day = addDays $ diffDays dto dfrom
  drepl <- mapM fts dfts
  exOccs <- Ex.select $ do
    occ <- Ex.from $ Ex.table @ExamOccurrence
    Ex.where_ $ occ Ex.^. ExamOccurrenceExam Ex.==. Ex.val eId
        Ex.&&. Ex.day (occ Ex.^. ExamOccurrenceStart) Ex.==. Ex.val dfrom
    return occ
  res <- forM exOccs $ \Entity{entityVal=eo@ExamOccurrence{examOccurrenceName=oldName}} -> do
    let eo' = _examOccurrenceStart       . _utctDay %~ shiftDay $
              _examOccurrenceEnd . _Just . _utctDay %~ shiftDay $ eo
    newName <- maybeM (guessExamOccurrenceName eId $ examOccurrenceTemplate eo') return $ return (fmap CI.mk $ textReplaceFirst drepl $ CI.original oldName)
    insertUnique_ (eo'{examOccurrenceName=newName})
  memcachedInvalidateClass MemcachedKeyClassExamOccurrences
  return $ length $ catMaybes res

-- | generate an exam-unique occurrence name from data
--   Pattern: <initials-examiner>_<mm-dd>_<room>_<roman_numeral>
--   eofName is entirely ignored, assumed to be Nothing
guessExamOccurrenceName :: forall backend m . (PersistUniqueRead backend, PersistQueryRead backend, BaseBackend backend ~ SqlBackend, BackendCompatible SqlBackend backend
                                              , MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX)
                         => Key Exam -> ExamOccurrenceForm -> ReaderT backend m ExamOccurrenceName
guessExamOccurrenceName eId ExamOccurrenceForm{..} = do
    -- oday <- formatTime' "%m-%d" eofStart
    oday <- formatTime' "%d.%m." eofStart
    ohour <- ifM hasMoreThanOneHour (formatTime' "at%H"   eofStart) (return mempty)
    inis <- ifMoreThanOne ExamOccurrenceExaminer $ foldMapM getInitials eofExaminer
    room <- case eofRoom of
              Just (RoomReferenceSimple t) -> ifMoreThanOne ExamOccurrenceRoom $ return $ Text.take 4 t   -- Text.cons '-' $ Text.take 4 t
              _ -> return mempty
    let pfx  = CI.mk $ inis <> oday <> ohour <> room
        eons = ocheck pfx : [ ocheck $ pfx <> CI.mk (Text.cons '_' $ toRomanNumeral n) | n <- [2..3999]]
    fromMaybe "Handler.Exam.Form.guessExamOccurrenceName failed to guess a unique name"
      <$> firstJustM eons
  where
    getInitials uid = get uid <&> foldMap (Text.filter Char.isUpper . userDisplayName) -- flip Text.snoc '_' .
    ocheck eon = existsBy (UniqueExamOccurrence eId eon) <&> (flip toMaybe eon . not)

    ifMoreThanOne :: (PersistField t, Monoid o) => EntityField ExamOccurrence (Maybe t) -> ReaderT backend m o -> ReaderT backend m o
    ifMoreThanOne eoprop act = ifM (hasMoreThanOne eoprop) act (return mempty)

    hasMoreThanOne :: PersistField t => EntityField ExamOccurrence (Maybe t) -> ReaderT backend m Bool
    hasMoreThanOne eoprop = $(memcachedByHere) (Just . Right $ 1 * diffMinute) (eId, tshow $ persistFieldDef eoprop) $ Ex.selectExists $ do
      exOcc <- Ex.from $ Ex.table @ExamOccurrence
      Ex.where_ $ (exOcc Ex.^. ExamOccurrenceExam Ex.==. Ex.val eId)
          Ex.&&. Ex.isJust (exOcc Ex.^. eoprop)
          Ex.&&. Ex.exists (do
            otOcc <- Ex.from $ Ex.table @ExamOccurrence
            Ex.where_ $ (otOcc Ex.^. ExamOccurrenceExam Ex.==. Ex.val eId)
              Ex.&&.  Ex.isJust (otOcc Ex.^. eoprop)
              Ex.&&.  otOcc Ex.^. eoprop Ex.!=. exOcc Ex.^. eoprop
          )

    hasMoreThanOneHour :: ReaderT backend m Bool
    hasMoreThanOneHour = $(memcachedByHere) (Just . Right $ 1 * diffMinute) eId $ Ex.selectExists $ do
      exOcc <- Ex.from $ Ex.table @ExamOccurrence
      Ex.where_ $ (exOcc Ex.^. ExamOccurrenceExam Ex.==. Ex.val eId)
          Ex.&&. Ex.exists (do
            other <- Ex.from $ Ex.table @ExamOccurrence
            Ex.where_ $ (other Ex.^. ExamOccurrenceExam Ex.==. Ex.val eId)
              Ex.&&. (Ex.day (other Ex.^. ExamOccurrenceStart) Ex.==. Ex.day (exOcc Ex.^. ExamOccurrenceStart))
              Ex.&&. (        other Ex.^. ExamOccurrenceStart  Ex.!=.         exOcc Ex.^. ExamOccurrenceStart)
          )


-- upsertExamOccurrences :: (MonoFoldable mono, Element mono ~ ExamOccurrenceForm) => ExamId -> mono -> DB ()     -- too specific
upsertExamOccurrences :: ( HandlerSite m ~ UniWorX, MonadHandler m, MonadThrow m
                         , PersistQueryRead backend, PersistUniqueWrite backend
                         , BaseBackend backend ~ SqlBackend, BackendCompatible SqlBackend backend)
  => Key Exam -> [ExamOccurrenceForm] -> ReaderT backend m Int
upsertExamOccurrences eId = fmap (length . catMaybes) . mapM (\case
    eof@ExamOccurrenceForm{ eofId = Nothing, eofName = eofNameMb, .. } -> do
      eofName <- fromMaybeM (guessExamOccurrenceName eId eof) (pure eofNameMb)
      $logInfoS "ExamOccurrenceForm" [st|New Exam Occurrence: #{eofName}|]
      insertUnique_ ExamOccurrence
          { examOccurrenceExam = eId
          , examOccurrenceName = eofName
          , examOccurrenceExaminer = eofExaminer
          , examOccurrenceRoom = eofRoom
          , examOccurrenceRoomHidden = eofRoomHidden
          , examOccurrenceCapacity = eofCapacity
          , examOccurrenceStart = eofStart
          , examOccurrenceEnd = eofEnd
          , examOccurrenceDescription = eofDescription
          }
    eof@ExamOccurrenceForm{eofName = eofNameMb, .. } -> fmap join $ runMaybeT $ do
      cID <- hoistMaybe eofId
      eofId' <- decrypt cID
      oldOcc <- MaybeT $ get eofId'
      guard $ examOccurrenceExam oldOcc == eId
      lift $ do
        eofName <- fromMaybeM (guessExamOccurrenceName eId eof) (pure eofNameMb)
        res <- replaceUnique eofId' ExamOccurrence
          { examOccurrenceExam = eId
          , examOccurrenceName = eofName
          , examOccurrenceExaminer = eofExaminer
          , examOccurrenceRoom = eofRoom
          , examOccurrenceRoomHidden = eofRoomHidden
          , examOccurrenceCapacity = eofCapacity
          , examOccurrenceStart = eofStart
          , examOccurrenceEnd = eofEnd
          , examOccurrenceDescription = eofDescription
          }
        memcachedInvalidateClass MemcachedKeyClassExamOccurrences
        return $ flipMaybe () res
    )

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 & Just
          , eofExaminer    = examOccurrenceExaminer
          , 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{eofName=fold->eofName, ..} -> 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 $ fold $ 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.selectOne . 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