{-# OPTIONS_GHC -fno-warn-orphans #-}

module Handler.Tutorial
  ( module Handler.Tutorial
  ) where

import Import
import Handler.Utils
import Handler.Utils.Tutorial
import Handler.Utils.Table.Cells
import Handler.Utils.Delete
import Handler.Utils.Communication
import Handler.Utils.Form.Occurrences
import Handler.Utils.Invitations
import Jobs.Queue

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

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

import qualified Data.CaseInsensitive as CI

import qualified Data.Text as Text

import Data.Aeson hiding (Result(..))
import Text.Hamlet (ihamlet)

import Handler.Tutorial.Users as Handler.Tutorial

{-# ANN module ("Hlint: ignore Redundant void" :: String) #-}


getCTutorialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCTutorialListR tid ssh csh = do
  Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh

  let
    tutorialDBTable = DBTable{..}
      where
        dbtSQLQuery tutorial = do
          E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
          let participants = E.sub_select . E.from $ \tutorialParticipant -> do
                E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
                return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
          return (tutorial, participants)
        dbtRowKey = (E.^. TutorialId)
        dbtProj = return . over (_dbrOutput . _2) E.unValue
        dbtColonnade = dbColonnade $ mconcat
          [ sortable (Just "type") (i18nCell MsgTutorialType) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> textCell $ CI.original tutorialType
          , sortable (Just "name") (i18nCell MsgTutorialName) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|]
          , sortable Nothing (i18nCell MsgTutorialTutors) $ \DBRow{ dbrOutput = (Entity tutid _, _) } -> sqlCell $ do
              tutors <- fmap (map $(unValueN 3)) . E.select . E.from $ \(tutor `E.InnerJoin` user) -> do
                E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
                E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
                return (user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname)
              return [whamlet|
                       $newline never
                       <ul .list--iconless .list--inline .list--comma-separated>
                         $forall tutor <- tutors
                           <li>
                             ^{nameEmailWidget' tutor}
                     |]
          , sortable (Just "participants") (i18nCell MsgTutorialParticipants) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, n) } -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) $ tshow n
          , sortable (Just "capacity") (i18nCell MsgTutorialCapacity) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybe mempty (textCell . tshow) tutorialCapacity
          , sortable (Just "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> textCell tutorialRoom
          , sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> occurrencesCell tutorialTime
          , sortable (Just "register-group") (i18nCell MsgTutorialRegGroup) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybe mempty (textCell . CI.original) tutorialRegGroup
          , sortable (Just "register-from") (i18nCell MsgTutorialRegisterFrom) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybeDateTimeCell tutorialRegisterFrom
          , sortable (Just "register-to") (i18nCell MsgTutorialRegisterTo) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybeDateTimeCell tutorialRegisterTo
          , sortable (Just "deregister-until") (i18nCell MsgTutorialDeregisterUntil) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybeDateTimeCell tutorialDeregisterUntil
          , sortable Nothing mempty $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> cell $ do
              linkButton mempty [whamlet|_{MsgTutorialEdit}|] [BCIsButton] . SomeRoute $ CTutorialR tid ssh csh tutorialName TEditR
              linkButton mempty [whamlet|_{MsgTutorialDelete}|] [BCIsButton, BCDanger] . SomeRoute $ CTutorialR tid ssh csh tutorialName TDeleteR
          ]
        dbtSorting = Map.fromList
          [ ("type", SortColumn $ \tutorial -> tutorial E.^. TutorialType )
          , ("name", SortColumn $ \tutorial -> tutorial E.^. TutorialName )
          , ("participants", SortColumn $ \tutorial -> E.sub_select . E.from $ \tutorialParticipant -> do
                E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
                return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
            )
          , ("capacity", SortColumn $ \tutorial -> tutorial E.^. TutorialCapacity )
          , ("room", SortColumn $ \tutorial -> tutorial E.^. TutorialRoom )
          , ("register-group", SortColumn $ \tutorial -> tutorial E.^. TutorialRegGroup )
          , ("register-from", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterFrom )
          , ("register-to", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterTo )
          , ("deregister-until", SortColumn $ \tutorial -> tutorial E.^. TutorialDeregisterUntil )
          ]
        dbtFilter = Map.empty
        dbtFilterUI = const mempty
        dbtStyle = def
        dbtParams = def
        dbtIdent :: Text
        dbtIdent = "tutorials"
        dbtCsvEncode = noCsvEncode
        dbtCsvDecode = Nothing

    tutorialDBTableValidator = def
      & defaultSorting [SortAscBy "type", SortAscBy "name"]
  ((), tutorialTable) <- runDB $ dbTable tutorialDBTableValidator tutorialDBTable

  siteLayoutMsg (prependCourseTitle tid ssh csh MsgTutorialsHeading) $ do
    setTitleI $ prependCourseTitle tid ssh csh MsgTutorialsHeading
    $(widgetFile "tutorial-list")

