64 lines
2.2 KiB
Haskell
64 lines
2.2 KiB
Haskell
module Handler.Tutorial.New
|
|
( getCTutorialNewR, postCTutorialNewR
|
|
) where
|
|
|
|
import Import
|
|
import Handler.Utils
|
|
import Handler.Utils.Invitations
|
|
import Jobs.Queue
|
|
|
|
import qualified Data.Set as Set
|
|
|
|
import Handler.Tutorial.Form
|
|
import Handler.Tutorial.TutorInvite
|
|
|
|
|
|
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
|
|
, tutorialTutorControlled = tfTutorControlled
|
|
}
|
|
whenIsJust insertRes $ \tutid -> do
|
|
audit $ TransactionTutorialEdit tutid
|
|
|
|
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")
|