386 lines
19 KiB
Haskell
386 lines
19 KiB
Haskell
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 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
|
|
|
|
{-# 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
|
|
}
|
|
|
|
|
|
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 UserId -- awaiting feat/generic-invitations
|
|
}
|
|
|
|
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' (fslI MsgTutorialTutors & setTooltip MsgMassInputTip) True (Set.toList . tfTutors <$> template)
|
|
where
|
|
miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([UserId] -> FormResult [UserId])
|
|
miAdd' nudge submitView csrf = do
|
|
(addRes, addView) <- mpreq (multiUserField False . Just $ tutUserSuggestions uid) ("" & addName (nudge "email")) Nothing
|
|
let
|
|
addRes'
|
|
| unresolved <- toListOf (_FormSuccess . folded . _Left) addRes
|
|
, (fUnresolved : _) <- unresolved
|
|
= FormFailure [mr $ MsgEMailUnknown fUnresolved]
|
|
| otherwise
|
|
= addRes <&> \newDat oldDat -> if
|
|
| (_ : _) <- Set.toList $ setOf (folded . _Right) newDat `Set.intersection` Set.fromList oldDat
|
|
-> FormFailure [mr MsgTutorialTutorAlreadyAdded]
|
|
| otherwise
|
|
-> FormSuccess $ toListOf (folded . _Right) newDat
|
|
return (addRes', $(widgetFile "tutorial/tutorMassInput/add"))
|
|
|
|
|
|
miCell' :: UserId -> Widget
|
|
miCell' userId = do
|
|
User{..} <- liftHandlerT . runDB $ get404 userId
|
|
$(widgetFile "tutorial/tutorMassInput/cellKnown")
|
|
|
|
miLayout' :: MassInputLayout ListLength 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 (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 <- runDB $ 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
|
|
}
|
|
forM_ tfTutors $ \tutor -> case insertRes of
|
|
Just tutid -> void . insert $ Tutor tutid tutor
|
|
_other -> return ()
|
|
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
|
|
|
|
let
|
|
template = TutorialForm
|
|
{ tfName = tutorialName
|
|
, tfType = tutorialType
|
|
, tfCapacity = tutorialCapacity
|
|
, tfRoom = tutorialRoom
|
|
, tfTime = tutorialTime
|
|
, tfRegGroup = tutorialRegGroup
|
|
, tfRegisterFrom = tutorialRegisterFrom
|
|
, tfRegisterTo = tutorialRegisterTo
|
|
, tfDeregisterUntil = tutorialDeregisterUntil
|
|
, tfTutors = Set.fromList tutorIds
|
|
}
|
|
|
|
return (cid, tutid, template)
|
|
|
|
((newTutResult, newTutWidget), newTutEnctype) <- runFormPost . tutorialForm cid $ Just template
|
|
|
|
formResult newTutResult $ \TutorialForm{..} -> do
|
|
insertRes <- runDB $ 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
|
|
}
|
|
deleteWhere [ TutorTutorial ==. tutid ]
|
|
forM_ tfTutors $ void . insert . Tutor tutid
|
|
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")
|