postTRegisterR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler ()
postTRegisterR tid ssh csh tutn = do
  uid <- requireAuthId

  Entity tutid Tutorial{..} <- runDB $ fetchTutorial tid ssh csh tutn

  ((btnResult, _), _) <- runFormPost buttonForm

  formResult btnResult $ \case
    BtnRegister -> do
      runDB . void . insert $ TutorialParticipant tutid uid
      addMessageI Success $ MsgTutorialRegisteredSuccess tutorialName
      redirect $ CourseR tid ssh csh CShowR
    BtnDeregister -> do
      runDB . deleteBy $ UniqueTutorialParticipant tutid uid
      addMessageI Success $ MsgTutorialDeregisteredSuccess tutorialName
      redirect $ CourseR tid ssh csh CShowR

  invalidArgs ["Register/Deregister button required"]

getTDeleteR, postTDeleteR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
getTDeleteR = postTDeleteR
postTDeleteR tid ssh csh tutn = do
  tutid <- runDB $ fetchTutorialId tid ssh csh tutn
  deleteR DeleteRoute
    { drRecords = Set.singleton tutid
    , drUnjoin = \(_ `E.InnerJoin` tutorial) -> tutorial
    , drGetInfo = \(course `E.InnerJoin` tutorial) -> do
        E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
        let participants = E.sub_select . E.from $ \participant -> do
              E.where_ $ participant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
              return E.countRows
        return (course, tutorial, participants :: E.SqlExpr (E.Value Int))
    , drRenderRecord = \(Entity _ Course{..}, Entity _ Tutorial{..}, E.Value ps) ->
        return [whamlet|_{prependCourseTitle courseTerm courseSchool courseShorthand (CI.original tutorialName)} (_{MsgParticipantsN ps})|]
    , drRecordConfirmString = \(Entity _ Course{..}, Entity _ Tutorial{..}, E.Value ps) ->
        return [st|#{termToText (unTermKey courseTerm)}/#{unSchoolKey courseSchool}/#{courseShorthand}/#{tutorialName}+#{tshow ps}|]
    , drCaption = SomeMessage MsgTutorialDeleteQuestion
    , drSuccessMessage = SomeMessage MsgTutorialDeleted
    , drAbort = SomeRoute $ CTutorialR tid ssh csh tutn TUsersR
    , drSuccess = SomeRoute $ CourseR tid ssh csh CTutorialListR
    }

getTCommR, postTCommR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
getTCommR = postTCommR
postTCommR tid ssh csh tutn = do
  jSender <- requireAuthId
  (cid, tutid) <- runDB $ fetchCourseIdTutorialId tid ssh csh tutn

  commR CommunicationRoute
    { crHeading    = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommTutorialHeading
    , crUltDest    = SomeRoute $ CTutorialR tid ssh csh tutn TCommR
    , crJobs       = \Communication{..} -> do
        let jSubject = cSubject
            jMailContent = cBody
            jCourse = cid
            allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients
        jMailObjectUUID <- liftIO getRandom
        jAllRecipientAddresses <- lift . fmap Set.fromList . forM allRecipients $ \case
          Left email -> return . Address Nothing $ CI.original email
          Right rid  -> userAddress <$> getJust rid
        forM_ allRecipients $ \jRecipientEmail ->
          yield JobSendCourseCommunication{..}
    , crRecipients = Map.fromList
      [ ( RGTutorialParticipants
        , E.from $ \(user `E.InnerJoin` participant) -> do
            E.on $ user E.^. UserId E.==. participant E.^. TutorialParticipantUser
            E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid
            return user
        )
      , ( RGCourseLecturers
        , E.from $ \(user `E.InnerJoin` lecturer) -> do
            E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
            E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
            return user
        )
      , ( RGCourseCorrectors
        , E.from $ \user -> do
            E.where_ $ E.exists $ E.from $ \(sheet `E.InnerJoin` corrector) -> do
              E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
              E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
                   E.&&. corrector E.^. SheetCorrectorUser E.==. user E.^. UserId
            return user
        )
      , ( RGCourseTutors
        , E.from $ \user -> do
            E.where_ $ E.exists $ E.from $ \(tutorial `E.InnerJoin` tutor) -> do
              E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial
              E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
                   E.&&. tutor E.^. TutorUser E.==. user E.^. UserId
            return user
        )
      ]
    , crRecipientAuth = Just $ \uid -> do
        [E.Value isTutorialUser] <- E.select . return . E.exists . E.from $ \tutorialUser ->
          E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val uid
               E.&&. tutorialUser E.^. TutorialParticipantTutorial E.==. E.val tutid

        isAssociatedCorrector <- evalAccessForDB (Just uid) (CourseR tid ssh csh CNotesR) False
        isAssociatedTutor <- evalAccessForDB (Just uid) (CourseR tid ssh csh CTutorialListR) False

        mr <- getMsgRenderer
        return $ if
          | isTutorialUser -> Authorized
          | otherwise -> orAR mr isAssociatedCorrector isAssociatedTutor
    }


instance IsInvitableJunction Tutor where
  type InvitationFor Tutor = Tutorial
  data InvitableJunction Tutor = JunctionTutor
    deriving (Eq, Ord, Read, Show, Generic, Typeable)
  data InvitationDBData Tutor = InvDBDataTutor
    deriving (Eq, Ord, Read, Show, Generic, Typeable)
  data InvitationTokenData Tutor = InvTokenDataTutor
    deriving (Eq, Ord, Read, Show, Generic, Typeable)

  _InvitableJunction = iso
    (\Tutor{..} -> (tutorUser, tutorTutorial, JunctionTutor))
    (\(tutorUser, tutorTutorial, JunctionTutor) -> Tutor{..})

instance ToJSON (InvitableJunction Tutor) where
  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
instance FromJSON (InvitableJunction Tutor) where
  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }

