463 lines
22 KiB
Haskell
463 lines
22 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
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.MassInput
|
|
import Handler.Utils.Form.Occurences
|
|
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 Utils.Lens
|
|
|
|
import Data.Aeson hiding (Result(..))
|
|
import Text.Hamlet (ihamlet)
|
|
|
|
{-# 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{..}, _) } -> textCell $ CI.original 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) . toWidget $ 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{..}, _) } -> occurencesCell tutorialTime
|
|
, sortable (Just "reg-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 )
|
|
, ("reg-grep", 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"
|
|
|
|
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)} (#{tshow ps} _{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
|
|
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
|
|
return user
|
|
)
|
|
]
|
|
, crRecipientAuth = Just $ \uid -> do
|
|
cID <- encrypt uid
|
|
evalAccessDB (CourseR tid ssh csh $ CUserR cID) False
|
|
}
|
|
|
|
|
|
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 { fieldLabelModifier = camelToPathPiece' 4 }
|
|
instance FromJSON (InvitationTokenData Tutor) where
|
|
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
|
|
|
tutorInvitationConfig :: InvitationConfig Tutor
|
|
tutorInvitationConfig = InvitationConfig{..}
|
|
where
|
|
invitationRoute 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 Tutorial{..} _ = do
|
|
Course{..} <- get404 tutorialCourse
|
|
return . SomeMessage $ MsgMailSubjectTutorInvitation courseTerm courseSchool courseShorthand tutorialName
|
|
invitationHeading Tutorial{..} _ = return . SomeMessage $ MsgTutorInviteHeading tutorialName
|
|
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgTutorInviteExplanation}|]
|
|
invitationTokenConfig _ _ = do
|
|
itAuthority <- liftHandlerT requireAuthId
|
|
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
|
invitationRestriction _ _ = return Authorized
|
|
invitationForm _ _ _ = pure JunctionTutor
|
|
invitationSuccessMsg Tutorial{..} _ = return . SomeMessage $ MsgCorrectorInvitationAccepted tutorialName
|
|
invitationUltDest 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 :: Occurences
|
|
, 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)
|
|
<*> occurencesAForm ("occurences" :: 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 $ MsgTutorialCreated 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")
|