79d4ae20ee
Support course applications BREAKING CHANGE: auditing for course registrations and deregistrations, more tightly couple exam results, exam registration, and course registration (delete them together now)
565 lines
31 KiB
Haskell
565 lines
31 KiB
Haskell
module Handler.Course.Edit
|
|
( getCourseNewR, postCourseNewR
|
|
, getCEditR, postCEditR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Utils.Lens
|
|
import Utils.Form
|
|
import Handler.Utils
|
|
import Handler.Utils.Invitations
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
import Data.Function ((&))
|
|
|
|
import Data.Maybe (fromJust)
|
|
import qualified Data.Set as Set
|
|
import Data.Map ((!))
|
|
import qualified Data.Map as Map
|
|
|
|
import Control.Monad.Trans.Writer (execWriterT)
|
|
|
|
import qualified Database.Esqueleto as E
|
|
|
|
import Jobs.Queue
|
|
|
|
import Handler.Course.LecturerInvite
|
|
|
|
import Text.Blaze.Html.Renderer.Text (renderHtml)
|
|
|
|
import qualified Data.Conduit.List as C
|
|
|
|
|
|
data CourseForm = CourseForm
|
|
{ cfCourseId :: Maybe CourseId
|
|
, cfName :: CourseName
|
|
, cfShort :: CourseShorthand
|
|
, cfSchool :: SchoolId
|
|
, cfTerm :: TermId
|
|
, cfDesc :: Maybe Html
|
|
, cfLink :: Maybe Text
|
|
, cfMatFree :: Bool
|
|
, cfAllocation :: Maybe AllocationCourseForm
|
|
, cfAppRequired :: Bool
|
|
, cfAppInstructions :: Maybe Html
|
|
, cfAppInstructionFiles :: Maybe (Source Handler (Either FileId File))
|
|
, cfAppText :: Bool
|
|
, cfAppFiles :: UploadMode
|
|
, cfAppRatingsVisible :: Bool
|
|
, cfCapacity :: Maybe Int
|
|
, cfSecret :: Maybe Text
|
|
, cfRegFrom :: Maybe UTCTime
|
|
, cfRegTo :: Maybe UTCTime
|
|
, cfDeRegUntil :: Maybe UTCTime
|
|
, cfLecturers :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
|
|
}
|
|
|
|
data AllocationCourseForm = AllocationCourseForm
|
|
{ acfAllocation :: AllocationId
|
|
, acfMinCapacity :: Int
|
|
}
|
|
|
|
courseToForm :: Entity Course -> [Lecturer] -> [(UserEmail, InvitationDBData Lecturer)] -> Maybe (Entity AllocationCourse) -> CourseForm
|
|
courseToForm (Entity cid Course{..}) lecs lecInvites alloc = CourseForm
|
|
{ cfCourseId = Just cid
|
|
, cfName = courseName
|
|
, cfDesc = courseDescription
|
|
, cfLink = courseLinkExternal
|
|
, cfShort = courseShorthand
|
|
, cfTerm = courseTerm
|
|
, cfSchool = courseSchool
|
|
, cfCapacity = courseCapacity
|
|
, cfSecret = courseRegisterSecret
|
|
, cfMatFree = courseMaterialFree
|
|
, cfAllocation = allocationCourseToForm <$> alloc
|
|
, cfAppRequired = courseApplicationsRequired
|
|
, cfAppInstructions = courseApplicationsInstructions
|
|
, cfAppInstructionFiles
|
|
, cfAppText = courseApplicationsText
|
|
, cfAppFiles = courseApplicationsFiles
|
|
, cfAppRatingsVisible = courseApplicationsRatingsVisible
|
|
, cfRegFrom = courseRegisterFrom
|
|
, cfRegTo = courseRegisterTo
|
|
, cfDeRegUntil = courseDeregisterUntil
|
|
, cfLecturers = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs]
|
|
++ [Left (email, mType) | (email, InvDBDataLecturer mType) <- lecInvites ]
|
|
}
|
|
where
|
|
cfAppInstructionFiles = Just . transPipe runDB $ selectAppFiles .| C.map (Left . E.unValue)
|
|
where selectAppFiles = E.selectSource . E.from $ \courseAppInstructionFile -> do
|
|
E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. E.val cid
|
|
return $ courseAppInstructionFile E.^. CourseAppInstructionFileFile
|
|
|
|
|
|
allocationCourseToForm :: Entity AllocationCourse -> AllocationCourseForm
|
|
allocationCourseToForm (Entity _ AllocationCourse{..}) = AllocationCourseForm
|
|
{ acfAllocation = allocationCourseAllocation
|
|
, acfMinCapacity = allocationCourseMinCapacity
|
|
}
|
|
|
|
makeCourseForm :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Form CourseForm
|
|
makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
|
|
-- TODO: Refactor to avoid the four repeated calls to liftHandlerT and three runDBs
|
|
-- let editCid = cfCourseId =<< template -- possible start for refactoring
|
|
|
|
MsgRenderer mr <- getMsgRenderer
|
|
|
|
uid <- liftHandlerT requireAuthId
|
|
(lecSchools, admSchools) <- liftHandlerT . runDB $ (,)
|
|
<$> (map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] [] )
|
|
<*> (map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] [] )
|
|
let userSchools = lecSchools ++ admSchools
|
|
|
|
termsField <- case template of
|
|
-- Change of term is only allowed if user may delete the course (i.e. no participants) or admin
|
|
(Just cform) | (Just cid) <- cfCourseId cform -> liftHandlerT $ do -- edit existing course
|
|
_courseOld@Course{..} <- runDB $ get404 cid
|
|
mayEditTerm <- isAuthorized TermEditR True
|
|
mayDelete <- isAuthorized (CourseR courseTerm courseSchool courseShorthand CDeleteR) True
|
|
return $ if
|
|
| (mayEditTerm == Authorized) || (mayDelete == Authorized) -> termsAllowedField
|
|
| otherwise -> termsSetField [cfTerm cform]
|
|
_allOtherCases -> return termsAllowedField
|
|
|
|
let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
|
|
miAdd _ _ nudge btn = Just $ \csrf -> do
|
|
(addRes, addView) <- mpreq emailField ("" & addName (nudge "user")) Nothing
|
|
addRes' <- for addRes $ liftHandlerT . runDB . getKeyBy . UniqueEmail . CI.mk
|
|
let addRes'' = case (,) <$> addRes <*> addRes' of
|
|
FormSuccess (CI.mk -> email, mLid) ->
|
|
let new = maybe (Left email) Right mLid
|
|
in FormSuccess $ \prev -> if
|
|
| new `elem` Map.elems prev -> FormFailure [ mr $ MsgCourseLecturerAlreadyAdded email ] -- Since there is only ever one email address associated with any user, the case where a @Left email@ corresponds to a @Right lid@ can never occur (at least logically; might still be the same person, of course)
|
|
| otherwise -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) new
|
|
FormFailure errs -> FormFailure errs
|
|
FormMissing -> FormMissing
|
|
addView' = $(widgetFile "course/lecturerMassInput/add")
|
|
return (addRes'', addView')
|
|
|
|
miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType)
|
|
miCell _ (Right lid) defType nudge = \csrf -> do
|
|
(lrwRes,lrwView) <- mreq (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) (join defType)
|
|
User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ get404 lid
|
|
let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown")
|
|
return (Just <$> lrwRes,lrwView')
|
|
miCell _ (Left lEmail) defType nudge = \csrf -> do
|
|
(lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
|
|
let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation")
|
|
return (lrwRes,lrwView')
|
|
|
|
miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape
|
|
-> ListPosition -- ^ Coordinate to delete
|
|
-> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition)
|
|
miDelete = miDeleteList
|
|
|
|
miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool
|
|
miAllowAdd _ _ _ = True
|
|
|
|
miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition
|
|
miAddEmpty _ _ _ = Set.empty
|
|
|
|
miLayout :: ListLength
|
|
-> Map ListPosition (Either UserEmail UserId, FormResult (Maybe LecturerType)) -- ^ massInput state
|
|
-> Map ListPosition Widget -- ^ Cell widgets
|
|
-> Map ListPosition (FieldView UniWorX) -- ^ Deletion buttons
|
|
-> Map (Natural, ListPosition) Widget -- ^ Addition widgets
|
|
-> Widget
|
|
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "course/lecturerMassInput/layout")
|
|
|
|
miIdent :: Text
|
|
miIdent = "lecturers"
|
|
|
|
|
|
lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
|
|
lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) (map liftEither . Map.elems) $ massInput
|
|
MassInput{..}
|
|
(fslI MsgCourseLecturers & setTooltip (UniWorXMessages [SomeMessage MsgCourseLecturerRightsIdentical, SomeMessage MsgMassInputTip]))
|
|
True
|
|
(Just . Map.fromList . zip [0..] $ maybe [(Right uid, Just CourseLecturer)] (map unliftEither . cfLecturers) template)
|
|
mempty
|
|
where
|
|
liftEither :: (Either UserEmail UserId, Maybe LecturerType) -> Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)
|
|
liftEither (Right lid , Just lType) = Right (lid , lType )
|
|
liftEither (Left lEmail, mLType ) = Left (lEmail, mLType)
|
|
liftEither _ = error "liftEither: lecturerForm produced output it should not have been able to"
|
|
|
|
unliftEither :: Either (UserEmail, Maybe LecturerType) (UserId, LecturerType) -> (Either UserEmail UserId, Maybe LecturerType)
|
|
unliftEither (Right (lid , lType )) = (Right lid , Just lType)
|
|
unliftEither (Left (lEmail, mLType)) = (Left lEmail, mLType )
|
|
|
|
(newRegFrom,newRegTo,newDeRegUntil) <- case template of
|
|
(Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing)
|
|
_allIOtherCases -> do
|
|
mbLastTerm <- liftHandlerT $ runDB $ selectFirst [TermActive ==. True] [Desc TermName]
|
|
return ( (Just . toMidnight . termStart . entityVal) <$> mbLastTerm
|
|
, (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm
|
|
, (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm )
|
|
|
|
let
|
|
allocationForm :: AForm Handler (Maybe AllocationCourseForm)
|
|
allocationForm = wFormToAForm $ do
|
|
availableAllocations' <- liftHandlerT . runDB . E.select . E.from $ \(allocation `E.InnerJoin` term) -> do
|
|
E.on $ allocation E.^. AllocationTerm E.==. term E.^. TermId
|
|
E.where_ $ term E.^. TermActive
|
|
return allocation
|
|
|
|
now <- liftIO getCurrentTime
|
|
let
|
|
allocationEnabled :: Entity Allocation -> Bool
|
|
allocationEnabled (Entity _ Allocation{..}) = NTop allocationStaffRegisterFrom <= NTop (Just now)
|
|
&& NTop (Just now) <= NTop allocationStaffRegisterTo
|
|
availableAllocations = filter allocationEnabled availableAllocations'
|
|
|
|
mkAllocationOption :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => Entity Allocation -> m (Option AllocationId)
|
|
mkAllocationOption (Entity aId Allocation{..}) = liftHandlerT $ do
|
|
cID <- encrypt aId :: Handler CryptoUUIDAllocation
|
|
return . Option (mr . MsgCourseAllocationOption (mr . ShortTermIdentifier $ unTermKey allocationTerm) $ CI.original allocationName) aId $ toPathPiece cID
|
|
|
|
case availableAllocations of
|
|
[] -> wforced (convertField (const Nothing) (const False) checkBoxField) (fslI MsgCourseAllocationParticipate & setTooltip MsgCourseNoAllocationsAvailable) Nothing
|
|
_ -> do
|
|
allocationOptions <- mkOptionList <$> mapM mkAllocationOption availableAllocations
|
|
|
|
let
|
|
allocationForm' = AllocationCourseForm
|
|
<$> apreq (selectField' Nothing $ return allocationOptions) (fslI MsgCourseAllocation) (fmap acfAllocation $ template >>= cfAllocation)
|
|
<*> apreq (natFieldI MsgCourseAllocationMinCapacityMustBeNonNegative) (fslI MsgCourseAllocationMinCapacity & setTooltip MsgCourseAllocationMinCapacityTip) (fmap acfMinCapacity $ template >>= cfAllocation)
|
|
|
|
optionalActionW allocationForm' (fslI MsgCourseAllocationParticipate & setTooltip MsgCourseAllocationParticipateTip) (is _Just . cfAllocation <$> template)
|
|
|
|
(result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
|
|
<$> pure (cfCourseId =<< template)
|
|
<*> areq ciField (fslI MsgCourseName) (cfName <$> template)
|
|
<*> areq ciField (fslI MsgCourseShorthand
|
|
-- & addAttr "disabled" "disabled"
|
|
& setTooltip MsgCourseShorthandUnique) (cfShort <$> template)
|
|
<*> areq (schoolFieldFor userSchools) (fslI MsgCourseSchool) (cfSchool <$> template)
|
|
<*> areq termsField (fslI MsgCourseSemester) (cfTerm <$> template)
|
|
<*> aopt htmlField (fslpI MsgCourseDescription "Bitte mindestens die Modulbeschreibung angeben"
|
|
& setTooltip MsgCourseDescriptionTip) (cfDesc <$> template)
|
|
<*> aopt urlField (fslpI MsgCourseHomepageExternal "Optionale externe URL")
|
|
(cfLink <$> template)
|
|
<*> apopt checkBoxField (fslI MsgMaterialFree) (cfMatFree <$> template)
|
|
<* aformSection MsgCourseFormSectionRegistration
|
|
<*> allocationForm
|
|
<*> apopt checkBoxField (fslI MsgCourseApplicationRequired & setTooltip MsgCourseApplicationRequiredTip) (cfAppRequired <$> template)
|
|
<*> (assertM (not . null . renderHtml) <$> aopt htmlField (fslI MsgCourseApplicationInstructions & setTooltip MsgCourseApplicationInstructionsTip) (cfAppInstructions <$> template))
|
|
<*> aopt (multiFileField' . fromMaybe (return ()) $ cfAppInstructionFiles =<< template) (fslI MsgCourseApplicationTemplate & setTooltip MsgCourseApplicationTemplateTip) (cfAppInstructionFiles <$> template)
|
|
<*> apopt checkBoxField (fslI MsgCourseApplicationsText & setTooltip MsgCourseApplicationsTextTip) (cfAppText <$> template)
|
|
<*> uploadModeForm (cfAppFiles <$> template)
|
|
<*> apopt checkBoxField (fslI MsgCourseApplicationRatingsVisible & setTooltip MsgCourseApplicationRatingsVisibleTip) (cfAppRatingsVisible <$> template)
|
|
<*> aopt (natFieldI MsgCourseCapacity) (fslI MsgCourseCapacity
|
|
& setTooltip MsgCourseCapacityTip) (cfCapacity <$> template)
|
|
<*> aopt textField (fslpI MsgCourseSecret (mr MsgCourseSecretFormat)
|
|
& setTooltip MsgCourseSecretTip) (cfSecret <$> template)
|
|
<*> aopt utcTimeField (fslpI MsgRegisterFrom (mr MsgDate)
|
|
& setTooltip MsgCourseRegisterFromTip) (deepAlt (cfRegFrom <$> template) newRegFrom)
|
|
<*> aopt utcTimeField (fslpI MsgRegisterTo (mr MsgDate)
|
|
& setTooltip MsgCourseRegisterToTip) (deepAlt (cfRegTo <$> template) newRegTo)
|
|
<*> aopt utcTimeField (fslpI MsgDeRegUntil (mr MsgDate)
|
|
& setTooltip MsgCourseDeregisterUntilTip) (deepAlt (cfDeRegUntil <$> template) newDeRegUntil)
|
|
<* aformSection MsgCourseFormSectionAdministration
|
|
<*> lecturerForm
|
|
errorMsgs' <- traverse validateCourse result
|
|
return $ case errorMsgs' of
|
|
FormSuccess errorMsgs
|
|
| not $ null errorMsgs ->
|
|
(FormFailure errorMsgs,
|
|
[whamlet|
|
|
<div class="alert alert-danger">
|
|
<div class="alert__content">
|
|
<h4> Fehler:
|
|
<ul>
|
|
$forall errmsg <- errorMsgs
|
|
<li> #{errmsg}
|
|
^{widget}
|
|
|]
|
|
)
|
|
_ -> (result, widget)
|
|
|
|
|
|
validateCourse :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseForm -> m [Text]
|
|
validateCourse CourseForm{..} = do
|
|
now <- liftIO getCurrentTime
|
|
uid <- liftHandlerT requireAuthId
|
|
userAdmin <- liftHandlerT . runDB . getBy $ UniqueUserAdmin uid cfSchool -- FIXME: This /needs/ to be a call to `isAuthorized` on a route
|
|
MsgRenderer mr <- getMsgRenderer
|
|
allocationTerm <- for (acfAllocation <$> cfAllocation) $ fmap allocationTerm . liftHandlerT . runDB . getJust
|
|
|
|
oldAllocatedCapacity <- fmap join . for cfCourseId $ \cid -> liftHandlerT . runDB $ do
|
|
prevAllocationCourse <- getBy $ UniqueAllocationCourse cid
|
|
prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse
|
|
|
|
fmap join . for prevAllocation $ \Allocation{allocationStaffRegisterTo} -> if
|
|
| is _Just userAdmin
|
|
-> return Nothing
|
|
| NTop allocationStaffRegisterTo <= NTop (Just now)
|
|
-> Just . courseCapacity <$> getJust cid
|
|
| otherwise
|
|
-> return Nothing
|
|
|
|
|
|
return
|
|
[ mr msg | (False, msg) <-
|
|
[
|
|
( NTop cfRegFrom <= NTop cfRegTo
|
|
, MsgCourseRegistrationEndMustBeAfterStart
|
|
)
|
|
,
|
|
( NTop cfRegFrom <= NTop cfDeRegUntil
|
|
, MsgCourseDeregistrationEndMustBeAfterStart
|
|
)
|
|
, ( maybe (anyOf (traverse . _Right . _1) (== uid) cfLecturers) (\(Entity _ UserAdmin{}) -> True) userAdmin
|
|
, MsgCourseUserMustBeLecturer
|
|
)
|
|
, ( is _Nothing cfAllocation || is _Just cfCapacity
|
|
, MsgCourseAllocationRequiresCapacity
|
|
)
|
|
, ( maybe True (== cfTerm) allocationTerm
|
|
, MsgCourseAllocationTermMustMatch
|
|
)
|
|
, ( maybe True (== cfCapacity) oldAllocatedCapacity
|
|
, MsgCourseAllocationCapacityMayNotBeChanged
|
|
)
|
|
] ]
|
|
|
|
|
|
getCourseNewR :: Handler Html -- call via toTextUrl
|
|
getCourseNewR = do
|
|
uid <- requireAuthId
|
|
params <- runInputGetResult $ (,,) --TODO: change to AForm, which is used in Course-Copy-Button
|
|
<$> iopt termNewField "tid"
|
|
<*> iopt ciField "ssh"
|
|
<*> iopt ciField "csh"
|
|
|
|
let courseEditHandler' = courseEditHandler $ \p -> Just . SomeRoute $ (CourseNewR, getParams) :#: p
|
|
getParams = concat
|
|
[ [ ("tid", toPathPiece tid) | FormSuccess (Just tid, _, _) <- [params] ]
|
|
, [ ("ssh", toPathPiece ssh) | FormSuccess (_, Just ssh, _) <- [params] ]
|
|
, [ ("csh", toPathPiece csh) | FormSuccess (_, _, Just csh) <- [params] ]
|
|
]
|
|
|
|
let noTemplateAction = courseEditHandler' Nothing
|
|
case params of -- DO NOT REMOVE: without this distinction, lecturers would never see an empty makeCourseForm any more!
|
|
FormMissing -> noTemplateAction
|
|
FormFailure msgs -> forM_ msgs (addMessage Error . toHtml) >>
|
|
noTemplateAction
|
|
FormSuccess (Nothing, Nothing, Nothing) -> noTemplateAction
|
|
FormSuccess (fmap TermKey -> mbTid, fmap SchoolKey -> mbSsh, mbCsh) -> do
|
|
oldCourses <- runDB $
|
|
E.select $ E.from $ \course -> do
|
|
whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
|
whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool E.==. E.val ssh
|
|
whenIsJust mbCsh $ \csh -> E.where_ $ course E.^. CourseShorthand E.==. E.val csh
|
|
let lecturersCourse =
|
|
E.exists $ E.from $ \lecturer ->
|
|
E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
|
|
E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
|
let lecturersSchool =
|
|
E.exists $ E.from $ \user ->
|
|
E.where_ $ user E.^. UserLecturerUser E.==. E.val uid
|
|
E.&&. user E.^. UserLecturerSchool E.==. course E.^. CourseSchool
|
|
let courseCreated c =
|
|
E.sub_select . E.from $ \edit -> do -- oldest edit must be creation
|
|
E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId
|
|
return $ E.min_ $ edit E.^. CourseEditTime
|
|
E.orderBy [ E.desc $ E.case_ [(lecturersCourse, E.val (1 :: Int64))] (E.val 0) -- prefer courses from lecturer
|
|
, E.desc $ E.case_ [(lecturersSchool, E.val (1 :: Int64))] (E.val 0) -- prefer from schools of lecturer
|
|
, E.desc $ courseCreated course] -- most recent created course
|
|
E.limit 1
|
|
return course
|
|
template <- case listToMaybe oldCourses of
|
|
(Just oldTemplate) ->
|
|
let newTemplate = courseToForm oldTemplate [] [] Nothing in
|
|
return $ Just $ newTemplate
|
|
{ cfCourseId = Nothing
|
|
, cfTerm = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness
|
|
, cfRegFrom = Nothing
|
|
, cfRegTo = Nothing
|
|
, cfDeRegUntil = Nothing
|
|
}
|
|
Nothing -> do
|
|
(tidOk,sshOk,cshOk) <- runDB $ (,,)
|
|
<$> ifMaybeM mbTid True existsKey
|
|
<*> ifMaybeM mbSsh True existsKey
|
|
<*> ifMaybeM mbCsh True (\csh -> not . null <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1])
|
|
unless tidOk $ addMessageI Warning $ MsgNoSuchTerm $ fromJust mbTid -- safe, since tidOk==True otherwise
|
|
unless sshOk $ addMessageI Warning $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise
|
|
unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh
|
|
when (tidOk && sshOk && cshOk) $ addMessageI Warning MsgNoSuchCourse
|
|
return Nothing
|
|
courseEditHandler' template
|
|
|
|
postCourseNewR :: Handler Html
|
|
postCourseNewR = courseEditHandler (\p -> Just . SomeRoute $ CourseNewR :#: p) Nothing -- Note: Nothing is safe here, since we will create a new course.
|
|
|
|
getCEditR, postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getCEditR = pgCEditR
|
|
postCEditR = pgCEditR
|
|
|
|
pgCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
pgCEditR tid ssh csh = do
|
|
courseData <- runDB $ do
|
|
mbCourse <- getBy (TermSchoolCourseShort tid ssh csh)
|
|
mbLecs <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
|
|
mbLecInvites <- for mbCourse $ sourceInvitationsList . entityKey
|
|
mbAllocation <- for mbCourse $ \course -> getBy . UniqueAllocationCourse $ entityKey course
|
|
return $ (,,,) <$> mbCourse <*> mbLecs <*> mbLecInvites <*> mbAllocation
|
|
-- IMPORTANT: both GET and POST Handler must use the same template,
|
|
-- since an Edit is identified via CourseID, which is not embedded in the received form data for security reasons.
|
|
courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ $(uncurryN 4) courseToForm <$> courseData
|
|
|
|
|
|
-- | Course Creation and Editing
|
|
-- | IMPORTANT: in case of Edit, Post/Get Request is provided with the same CourseForm template (cannot be Nothing),
|
|
-- | since an edit is identified via cfCourseId which is not contained in the received form data for security reasons!
|
|
courseEditHandler :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Handler Html
|
|
courseEditHandler miButtonAction mbCourseForm = do
|
|
aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!!
|
|
((result, formWidget), formEnctype) <- runFormPost $ makeCourseForm miButtonAction mbCourseForm
|
|
formResult result $ \case
|
|
res@CourseForm
|
|
{ cfCourseId = Nothing
|
|
, cfShort = csh
|
|
, cfSchool = ssh
|
|
, cfTerm = tid
|
|
} -> do -- create new course
|
|
now <- liftIO getCurrentTime
|
|
insertOkay <- runDBJobs $ do
|
|
insertOkay <- let CourseForm{..} = res
|
|
in insertUnique Course
|
|
{ courseName = cfName
|
|
, courseDescription = cfDesc
|
|
, courseLinkExternal = cfLink
|
|
, courseShorthand = cfShort
|
|
, courseTerm = cfTerm
|
|
, courseSchool = cfSchool
|
|
, courseCapacity = cfCapacity
|
|
, courseRegisterSecret = cfSecret
|
|
, courseMaterialFree = cfMatFree
|
|
, courseApplicationsRequired = cfAppRequired
|
|
, courseApplicationsInstructions = cfAppInstructions
|
|
, courseApplicationsText = cfAppText
|
|
, courseApplicationsFiles = cfAppFiles
|
|
, courseApplicationsRatingsVisible = cfAppRatingsVisible
|
|
, courseRegisterFrom = cfRegFrom
|
|
, courseRegisterTo = cfRegTo
|
|
, courseDeregisterUntil = cfDeRegUntil
|
|
}
|
|
whenIsJust insertOkay $ \cid -> do
|
|
let (invites, adds) = partitionEithers $ cfLecturers res
|
|
insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds
|
|
sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
|
|
insert_ $ CourseEdit aid now cid
|
|
upsertAllocationCourse cid $ cfAllocation res
|
|
return insertOkay
|
|
case insertOkay of
|
|
Just _ -> do
|
|
-- addMessageI Info $ MsgCourseNewOk tid ssh csh
|
|
redirect $ CourseR tid ssh csh CShowR
|
|
Nothing ->
|
|
addMessageI Warning $ MsgCourseNewDupShort tid ssh csh
|
|
|
|
res@CourseForm
|
|
{ cfCourseId = Just cid
|
|
, cfShort = csh
|
|
, cfSchool = ssh
|
|
, cfTerm = tid
|
|
} -> do -- edit existing course
|
|
now <- liftIO getCurrentTime
|
|
-- addMessage "debug" [shamlet| #{show res}|]
|
|
success <- runDBJobs $ do
|
|
old <- get cid
|
|
case old of
|
|
Nothing -> addMessageI Error MsgInvalidInput $> False
|
|
(Just _) -> do
|
|
updOkay <- let CourseForm{..} = res
|
|
in myReplaceUnique cid Course
|
|
{ courseName = cfName
|
|
, courseDescription = cfDesc
|
|
, courseLinkExternal = cfLink
|
|
, courseShorthand = cfShort
|
|
, courseTerm = cfTerm -- dangerous
|
|
, courseSchool = cfSchool
|
|
, courseCapacity = cfCapacity
|
|
, courseRegisterSecret = cfSecret
|
|
, courseMaterialFree = cfMatFree
|
|
, courseApplicationsRequired = cfAppRequired
|
|
, courseApplicationsInstructions = cfAppInstructions
|
|
, courseApplicationsText = cfAppText
|
|
, courseApplicationsFiles = cfAppFiles
|
|
, courseApplicationsRatingsVisible = cfAppRatingsVisible
|
|
, courseRegisterFrom = cfRegFrom
|
|
, courseRegisterTo = cfRegTo
|
|
, courseDeregisterUntil = cfDeRegUntil
|
|
}
|
|
case updOkay of
|
|
(Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False
|
|
Nothing -> do
|
|
deleteWhere [LecturerCourse ==. cid]
|
|
deleteWhere [InvitationFor ==. invRef @Lecturer cid, InvitationEmail /<-. toListOf (folded . _Left . _1) (cfLecturers res)]
|
|
let (invites, adds) = partitionEithers $ cfLecturers res
|
|
insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds
|
|
sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
|
|
|
|
insert_ $ CourseEdit aid now cid
|
|
|
|
let
|
|
finsert val = do
|
|
fId <- lift $ either return insert val
|
|
tell $ Set.singleton fId
|
|
lift $
|
|
void . insertUnique $ CourseAppInstructionFile cid fId
|
|
keep <- execWriterT . runConduit $ transPipe liftHandlerT (traverse_ id $ cfAppInstructionFiles res) .| C.mapM_ finsert
|
|
acfs <- selectList [ CourseAppInstructionFileCourse ==. cid, CourseAppInstructionFileFile /<-. Set.toList keep ] []
|
|
mapM_ deleteCascade $ map (courseAppInstructionFileFile . entityVal) acfs
|
|
|
|
upsertAllocationCourse cid $ cfAllocation res
|
|
|
|
addMessageI Success $ MsgCourseEditOk tid ssh csh
|
|
return True
|
|
when success $ redirect $ CourseR tid ssh csh CShowR
|
|
actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute
|
|
defaultLayout $ do
|
|
setTitleI MsgCourseEditTitle
|
|
wrapForm formWidget def
|
|
{ formAction = Just $ SomeRoute actionUrl
|
|
, formEncoding = formEnctype
|
|
}
|
|
|
|
upsertAllocationCourse :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m ()
|
|
upsertAllocationCourse cid cfAllocation = do
|
|
now <- liftIO getCurrentTime
|
|
uid <- liftHandlerT requireAuthId
|
|
Course{..} <- getJust cid
|
|
prevAllocationCourse <- getBy $ UniqueAllocationCourse cid
|
|
prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse
|
|
userAdmin <- liftHandlerT . runDB . getBy $ UniqueUserAdmin uid courseSchool -- FIXME: This /needs/ to be a call to `isAuthorized` on a route
|
|
|
|
doEdit <- if
|
|
| is _Just userAdmin
|
|
-> return True
|
|
| Just Allocation{allocationStaffRegisterTo} <- prevAllocation
|
|
, NTop allocationStaffRegisterTo <= NTop (Just now)
|
|
-> False <$ addMessageI Error MsgAllocationStaffRegisterToExpired
|
|
| otherwise
|
|
-> return True
|
|
|
|
when doEdit $
|
|
case cfAllocation of
|
|
Just AllocationCourseForm{..} ->
|
|
void $ upsert AllocationCourse
|
|
{ allocationCourseAllocation = acfAllocation
|
|
, allocationCourseCourse = cid
|
|
, allocationCourseMinCapacity = acfMinCapacity
|
|
}
|
|
[ AllocationCourseAllocation =. acfAllocation
|
|
, AllocationCourseCourse =. cid
|
|
, AllocationCourseMinCapacity =. acfMinCapacity
|
|
]
|
|
Nothing
|
|
| Just (Entity prevId _) <- prevAllocationCourse
|
|
-> delete prevId
|
|
_other -> return ()
|