589 lines
33 KiB
Haskell
589 lines
33 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.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 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 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 (ConduitT () (Either FileId File) Handler ())
|
|
, 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] -> Map 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) <- Map.toList 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 . 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
|
|
|
|
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 emailField ("" & addName (nudge "user")) Nothing
|
|
addRes' <- for addRes $ liftHandler . 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} <- 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 <- messageI Warning 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 (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 <- liftHandler $ 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' <- 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)
|
|
|
|
now <- liftIO getCurrentTime
|
|
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
|
|
userAdmin = not $ null adminSchools
|
|
mayChange = fromMaybe True $ (|| userAdmin) <$> currentAllocationAvailable
|
|
|
|
allocationForm' =
|
|
let ainp :: Field Handler a -> FieldSettings UniWorX -> Maybe a -> AForm Handler a
|
|
ainp
|
|
| mayChange
|
|
= apreq
|
|
| otherwise
|
|
= aforcedJust
|
|
in AllocationCourseForm
|
|
<$> ainp (selectField' Nothing $ return allocationOptions) (fslI MsgCourseAllocation) (fmap acfAllocation $ template >>= cfAllocation)
|
|
<*> ainp (natFieldI MsgCourseAllocationMinCapacityMustBeNonNegative) (fslI MsgCourseAllocationMinCapacity & setTooltip MsgCourseAllocationMinCapacityTip) (fmap acfMinCapacity $ 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
|
|
<$> pure (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)
|
|
& setTooltip MsgCourseDescriptionTip) (cfDesc <$> template)
|
|
<*> aopt (urlField & cfStrip) (fslpI MsgCourseHomepageExternal (mr MsgCourseHomepageExternalPlaceholder))
|
|
(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 & 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
|
|
allocationTerm <- for (acfAllocation <$> cfAllocation) $ lift . fmap allocationTerm . getJust
|
|
|
|
oldAllocatedCapacity <- fmap join . for cfCourseId $ \cid -> lift $ do
|
|
prevAllocationCourse <- getBy $ UniqueAllocationCourse cid
|
|
prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse
|
|
|
|
fmap join . for prevAllocation $ \Allocation{allocationStaffAllocationTo, allocationRegisterByCourse} -> if
|
|
| userAdmin
|
|
-> return Nothing
|
|
| NTop allocationStaffAllocationTo <= NTop (Just now)
|
|
, NTop allocationRegisterByCourse > NTop (Just now)
|
|
-> Just . courseCapacity <$> getJust cid
|
|
| otherwise
|
|
-> return Nothing
|
|
|
|
guardValidation MsgCourseRegistrationEndMustBeAfterStart
|
|
$ NTop cfRegFrom <= NTop cfRegTo
|
|
guardValidation MsgCourseDeregistrationEndMustBeAfterStart
|
|
$ fromMaybe True $ (<=) <$> cfRegFrom <*> cfDeRegUntil
|
|
unless userAdmin $
|
|
guardValidation MsgCourseUserMustBeLecturer
|
|
$ anyOf (traverse . _Right . _1) (== uid) cfLecturers
|
|
guardValidation MsgCourseAllocationRequiresCapacity
|
|
$ is _Nothing cfAllocation || is _Just cfCapacity
|
|
guardValidation MsgCourseAllocationTermMustMatch
|
|
$ maybe True (== cfTerm) allocationTerm
|
|
guardValidation MsgCourseAllocationCapacityMayNotBeChanged
|
|
$ maybe True (== cfCapacity) oldAllocatedCapacity
|
|
|
|
warnValidation MsgCourseShorthandTooLong
|
|
$ length (CI.original cfShort) <= 10
|
|
|
|
|
|
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
|
|
, 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 liftHandler (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 :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m ()
|
|
upsertAllocationCourse cid cfAllocation = do
|
|
now <- liftIO getCurrentTime
|
|
Course{..} <- getJust cid
|
|
prevAllocationCourse <- getBy $ UniqueAllocationCourse cid
|
|
prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse
|
|
userAdmin <- fromMaybe False <$> for prevAllocation (\Allocation{..} -> hasWriteAccessTo $ SchoolR allocationSchool SchoolEditR)
|
|
|
|
doEdit <- if
|
|
| userAdmin
|
|
-> return True
|
|
| Just Allocation{allocationStaffRegisterTo} <- prevAllocation
|
|
, NTop allocationStaffRegisterTo <= NTop (Just now)
|
|
-> let anyChanges
|
|
| Just AllocationCourseForm{..} <- cfAllocation
|
|
, Just (Entity _ AllocationCourse{..}) <- prevAllocationCourse
|
|
= or [ acfAllocation /= allocationCourseAllocation
|
|
, acfMinCapacity /= allocationCourseMinCapacity
|
|
]
|
|
| otherwise
|
|
= True
|
|
in False <$ when anyChanges (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 ()
|