instance ToJSON (InvitationDBData Tutor) where
  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
instance FromJSON (InvitationDBData Tutor) where
  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }

instance ToJSON (InvitationTokenData Tutor) where
  toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
instance FromJSON (InvitationTokenData Tutor) where
  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }

tutorInvitationConfig :: InvitationConfig Tutor
tutorInvitationConfig = InvitationConfig{..}
  where
    invitationRoute (Entity _ Tutorial{..}) _ = do
      Course{..} <- get404 tutorialCourse
      return $ CTutorialR courseTerm courseSchool courseShorthand tutorialName TInviteR
    invitationResolveFor _ = do
      Just (CTutorialR tid csh ssh tutn TInviteR) <- getCurrentRoute
      fetchTutorialId tid csh ssh tutn
    invitationSubject (Entity _ Tutorial{..}) _ = do
      Course{..} <- get404 tutorialCourse
      return . SomeMessage $ MsgMailSubjectTutorInvitation courseTerm courseSchool courseShorthand tutorialName
    invitationHeading (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgTutorInviteHeading tutorialName
    invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgTutorInviteExplanation}|]
    invitationTokenConfig _ _ = do
      itAuthority <- liftHandlerT requireAuthId
      return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
    invitationRestriction _ _ = return Authorized
    invitationForm _ _ _ = pure (JunctionTutor, ())
    invitationInsertHook _ _ _ _ = id
    invitationSuccessMsg (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted tutorialName
    invitationUltDest (Entity _ Tutorial{..}) _ = do
      Course{..} <- get404 tutorialCourse
      return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CTutorialListR

getTInviteR, postTInviteR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
getTInviteR = postTInviteR
postTInviteR = invitationR tutorInvitationConfig


data TutorialForm = TutorialForm
  { tfName            :: TutorialName
  , tfType            :: CI Text
  , tfCapacity        :: Maybe Int
  , tfRoom            :: Text
  , tfTime            :: Occurrences
  , tfRegGroup        :: Maybe (CI Text)
  , tfRegisterFrom    :: Maybe UTCTime
  , tfRegisterTo      :: Maybe UTCTime
  , tfDeregisterUntil :: Maybe UTCTime
  , tfTutors          :: Set (Either UserEmail UserId)
  }

tutorialForm :: CourseId -> Maybe TutorialForm -> Form TutorialForm
tutorialForm cid template html = do
  MsgRenderer mr <- getMsgRenderer
  Just cRoute <- getCurrentRoute
  uid <- liftHandlerT requireAuthId

  let
    tutorForm = Set.fromList <$> massInputAccumA miAdd' miCell' (\p -> Just . SomeRoute $ cRoute :#: p) miLayout' ("tutors" :: Text) (fslI MsgTutorialTutors & setTooltip MsgMassInputTip) True (Set.toList . tfTutors <$> template)
      where
        miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId])
        miAdd' nudge submitView csrf = do
          (addRes, addView) <- mpreq (multiUserField False . Just $ tutUserSuggestions uid) ("" & addName (nudge "email")) Nothing
          let
            addRes'
              | otherwise
              = addRes <&> \newDat oldDat -> if
                  | existing <- newDat `Set.intersection` Set.fromList oldDat
                  , not $ Set.null existing
                    -> FormFailure [mr MsgTutorialTutorAlreadyAdded]
                  | otherwise
                    -> FormSuccess $ Set.toList newDat
          return (addRes', $(widgetFile "tutorial/tutorMassInput/add"))


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

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

  flip (renderAForm FormStandard) html $ TutorialForm
    <$> areq ciField (fslpI MsgTutorialName (mr MsgTutorialName) & setTooltip MsgTutorialNameTip) (tfName <$> template)
    <*> areq (ciField & addDatalist tutTypeDatalist) (fslpI MsgTutorialType $ mr MsgTutorialType) (tfType <$> template)
    <*> aopt (natFieldI MsgTutorialCapacityNonPositive) (fslpI MsgTutorialCapacity (mr MsgTutorialCapacity) & setTooltip MsgTutorialCapacityTip) (tfCapacity <$> template)
    <*> areq textField (fslpI MsgTutorialRoom $ mr MsgTutorialRoomPlaceholder) (tfRoom <$> template)
    <*> occurrencesAForm ("occurrences" :: Text) (tfTime <$> template)
    <*> fmap (assertM (not . Text.null . CI.original) . fmap (CI.map Text.strip)) (aopt ciField (fslI MsgTutorialRegGroup & setTooltip MsgTutorialRegGroupTip) ((tfRegGroup <$> template) <|> Just (Just "tutorial")))
    <*> aopt utcTimeField   (fslpI MsgRegisterFrom (mr MsgDate)
                               & setTooltip MsgCourseRegisterFromTip
                            ) (tfRegisterFrom <$> template)
    <*> aopt utcTimeField   (fslpI MsgRegisterTo   (mr MsgDate)
                               & setTooltip MsgCourseRegisterToTip
                            ) (tfRegisterTo <$> template)
    <*> aopt utcTimeField   (fslpI MsgDeRegUntil   (mr MsgDate)
                               & setTooltip MsgCourseDeregisterUntilTip
                            ) (tfDeregisterUntil <$> template)
    <*> tutorForm
  where
    tutTypeDatalist :: WidgetT UniWorX IO (Set (CI Text))
    tutTypeDatalist = liftHandlerT . runDB $
      fmap (setOf $ folded . _Value) . E.select . E.from $ \tutorial -> do
        E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
        return $ tutorial E.^. TutorialType

    tutUserSuggestions :: UserId -> E.SqlQuery (E.SqlExpr (Entity User))
    tutUserSuggestions uid = E.from $ \(lecturer `E.InnerJoin` course `E.InnerJoin` tutorial `E.InnerJoin` tutor `E.InnerJoin` tutorUser) -> do
      E.on $ tutorUser E.^. UserId E.==. tutor E.^. TutorUser
      E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
      E.on $ tutorial E.^. TutorialCourse E.==. course E.^. CourseId
      E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
      E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
      return tutorUser


getCTutorialNewR, postCTutorialNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCTutorialNewR = postCTutorialNewR
postCTutorialNewR tid ssh csh = do
  Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh

  ((newTutResult, newTutWidget), newTutEnctype) <- runFormPost $ tutorialForm cid Nothing

  formResult newTutResult $ \TutorialForm{..} -> do
    insertRes <- runDBJobs $ do
      now <- liftIO getCurrentTime
      insertRes <- insertUnique Tutorial
        { tutorialName            = tfName
        , tutorialCourse          = cid
        , tutorialType            = tfType
        , tutorialCapacity        = tfCapacity
        , tutorialRoom            = tfRoom
        , tutorialTime            = tfTime
        , tutorialRegGroup        = tfRegGroup
        , tutorialRegisterFrom    = tfRegisterFrom
        , tutorialRegisterTo      = tfRegisterTo
        , tutorialDeregisterUntil = tfDeregisterUntil
        , tutorialLastChanged     = now
        }
      whenIsJust insertRes $ \tutid -> do
        let (invites, adds) = partitionEithers $ Set.toList tfTutors
        insertMany_ $ map (Tutor tutid) adds
        sinkInvitationsF tutorInvitationConfig $ map (, tutid, (InvDBDataTutor, InvTokenDataTutor)) invites
      return insertRes
    case insertRes of
      Nothing -> addMessageI Error $ MsgTutorialNameTaken tfName
      Just _  -> do
        addMessageI Success $ MsgTutorialCreated tfName
        redirect $ CourseR tid ssh csh CTutorialListR

  let heading = prependCourseTitle tid ssh csh MsgTutorialNew

  siteLayoutMsg heading $ do
    setTitleI heading
    let
      newTutForm = wrapForm newTutWidget def
        { formMethod = POST
        , formAction = Just . SomeRoute $ CourseR tid ssh csh CTutorialNewR
        , formEncoding = newTutEnctype
        }
    $(widgetFile "tutorial-new")

getTEditR, postTEditR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
getTEditR = postTEditR
postTEditR tid ssh csh tutn = do
  (cid, tutid, template) <- runDB $ do
    (cid, Entity tutid Tutorial{..}) <- fetchCourseIdTutorial tid ssh csh tutn

    tutorIds <- fmap (map E.unValue) . E.select . E.from $ \tutor -> do
      E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
      return $ tutor E.^. TutorUser

    tutorInvites <- sourceInvitationsList tutid

    let
      template = TutorialForm
        { tfName            = tutorialName
        , tfType            = tutorialType
        , tfCapacity        = tutorialCapacity
        , tfRoom            = tutorialRoom
        , tfTime            = tutorialTime
        , tfRegGroup        = tutorialRegGroup
        , tfRegisterFrom    = tutorialRegisterFrom
        , tfRegisterTo      = tutorialRegisterTo
        , tfDeregisterUntil = tutorialDeregisterUntil
        , tfTutors          = Set.fromList (map Right tutorIds)
                           <> Set.fromList (map (\(email, InvDBDataTutor) -> Left email) tutorInvites)
        }

    return (cid, tutid, template)

  ((newTutResult, newTutWidget), newTutEnctype) <- runFormPost . tutorialForm cid $ Just template

  formResult newTutResult $ \TutorialForm{..} -> do
    insertRes <- runDBJobs $ do
      now <- liftIO getCurrentTime
      insertRes <- myReplaceUnique tutid Tutorial
        { tutorialName            = tfName
        , tutorialCourse          = cid
        , tutorialType            = tfType
        , tutorialCapacity        = tfCapacity
        , tutorialRoom            = tfRoom
        , tutorialTime            = tfTime
        , tutorialRegGroup        = tfRegGroup
        , tutorialRegisterFrom    = tfRegisterFrom
        , tutorialRegisterTo      = tfRegisterTo
        , tutorialDeregisterUntil = tfDeregisterUntil
        , tutorialLastChanged     = now
        }
      when (is _Nothing insertRes) $ do
        let (invites, adds) = partitionEithers $ Set.toList tfTutors

        deleteWhere [ TutorTutorial ==. tutid ]
        insertMany_ $ map (Tutor tutid) adds

        deleteWhere [ InvitationFor ==. invRef @Tutor tutid, InvitationEmail /<-. invites ]
        sinkInvitationsF tutorInvitationConfig $ map (, tutid, (InvDBDataTutor, InvTokenDataTutor)) invites
      return insertRes
    case insertRes of
      Just _  -> addMessageI Error $ MsgTutorialNameTaken tfName
      Nothing -> do
        addMessageI Success $ MsgTutorialEdited tfName
        redirect $ CourseR tid ssh csh CTutorialListR

  let heading = prependCourseTitle tid ssh csh . MsgTutorialEditHeading $ tfName template

  siteLayoutMsg heading $ do
    setTitleI heading
    let
      newTutForm = wrapForm newTutWidget def
        { formMethod = POST
        , formAction = Just . SomeRoute $ CTutorialR tid ssh csh tutn TEditR
        , formEncoding = newTutEnctype
        }
    $(widgetFile "tutorial-edit")