refactor(tutorials): split
This commit is contained in:
Gregor Kleen
parent
2a518f3284
commit
8a688cc795
@ -1,480 +1,13 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Handler.Tutorial
|
||||
( module Handler.Tutorial
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Tutorial
|
||||
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 qualified Database.Esqueleto.Utils 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 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
|
||||
, drDelete = \_ -> id -- TODO: audit
|
||||
}
|
||||
|
||||
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
|
||||
isTutorialUser <- E.selectExists . 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
|
||||
cRoute <- getCurrentRoute
|
||||
case cRoute of
|
||||
Just (CTutorialR tid csh ssh tutn TInviteR) ->
|
||||
fetchTutorialId tid csh ssh tutn
|
||||
_other ->
|
||||
error "tutorInvitationConfig called from unsupported route"
|
||||
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 <- liftHandler 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
|
||||
cRoute <- fromMaybe (error "tutorialForm called from 404-Handler") <$> getCurrentRoute
|
||||
uid <- liftHandler 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{..} <- liftHandler . 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 (textField & cfStrip & cfCI) (fslpI MsgTutorialName (mr MsgTutorialName) & setTooltip MsgTutorialNameTip) (tfName <$> template)
|
||||
<*> areq (textField & cfStrip & cfCI & 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)
|
||||
<*> aopt (textField & cfStrip & cfCI) (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 :: HandlerFor UniWorX (OptionList (CI Text))
|
||||
tutTypeDatalist = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . 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 <- sourceInvitationsF @Tutor 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.mapMonotonic Left (Map.keysSet 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")
|
||||
import Handler.Tutorial.Communication as Handler.Tutorial
|
||||
import Handler.Tutorial.Delete as Handler.Tutorial
|
||||
import Handler.Tutorial.Edit as Handler.Tutorial
|
||||
import Handler.Tutorial.Form as Handler.Tutorial
|
||||
import Handler.Tutorial.List as Handler.Tutorial
|
||||
import Handler.Tutorial.New as Handler.Tutorial
|
||||
import Handler.Tutorial.Register as Handler.Tutorial
|
||||
import Handler.Tutorial.TutorInvite as Handler.Tutorial
|
||||
import Handler.Tutorial.Users as Handler.Tutorial
|
||||
|
||||
81
src/Handler/Tutorial/Communication.hs
Normal file
81
src/Handler/Tutorial/Communication.hs
Normal file
@ -0,0 +1,81 @@
|
||||
module Handler.Tutorial.Communication
|
||||
( getTCommR, postTCommR
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Tutorial
|
||||
import Handler.Utils.Communication
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
|
||||
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
|
||||
isTutorialUser <- E.selectExists . 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
|
||||
}
|
||||
39
src/Handler/Tutorial/Delete.hs
Normal file
39
src/Handler/Tutorial/Delete.hs
Normal file
@ -0,0 +1,39 @@
|
||||
module Handler.Tutorial.Delete
|
||||
( getTDeleteR, postTDeleteR
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Tutorial
|
||||
import Handler.Utils.Delete
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
|
||||
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
|
||||
, drDelete = const id -- TODO: audit
|
||||
}
|
||||
92
src/Handler/Tutorial/Edit.hs
Normal file
92
src/Handler/Tutorial/Edit.hs
Normal file
@ -0,0 +1,92 @@
|
||||
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 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
|
||||
, tfTime = tutorialTime
|
||||
, tfRegGroup = tutorialRegGroup
|
||||
, tfRegisterFrom = tutorialRegisterFrom
|
||||
, tfRegisterTo = tutorialRegisterTo
|
||||
, tfDeregisterUntil = tutorialDeregisterUntil
|
||||
, tfTutors = Set.fromList (map Right tutorIds)
|
||||
<> Set.mapMonotonic Left (Map.keysSet 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")
|
||||
96
src/Handler/Tutorial/Form.hs
Normal file
96
src/Handler/Tutorial/Form.hs
Normal file
@ -0,0 +1,96 @@
|
||||
module Handler.Tutorial.Form
|
||||
( TutorialForm(..)
|
||||
, tutorialForm
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Form.Occurrences
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import Data.Map ((!))
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
|
||||
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
|
||||
cRoute <- fromMaybe (error "tutorialForm called from 404-Handler") <$> getCurrentRoute
|
||||
uid <- liftHandler 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{..} <- liftHandler . 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 (textField & cfStrip & cfCI) (fslpI MsgTutorialName (mr MsgTutorialName) & setTooltip MsgTutorialNameTip) (tfName <$> template)
|
||||
<*> areq (textField & cfStrip & cfCI & 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)
|
||||
<*> aopt (textField & cfStrip & cfCI) (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 :: HandlerFor UniWorX (OptionList (CI Text))
|
||||
tutTypeDatalist = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . 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
|
||||
87
src/Handler/Tutorial/List.hs
Normal file
87
src/Handler/Tutorial/List.hs
Normal file
@ -0,0 +1,87 @@
|
||||
module Handler.Tutorial.List
|
||||
( getCTutorialListR
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
|
||||
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")
|
||||
60
src/Handler/Tutorial/New.hs
Normal file
60
src/Handler/Tutorial/New.hs
Normal file
@ -0,0 +1,60 @@
|
||||
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
|
||||
}
|
||||
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")
|
||||
28
src/Handler/Tutorial/Register.hs
Normal file
28
src/Handler/Tutorial/Register.hs
Normal file
@ -0,0 +1,28 @@
|
||||
module Handler.Tutorial.Register
|
||||
( postTRegisterR
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Tutorial
|
||||
|
||||
|
||||
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"]
|
||||
79
src/Handler/Tutorial/TutorInvite.hs
Normal file
79
src/Handler/Tutorial/TutorInvite.hs
Normal file
@ -0,0 +1,79 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Handler.Tutorial.TutorInvite
|
||||
( getTInviteR, postTInviteR
|
||||
, tutorInvitationConfig
|
||||
, InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..)
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Handler.Utils.Tutorial
|
||||
import Handler.Utils.Invitations
|
||||
|
||||
import Data.Aeson hiding (Result(..))
|
||||
import Text.Hamlet (ihamlet)
|
||||
|
||||
|
||||
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
|
||||
cRoute <- getCurrentRoute
|
||||
case cRoute of
|
||||
Just (CTutorialR tid csh ssh tutn TInviteR) ->
|
||||
fetchTutorialId tid csh ssh tutn
|
||||
_other ->
|
||||
error "tutorInvitationConfig called from unsupported route"
|
||||
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 <- liftHandler 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
|
||||
Loading…
Reference in New Issue
Block a user