105 lines
3.8 KiB
Haskell
105 lines
3.8 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Handler.Tutorial.Edit
|
|
( getTEditR, postTEditR
|
|
) where
|
|
|
|
import Import
|
|
import Handler.Utils
|
|
import Handler.Utils.Tutorial
|
|
import Handler.Utils.Invitations
|
|
import Jobs.Queue
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Set as Set
|
|
|
|
import Handler.Tutorial.Form
|
|
import Handler.Tutorial.TutorInvite
|
|
|
|
|
|
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 <- sourceInvitationsF @Tutor tutid
|
|
|
|
let
|
|
template = TutorialForm
|
|
{ tfName = tutorialName
|
|
, tfType = tutorialType
|
|
, tfCapacity = tutorialCapacity
|
|
, tfRoom = tutorialRoom
|
|
, tfRoomHidden = tutorialRoomHidden
|
|
, tfTime = tutorialTime
|
|
, tfRegGroup = tutorialRegGroup
|
|
, tfRegisterFrom = tutorialRegisterFrom
|
|
, tfRegisterTo = tutorialRegisterTo
|
|
, tfDeregisterUntil = tutorialDeregisterUntil
|
|
, tfTutors = Set.fromList (map Right tutorIds)
|
|
<> Set.mapMonotonic Left (Map.keysSet tutorInvites)
|
|
, tfTutorControlled = tutorialTutorControlled
|
|
}
|
|
|
|
return (cid, tutid, template)
|
|
|
|
((newTutResult, newTutWidget), newTutEnctype) <- runFormPost . tutorialForm cid $ Just template
|
|
|
|
formResult newTutResult $ \TutorialForm{..} -> do
|
|
insertRes <- runDBJobs $ do
|
|
term <- fetchTermByCID cid
|
|
now <- liftIO getCurrentTime
|
|
insertRes <- myReplaceUnique tutid Tutorial
|
|
{ tutorialName = tfName
|
|
, tutorialCourse = cid
|
|
, tutorialType = tfType
|
|
, tutorialCapacity = tfCapacity
|
|
, tutorialRoom = tfRoom
|
|
, tutorialRoomHidden = tfRoomHidden
|
|
, tutorialTime = tfTime
|
|
, tutorialRegGroup = tfRegGroup
|
|
, tutorialRegisterFrom = tfRegisterFrom
|
|
, tutorialRegisterTo = tfRegisterTo
|
|
, tutorialDeregisterUntil = tfDeregisterUntil
|
|
, tutorialLastChanged = now
|
|
, tutorialTutorControlled = tfTutorControlled
|
|
, tutorialFirstDay = fst $ occurrencesBounds term tfTime
|
|
}
|
|
when (is _Nothing insertRes) $ do
|
|
audit $ TransactionTutorialEdit tutid
|
|
|
|
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
|
|
memcachedByInvalidate AuthCacheTutorList $ Proxy @(Set UserId)
|
|
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")
|