76 lines
3.0 KiB
Haskell
76 lines
3.0 KiB
Haskell
module Handler.Tutorial.Users
|
|
( getTUsersR, postTUsersR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Utils.Form
|
|
-- import Utils.DB
|
|
import Handler.Utils
|
|
import Handler.Utils.Tutorial
|
|
import Database.Persist.Sql (deleteWhereCount)
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
|
|
import qualified Database.Esqueleto as E
|
|
|
|
import Handler.Course.Users
|
|
|
|
|
|
data TutorialUserAction = TutorialUserSendMail | TutorialUserDeregister
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
|
|
instance Universe TutorialUserAction
|
|
instance Finite TutorialUserAction
|
|
nullaryPathPiece ''TutorialUserAction $ camelToPathPiece' 2
|
|
embedRenderMessage ''UniWorX ''TutorialUserAction id
|
|
|
|
|
|
getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
|
|
getTUsersR = postTUsersR
|
|
postTUsersR tid ssh csh tutn = do
|
|
showSex <- getShowSex
|
|
(Entity tutid Tutorial{..}, (participantRes, participantTable)) <- runDB $ do
|
|
tut@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
|
|
let colChoices = mconcat $ catMaybes
|
|
[ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
|
|
, pure colUserName
|
|
, guardOn showSex colUserSex'
|
|
, pure colUserEmail
|
|
, pure colUserMatriclenr
|
|
, pure colUserDegreeShort
|
|
, pure colUserField
|
|
, pure colUserSemester
|
|
]
|
|
psValidator = def
|
|
& defaultSortingByName
|
|
& restrictSorting (\name _ -> none (== name) ["note", "registration", "tutorials"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
|
|
isInTut q = E.exists . E.from $ \tutorialParticipant ->
|
|
E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId
|
|
E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid
|
|
csvColChoices = flip elem ["name", "matriculation", "email", "field", "degree", "semester", "study-features"]
|
|
|
|
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
|
table <- makeCourseUserTable cid (Map.fromList $ map (id &&& pure) universeF) isInTut colChoices psValidator (Just csvColChoices)
|
|
return (tut, table)
|
|
|
|
formResult participantRes $ \case
|
|
(TutorialUserSendMail, selectedUsers) -> do
|
|
cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
|
|
redirect (CTutorialR tid ssh csh tutn TCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])
|
|
(TutorialUserDeregister,selectedUsers) -> do
|
|
nrDel <- runDB $ deleteWhereCount
|
|
[ TutorialParticipantTutorial ==. tutid
|
|
, TutorialParticipantUser <-. Set.toList selectedUsers
|
|
]
|
|
addMessageI Success $ MsgTutorialUsersDeregistered nrDel
|
|
redirect $ CTutorialR tid ssh csh tutn TUsersR
|
|
|
|
let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName
|
|
siteLayoutMsg heading $ do
|
|
setTitleI heading
|
|
$(widgetFile "tutorial-participants")
|