609 lines
35 KiB
Haskell
609 lines
35 KiB
Haskell
module Handler.Course.Edit
|
|
( getCourseNewR, postCourseNewR
|
|
, getCEditR, postCEditR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Utils.Form
|
|
import Handler.Utils
|
|
import Handler.Utils.Invitations
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import Data.Maybe (fromJust)
|
|
import qualified Data.Set as Set
|
|
import Data.Map ((!))
|
|
import qualified Data.Map as Map
|
|
|
|
import qualified Control.Monad.State.Class as State
|
|
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import Jobs.Queue
|
|
|
|
import Handler.Course.LecturerInvite
|
|
|
|
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
|
|
, cfVisFrom :: Maybe UTCTime
|
|
, cfVisTo :: Maybe UTCTime
|
|
, cfMatFree :: Bool
|
|
, cfAllocation :: Maybe AllocationCourseForm
|
|
, cfAppRequired :: Bool
|
|
, cfAppInstructions :: Maybe Html
|
|
, cfAppInstructionFiles :: Maybe FileUploads
|
|
, 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
|
|
, acfAcceptSubstitutes :: Maybe UTCTime
|
|
, acfDeregisterNoShow :: Bool
|
|
}
|
|
|
|
makeLenses_ ''CourseForm
|
|
makeLenses_ ''AllocationCourseForm
|
|
|
|
courseToForm :: Entity Course -> [Lecturer] -> Map UserEmail (InvitationDBData Lecturer) -> Maybe (Entity AllocationCourse) -> CourseForm
|
|
courseToForm cEnt@(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 cEnt <$> alloc
|
|
, cfAppRequired = courseApplicationsRequired
|
|
, cfAppInstructions = courseApplicationsInstructions
|
|
, cfAppInstructionFiles
|
|
, cfAppText = courseApplicationsText
|
|
, cfAppFiles = courseApplicationsFiles
|
|
, cfAppRatingsVisible = courseApplicationsRatingsVisible
|
|
, cfVisFrom = courseVisibleFrom
|
|
, cfVisTo = courseVisibleTo
|
|
, cfRegFrom = courseRegisterFrom
|
|
, cfRegTo = courseRegisterTo
|
|
, cfDeRegUntil = courseDeregisterUntil
|
|
, cfLecturers = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs]
|
|
++ [Left (email, mType) | (email, InvDBDataLecturer mType) <- Map.toList lecInvites ]
|
|
}
|
|
where
|
|
cfAppInstructionFiles = Just . transPipe runDB $ selectAppFiles .| C.map (view $ _entityVal . _FileReference . _1)
|
|
where selectAppFiles = E.selectSource . E.from $ \courseAppInstructionFile -> do
|
|
E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. E.val cid
|
|
return courseAppInstructionFile
|
|
|
|
|
|
allocationCourseToForm :: Entity Course -> Entity AllocationCourse -> AllocationCourseForm
|
|
allocationCourseToForm (Entity _ Course{..}) (Entity _ AllocationCourse{..}) = AllocationCourseForm
|
|
{ acfAllocation = allocationCourseAllocation
|
|
, acfMinCapacity = allocationCourseMinCapacity
|
|
, acfAcceptSubstitutes = allocationCourseAcceptSubstitutes
|
|
, acfDeregisterNoShow = courseDeregisterNoShow
|
|
}
|
|
|
|
makeCourseForm :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Form CourseForm
|
|
makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB validateCourse $ \html -> do
|
|
-- TODO: Refactor to avoid the four repeated calls to liftHandler and three runDBs
|
|
-- let editCid = cfCourseId =<< template -- possible start for refactoring
|
|
|
|
now <- liftIO getCurrentTime
|
|
MsgRenderer mr <- getMsgRenderer
|
|
|
|
uid <- liftHandler requireAuthId
|
|
(lecturerSchools, adminSchools, oldSchool) <- liftHandler . runDB $ do
|
|
lecturerSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolLecturer]] []
|
|
protoAdminSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin]] []
|
|
adminSchools <- filterM (hasWriteAccessTo . flip SchoolR SchoolEditR) protoAdminSchools
|
|
oldSchool <- forM (cfCourseId =<< template) $ fmap courseSchool . getJust
|
|
return (lecturerSchools, adminSchools, oldSchool)
|
|
let userSchools = nub . maybe id (:) oldSchool $ lecturerSchools ++ adminSchools
|
|
|
|
(termsField, userTerms) <- liftHandler $ 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 -> do -- edit existing course
|
|
_courseOld@Course{..} <- runDB $ get404 cid
|
|
mayEditTerm <- isAuthorized TermEditR True
|
|
mayDelete <- isAuthorized (CourseR courseTerm courseSchool courseShorthand CDeleteR) True
|
|
if
|
|
| (mayEditTerm == Authorized) || (mayDelete == Authorized)
|
|
-> (termsAllowedField, ) <$> runDB (selectKeysList [TermActive ==. True] [])
|
|
| otherwise
|
|
-> return (termsSetField [cfTerm cform], [cfTerm cform])
|
|
_allOtherCases -> (termsAllowedField, ) <$> runDB (selectKeysList [TermActive ==. True] [])
|
|
|
|
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 (multiUserInvitationField $ MUILookupAnyUser Nothing) (fslI MsgCourseLecturerEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
|
|
let addRes'' = addRes <&> \newDat oldDat -> if
|
|
| existing <- newDat `Set.intersection` Set.fromList (Map.elems oldDat)
|
|
, not $ Set.null existing
|
|
-> FormFailure [mr MsgCourseLecturerAlreadyAdded]
|
|
| otherwise
|
|
-> FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) $ Map.lookupMax oldDat ..] $ Set.toList newDat
|
|
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) (fslI MsgLecturerType & addName (nudge "lecturer-type")) (join defType)
|
|
User{userEmail, userDisplayName, userSurname} <- liftHandler . 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
|
|
invWarnMsg <- messageIconI Info IconEmail MsgEmailInvitationWarning
|
|
let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation")
|
|
return (lrwRes,lrwView')
|
|
|
|
miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape
|
|
-> ListPosition -- ^ Coordinate to delete
|
|
-> MaybeT (MForm (HandlerFor UniWorX)) (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 MsgCourseLecturerRightsIdentical)
|
|
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 )
|
|
|
|
(newVisFrom,newRegFrom,newRegTo,newDeRegUntil) <- case template of
|
|
(Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing,Nothing)
|
|
_allIOtherCases -> do
|
|
mbLastTerm <- liftHandler $ runDB $ selectFirst [TermActive ==. True] [Desc TermName]
|
|
return ( Just $ Just now
|
|
, 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' <- liftHandler . runDB . E.select . E.from $ \(allocation `E.InnerJoin` term) -> do
|
|
E.on $ allocation E.^. AllocationTerm E.==. term E.^. TermId
|
|
|
|
let alreadyParticipates = flip (maybe E.false) (template >>= cfCourseId) $ \cid ->
|
|
E.exists . E.from $ \allocationCourse ->
|
|
E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. E.val cid
|
|
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. allocation E.^. AllocationId
|
|
|
|
E.where_ $ term E.^. TermActive
|
|
E.||. alreadyParticipates
|
|
E.||. allocation E.^. AllocationSchool `E.in_` E.valList adminSchools
|
|
return (allocation, alreadyParticipates)
|
|
|
|
let
|
|
allocationEnabled :: Entity Allocation -> Bool
|
|
allocationEnabled (Entity _ Allocation{..})
|
|
= ( NTop allocationStaffRegisterFrom <= NTop (Just now)
|
|
&& NTop (Just now) <= NTop allocationStaffRegisterTo
|
|
) || allocationSchool `elem` adminSchools
|
|
availableAllocations = availableAllocations' ^.. folded . filtered (allocationEnabled . view _1) . _1
|
|
activeAllocations = availableAllocations' ^.. folded . filtered ((&&) <$> (not <$> allocationEnabled . view _1) <*> view (_2 . _Value)) . _1
|
|
|
|
mkAllocationOption :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => Entity Allocation -> m (Option AllocationId)
|
|
mkAllocationOption (Entity aId Allocation{..}) = liftHandler $ do
|
|
cID <- encrypt aId :: Handler CryptoUUIDAllocation
|
|
return . Option (mr . MsgCourseAllocationOption (mr . ShortTermIdentifier $ unTermKey allocationTerm) $ CI.original allocationName) aId $ toPathPiece cID
|
|
|
|
currentAllocationAvailable = (\alloc -> any ((== alloc) . entityKey) availableAllocations) . acfAllocation <$> (template >>= cfAllocation)
|
|
|
|
case (currentAllocationAvailable, availableAllocations) of
|
|
(Nothing, []) -> wforced (convertField (const Nothing) (const False) checkBoxField) (fslI MsgCourseAllocationParticipate & setTooltip MsgCourseNoAllocationsAvailable) Nothing
|
|
_ -> do
|
|
allocationOptions <- mkOptionList <$> mapM mkAllocationOption (availableAllocations ++ activeAllocations)
|
|
|
|
let
|
|
explainedAllocationOptions = return allocationOptions `explainOptionList` \allocId -> hoistMaybe . listToMaybe $ do
|
|
(Entity allocId' Allocation{..}, _) <- availableAllocations'
|
|
guard $ allocId' == allocId
|
|
toWidget <$> hoistMaybe allocationStaffDescription
|
|
|
|
doExplain = has (folded . _entityVal . _allocationStaffDescription . _Just) $ availableAllocations ++ activeAllocations
|
|
allocField | doExplain = explainedSelectionField Nothing explainedAllocationOptions
|
|
| otherwise = selectField' Nothing $ return allocationOptions
|
|
|
|
userAdmin = not $ null adminSchools
|
|
mayChange = Just False /= fmap (|| userAdmin) currentAllocationAvailable
|
|
|
|
allocationForm' =
|
|
let ainp :: Field Handler a -> FieldSettings UniWorX -> Maybe a -> AForm Handler a
|
|
ainp
|
|
| mayChange
|
|
= apreq
|
|
| otherwise
|
|
= aforcedJust
|
|
in AllocationCourseForm
|
|
<$> ainp allocField (fslI MsgCourseAllocation) (fmap acfAllocation $ template >>= cfAllocation)
|
|
<*> ainp (natFieldI MsgCourseAllocationMinCapacityMustBeNonNegative) (fslI MsgCourseAllocationMinCapacity & setTooltip MsgCourseAllocationMinCapacityTip) (fmap acfMinCapacity $ template >>= cfAllocation)
|
|
<*> aopt utcTimeField (fslI MsgCourseAcceptSubstitutesUntil & setTooltip MsgCourseAcceptSubstitutesUntilTip) (fmap acfAcceptSubstitutes $ template >>= cfAllocation)
|
|
<*> apopt checkBoxField (fslI MsgCourseDeregisterNoShow & setTooltip MsgCourseDeregisterNoShowTip) ((<|> Just True) . fmap acfDeregisterNoShow $ template >>= cfAllocation)
|
|
|
|
optionalActionW' (bool mforcedJust mpopt mayChange) allocationForm' (fslI MsgCourseAllocationParticipate & setTooltip MsgCourseAllocationParticipateTip) (is _Just . cfAllocation <$> template)
|
|
|
|
-- let autoUnzipInfo = [|Entpackt hochgeladene Zip-Dateien (*.zip) automatisch und fügt den Inhalt dem Stamm-Verzeichnis der Abgabe hinzu. TODO|]
|
|
|
|
multipleSchoolsMsg <- messageI Warning MsgCourseSchoolMultipleTip
|
|
multipleTermsMsg <- messageI Warning MsgCourseSemesterMultipleTip
|
|
|
|
(result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
|
|
(cfCourseId =<< template)
|
|
<$> areq (textField & cfStrip & cfCI) (fslI MsgCourseName) (cfName <$> template)
|
|
<*> areq (textField & cfStrip & cfCI) (fslpI MsgCourseShorthand "ProMo, LinAlg1, AlgoDat, Ana2, EiP, …"
|
|
-- & addAttr "disabled" "disabled"
|
|
& setTooltip MsgCourseShorthandUnique) (cfShort <$> template)
|
|
<* bool (pure ()) (aformMessage multipleSchoolsMsg) (length userSchools > 1)
|
|
<*> areq (schoolFieldFor userSchools) (fslI MsgCourseSchool) (cfSchool <$> template)
|
|
<* bool (pure ()) (aformMessage multipleTermsMsg) (length userTerms > 1)
|
|
<*> areq termsField (fslI MsgCourseSemester) (cfTerm <$> template)
|
|
<*> aopt htmlField (fslpI MsgCourseDescription (mr MsgCourseDescriptionPlaceholder))
|
|
(cfDesc <$> template)
|
|
<*> aopt (urlField & cfStrip) (fslpI MsgCourseHomepageExternal (mr MsgCourseHomepageExternalPlaceholder))
|
|
(cfLink <$> template)
|
|
<*> aopt utcTimeField (fslpI MsgCourseVisibleFrom (mr MsgDate)
|
|
& setTooltip MsgCourseVisibleFromTip) (deepAlt (cfVisFrom <$> template) newVisFrom)
|
|
<*> aopt utcTimeField (fslpI MsgCourseVisibleTo (mr MsgDate)
|
|
& setTooltip MsgCourseVisibleToTip) (cfVisTo <$> template)
|
|
<*> apopt checkBoxField (fslI MsgMaterialFree) (cfMatFree <$> template)
|
|
<* aformSection MsgCourseFormSectionRegistration
|
|
<*> allocationForm
|
|
<*> apopt checkBoxField (fslI MsgCourseApplicationRequired & setTooltip MsgCourseApplicationRequiredTip) (cfAppRequired <$> template)
|
|
<*> 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 (fslI MsgCourseApplicationsFiles & setTooltip MsgCourseApplicationsFilesTip) (fmap cfAppFiles template <|> pure NoUpload)
|
|
<*> apopt checkBoxField (fslI MsgCourseApplicationRatingsVisible & setTooltip MsgCourseApplicationRatingsVisibleTip) (cfAppRatingsVisible <$> template)
|
|
<*> aopt (natFieldI MsgCourseCapacity) (fslI MsgCourseCapacity
|
|
& setTooltip MsgCourseCapacityTip) (cfCapacity <$> template)
|
|
<*> aopt (textField & cfStrip) (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
|
|
return (result, widget)
|
|
|
|
|
|
validateCourse :: FormValidator CourseForm (YesodDB UniWorX) ()
|
|
validateCourse = do
|
|
CourseForm{..} <- State.get
|
|
|
|
now <- liftIO getCurrentTime
|
|
uid <- liftHandler requireAuthId
|
|
userAdmin <- hasWriteAccessTo $ SchoolR cfSchool SchoolEditR
|
|
newAllocationTerm <- for (acfAllocation <$> cfAllocation) $ lift . fmap allocationTerm . getJust
|
|
|
|
prevAllocationCourse <- join <$> traverse (lift . getBy . UniqueAllocationCourse) cfCourseId
|
|
prevAllocation <- fmap join . traverse (lift . getEntity) $ allocationCourseAllocation . entityVal <$> prevAllocationCourse
|
|
|
|
oldAllocatedCapacity <- if
|
|
| Just (Entity _ Allocation{..}) <- prevAllocation
|
|
, Just (Entity _ AllocationCourse{..}) <- prevAllocationCourse
|
|
, NTop allocationStaffAllocationTo <= NTop (Just now)
|
|
, NTop allocationRegisterByCourse > NTop (Just now)
|
|
-> lift $ Just . courseCapacity <$> getJust allocationCourseCourse
|
|
| otherwise
|
|
-> return Nothing
|
|
let oldAllocation = do
|
|
Entity allocId Allocation{..} <- prevAllocation
|
|
guard $ NTop (Just now) > NTop allocationStaffRegisterTo
|
|
pure $ Just allocId
|
|
oldAllocatedMinCapacity = do
|
|
Entity _ Allocation{..} <- prevAllocation
|
|
Entity _ AllocationCourse{..} <- prevAllocationCourse
|
|
guard $ NTop (Just now) > NTop allocationStaffRegisterTo
|
|
pure $ Just allocationCourseMinCapacity
|
|
|
|
guardValidation MsgCourseVisibilityEndMustBeAfterStart
|
|
$ NTop cfVisFrom <= NTop cfVisTo
|
|
guardValidation MsgCourseRegistrationEndMustBeAfterStart
|
|
$ NTop cfRegFrom <= NTop cfRegTo
|
|
guardValidation MsgCourseDeregistrationEndMustBeAfterStart
|
|
$ Just False /= ((<=) <$> cfRegFrom <*> cfDeRegUntil)
|
|
guardValidation MsgCourseAllocationRequiresCapacity
|
|
$ is _Nothing cfAllocation || is _Just cfCapacity
|
|
guardValidation MsgCourseAllocationTermMustMatch
|
|
$ maybe True (== cfTerm) newAllocationTerm
|
|
unless userAdmin $ do
|
|
guardValidation MsgCourseUserMustBeLecturer
|
|
$ anyOf (traverse . _Right . _1) (== uid) cfLecturers
|
|
guardValidation MsgCourseAllocationCapacityMayNotBeChanged
|
|
$ maybe True (== cfCapacity) oldAllocatedCapacity
|
|
guardValidation MsgAllocationStaffRegisterToExpiredAllocation
|
|
$ maybe True (== fmap acfAllocation cfAllocation) oldAllocation
|
|
guardValidation MsgAllocationStaffRegisterToExpiredMinCapacity
|
|
$ maybe True (== fmap acfMinCapacity cfAllocation) oldAllocatedMinCapacity
|
|
|
|
warnValidation MsgCourseShorthandTooLong
|
|
$ length (CI.original cfShort) <= 10
|
|
warnValidation MsgCourseNotAlwaysVisibleDuringRegistration
|
|
$ NTop cfVisFrom <= NTop cfRegFrom && NTop cfRegTo <= NTop cfVisTo
|
|
|
|
warnValidation MsgCourseApplicationInstructionsRecommended
|
|
$ (is _Just cfAppInstructions || is _Just cfAppInstructionFiles)
|
|
|| not (cfAppText || isn't _NoUpload cfAppFiles)
|
|
|
|
|
|
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.^. UserFunctionUser E.==. E.val uid
|
|
E.&&. user E.^. UserFunctionSchool E.==. course E.^. CourseSchool
|
|
E.&&. user E.^. UserFunctionFunction E.==. E.val SchoolLecturer
|
|
let courseCreated c =
|
|
E.subSelectMaybe . 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 mempty mempty 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 $ sourceInvitationsF . 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
|
|
, courseVisibleFrom = cfVisFrom
|
|
, courseVisibleTo = cfVisTo
|
|
, courseRegisterFrom = cfRegFrom
|
|
, courseRegisterTo = cfRegTo
|
|
, courseDeregisterUntil = cfDeRegUntil
|
|
, courseDeregisterNoShow = maybe False acfDeregisterNoShow cfAllocation
|
|
}
|
|
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
|
|
, courseVisibleFrom = cfVisFrom
|
|
, courseVisibleTo = cfVisTo
|
|
, courseRegisterFrom = cfRegFrom
|
|
, courseRegisterTo = cfRegTo
|
|
, courseDeregisterUntil = cfDeRegUntil
|
|
, courseDeregisterNoShow = maybe False acfDeregisterNoShow cfAllocation
|
|
}
|
|
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 mkFilter CourseAppInstructionFileResidual{..} = [ CourseAppInstructionFileCourse ==. courseAppInstructionFileResidualCourse ]
|
|
in void . replaceFileReferences mkFilter (CourseAppInstructionFileResidual cid) . sequence_ $ cfAppInstructionFiles res
|
|
|
|
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 :: CourseId -> Maybe AllocationCourseForm -> YesodJobDB UniWorX ()
|
|
upsertAllocationCourse cid = \case
|
|
Just AllocationCourseForm{..} -> do
|
|
prevAllocationCourse <- getBy $ UniqueAllocationCourse cid
|
|
|
|
void $ upsert AllocationCourse
|
|
{ allocationCourseAllocation = acfAllocation
|
|
, allocationCourseCourse = cid
|
|
, allocationCourseMinCapacity = acfMinCapacity
|
|
, allocationCourseAcceptSubstitutes = acfAcceptSubstitutes
|
|
}
|
|
[ AllocationCourseAllocation =. acfAllocation
|
|
, AllocationCourseCourse =. cid
|
|
, AllocationCourseMinCapacity =. acfMinCapacity
|
|
, AllocationCourseAcceptSubstitutes =. acfAcceptSubstitutes
|
|
]
|
|
|
|
when (Just acfAllocation /= fmap (allocationCourseAllocation . entityVal) prevAllocationCourse) $
|
|
queueDBJob . JobQueueNotification $ NotificationAllocationNewCourse acfAllocation cid
|
|
Nothing ->
|
|
deleteWhere [ AllocationCourseCourse ==. cid ]
|