feat(allocations): add courses to allocations
This commit is contained in:
Gregor Kleen
parent
7d7bb844f5
commit
14a9a45674
@ -28,6 +28,10 @@ export class InteractiveFieldset {
|
||||
return false;
|
||||
}
|
||||
|
||||
if (this._element.querySelector('[uw-interactive-fieldset]')) {
|
||||
return false;
|
||||
}
|
||||
|
||||
// param conditionalInput
|
||||
if (!this._element.dataset.conditionalInput) {
|
||||
throw new Error('Interactive Fieldset needs a selector for a conditional input!');
|
||||
|
||||
@ -142,6 +142,28 @@ CourseUserSendMail: Mitteilung verschicken
|
||||
TutorialUserDeregister: Vom Tutorium Abmelden
|
||||
TutorialUserSendMail: Mitteilung verschicken
|
||||
TutorialUsersDeregistered count@Int64: #{show count} Tutorium-Teilnehmer abgemeldet
|
||||
CourseAllocationParticipate: Teilnahme an Zentralanmeldung
|
||||
CourseAllocationParticipateTip: Wird an einer Zentralanmeldung teilgenommen, kann es sein, dass Sie bestimmte Rechte, die Sie normalerweise bzgl. Ihres Kurses hätten, nicht ausüben können (z.B. Studenten direkt zum Kurs anmelden, Studenten abmelden, ...).
|
||||
CourseAllocation: Zentralanmeldung
|
||||
CourseAllocationOption term@Text name@Text: #{name} (#{term})
|
||||
CourseAllocationMinCapacity: Minimale Teilnehmeranzahl
|
||||
CourseAllocationMinCapacityTip: Wenn der Veranstaltung bei der Zentralanmeldung weniger als diese Anzahl von Teilnehmern zugeteilt würden, werden diese stattdessen auf andere Kurse umverteilt
|
||||
CourseAllocationMinCapacityMustBeNonNegative: Minimale Teilnehmeranzahl darf nicht negativ sein
|
||||
CourseAllocationInstructions: Anweisungen zur Bewerbung
|
||||
CourseAllocationInstructionsTip: Wird den Studierenden angezeigt, wenn sie diese Veranstaltung in ihre Präferenzliste aufnehmen
|
||||
CourseAllocationApplicationTemplate: Bewerbungsvorlagen
|
||||
CourseAllocationApplicationText: Text-Bewerbungen
|
||||
CourseAllocationApplicationTextTip: Sollen die Studierenden Bewerbungen (ggf. zusätzlich zu abgegebenen Dateien) als unformatierten Text einreichen?
|
||||
CourseAllocationApplicationRatingsVisible: Feedback für Bewerbungen
|
||||
CourseAllocationApplicationRatingsVisibleTip: Sollen Bewertung und Kommentar der Bewerbungen den Studierenden nach Ende der Bewertungs-Phase angezeigt werden?
|
||||
|
||||
|
||||
CourseNoAllocationsAvailable: Es sind aktuell keine Zentralanmeldungen verfügbar
|
||||
AllocationStaffRegisterToExpired: Es dürfen keine Änderungen an der Eintragung des Kurses zur Zentralanmeldung mehr vorgenommen werden
|
||||
|
||||
|
||||
CourseFormSectionRegistration: Anmeldung
|
||||
CourseFormSectionAdministration: Verwaltung
|
||||
|
||||
CourseLecturers: Kursverwalter
|
||||
CourseLecturer: Dozent
|
||||
|
||||
@ -22,7 +22,7 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis
|
||||
registerByStaffFrom UTCTime Maybe -- lecturers may directly enrol/disenrol students after a given date or prohibited
|
||||
registerByStaffTo UTCTime Maybe
|
||||
registerByCourse UTCTime Maybe -- course registration dates are ignored until this day has passed or always prohibited
|
||||
overrideDeregister UTCTime Maybe -- course deregistration enforced to be this date, i.e. students may disenrol from course before or never
|
||||
overrideDeregister UTCTime Maybe -- course deregistration enforced to be this date, i.e. students may disenrol from course after or never
|
||||
-- overrideVisible not needed, since courses are always visible
|
||||
TermSchoolAllocationShort term school shorthand -- shorthand must be unique within school and semester
|
||||
TermSchoolAllocationName term school name -- name must be unique within school and semester
|
||||
@ -30,37 +30,42 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis
|
||||
AllocationCourse
|
||||
allocation AllocationId
|
||||
course CourseId
|
||||
minCapacity Int -- if the course would get assigned fewer than this many applicants, restart the assignment process without the course
|
||||
instructions Html Maybe -- instructions from the lecturer to applicants
|
||||
applicationText Bool -- lecturer will read application texts supplied by users
|
||||
applicationFiles UploadMode -- lecturer wants to receive course specific application files
|
||||
ratingsVisible Bool -- lecturer wants applicants to receive feedback on their application (Grade & comment)
|
||||
UniqueAllocationCourse allocation course
|
||||
UniqueAllocationCourse course
|
||||
|
||||
AllocationCourseFile
|
||||
allocation AllocationId
|
||||
course CourseId
|
||||
allocationCourse AllocationCourseId
|
||||
file FileId
|
||||
UniqueAllocationCourseFile allocationCourse file
|
||||
|
||||
AllocationUserCourse
|
||||
AllocationUser
|
||||
allocation AllocationId
|
||||
user UserId
|
||||
course CourseId
|
||||
totalCourses Natural -- number of total allocated courses for this user must be <= than this number
|
||||
UniqueAllocationUser allocation user
|
||||
|
||||
AllocationApplication
|
||||
allocationCourse AllocationCourseId
|
||||
allocationUser AllocationUserId
|
||||
text Text Maybe -- free text entered by user
|
||||
priority Natural -- priority, higher number means higher priority
|
||||
totalCourses Natural -- number of total allocated courses for this user must be <= than this number, if this course is part of that allocation
|
||||
ratingVeto Bool
|
||||
ratingPoints ExamGrade Maybe
|
||||
ratingComment Text Maybe
|
||||
UniqueAllocationUserCourse allocation user course
|
||||
UniqueAllocationApplication allocationCourse allocationUser
|
||||
|
||||
AllocationUserFile -- supplemental file for application by a user for a certain course, not unique
|
||||
allocation AllocationId
|
||||
user UserId
|
||||
course CourseId
|
||||
file FileId
|
||||
AllocationApplicationFile -- supplemental file for application by a user for a certain course
|
||||
application AllocationApplicationId
|
||||
file FileId
|
||||
UniqueAllocationUserFile application file
|
||||
|
||||
AllocationDeregister -- self-inflicted user-deregistrations from an allocated course
|
||||
user UserId
|
||||
allocation AllocationId
|
||||
course CourseId
|
||||
allocation AllocationId Maybe
|
||||
course CourseId Maybe
|
||||
time UTCTime
|
||||
reason Text Maybe -- if this deregistration was done by proxy (e.g. the lecturer pressed the button)
|
||||
|
||||
@ -45,6 +45,7 @@ decCryptoIDs [ ''SubmissionId
|
||||
, ''StudyFeaturesId
|
||||
, ''ExamOccurrenceId
|
||||
, ''ExamPartId
|
||||
, ''AllocationId
|
||||
]
|
||||
|
||||
instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where
|
||||
|
||||
@ -18,32 +18,49 @@ 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
|
||||
, cfDesc :: Maybe Html
|
||||
, cfLink :: Maybe Text
|
||||
, cfShort :: CourseShorthand
|
||||
, cfTerm :: TermId
|
||||
, cfSchool :: SchoolId
|
||||
, cfCapacity :: Maybe Int
|
||||
, cfSecret :: Maybe Text
|
||||
, cfMatFree :: Bool
|
||||
, cfRegFrom :: Maybe UTCTime
|
||||
, cfRegTo :: Maybe UTCTime
|
||||
, cfDeRegUntil :: Maybe UTCTime
|
||||
, cfLecturers :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
|
||||
{ cfCourseId :: Maybe CourseId
|
||||
, cfName :: CourseName
|
||||
, cfShort :: CourseShorthand
|
||||
, cfSchool :: SchoolId
|
||||
, cfTerm :: TermId
|
||||
, cfDesc :: Maybe Html
|
||||
, cfLink :: Maybe Text
|
||||
, cfMatFree :: Bool
|
||||
, cfAllocation :: Maybe AllocationCourseForm
|
||||
, cfCapacity :: Maybe Int
|
||||
, cfSecret :: Maybe Text
|
||||
, cfRegFrom :: Maybe UTCTime
|
||||
, cfRegTo :: Maybe UTCTime
|
||||
, cfDeRegUntil :: Maybe UTCTime
|
||||
, cfLecturers :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
|
||||
}
|
||||
|
||||
courseToForm :: Entity Course -> [Lecturer] -> [(UserEmail, InvitationDBData Lecturer)] -> CourseForm
|
||||
courseToForm (Entity cid Course{..}) lecs lecInvites = CourseForm
|
||||
data AllocationCourseForm = AllocationCourseForm
|
||||
{ acfAllocation :: AllocationId
|
||||
, acfMinCapacity :: Int
|
||||
, acfInstructions :: Maybe Html
|
||||
, acfFiles :: Maybe (Source Handler (Either FileId File))
|
||||
, acfApplicationText :: Bool
|
||||
, acfApplicationFiles :: UploadMode
|
||||
, acfApplicationRatingsVisible :: Bool
|
||||
}
|
||||
|
||||
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
|
||||
@ -57,10 +74,22 @@ courseToForm (Entity cid Course{..}) lecs lecInvites = CourseForm
|
||||
, cfRegFrom = courseRegisterFrom
|
||||
, cfRegTo = courseRegisterTo
|
||||
, cfDeRegUntil = courseDeregisterUntil
|
||||
, cfAllocation = allocationCourseToForm <$> alloc
|
||||
, cfLecturers = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs]
|
||||
++ [Left (email, mType) | (email, InvDBDataLecturer mType) <- lecInvites ]
|
||||
}
|
||||
|
||||
allocationCourseToForm :: Entity AllocationCourse -> AllocationCourseForm
|
||||
allocationCourseToForm (Entity _ AllocationCourse{..}) = AllocationCourseForm
|
||||
{ acfAllocation = allocationCourseAllocation
|
||||
, acfMinCapacity = allocationCourseMinCapacity
|
||||
, acfInstructions = allocationCourseInstructions
|
||||
, acfFiles = Nothing
|
||||
, acfApplicationText = allocationCourseApplicationText
|
||||
, acfApplicationFiles = allocationCourseApplicationFiles
|
||||
, acfApplicationRatingsVisible = allocationCourseRatingsVisible
|
||||
}
|
||||
|
||||
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
|
||||
@ -159,29 +188,76 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
|
||||
, (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
|
||||
|
||||
oldFileIds <- for ((,) <$> (fmap acfAllocation $ template >>= cfAllocation) <*> (template >>= cfCourseId)) $ \(allId, cId) -> fmap (Set.fromList . map E.unValue) . liftHandlerT . runDB . E.select . E.from $ \(allocationCourseFile `E.InnerJoin` allocationCourse) -> do
|
||||
E.on $ allocationCourseFile E.^. AllocationCourseFileAllocationCourse E.==. allocationCourse E.^. AllocationCourseId
|
||||
E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. E.val cId
|
||||
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val allId
|
||||
return $ allocationCourseFile E.^. AllocationCourseFileFile
|
||||
|
||||
|
||||
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)
|
||||
<*> (assertM (not . null . renderHtml) <$> aopt htmlField (fslI MsgCourseAllocationInstructions & setTooltip MsgCourseAllocationInstructionsTip) (fmap acfInstructions $ template >>= cfAllocation))
|
||||
<*> aopt (multiFileField . return $ fromMaybe Set.empty oldFileIds) (fslI MsgCourseAllocationApplicationTemplate) (fmap acfFiles $ template >>= cfAllocation)
|
||||
<*> apopt checkBoxField (fslI MsgCourseAllocationApplicationText & setTooltip MsgCourseAllocationApplicationTextTip) (fmap acfApplicationText $ template >>= cfAllocation)
|
||||
<*> uploadModeForm (fmap acfApplicationFiles $ template >>= cfAllocation)
|
||||
<*> apopt checkBoxField (fslI MsgCourseAllocationApplicationRatingsVisible & setTooltip MsgCourseAllocationApplicationRatingsVisibleTip) (fmap acfApplicationRatingsVisible $ 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)
|
||||
<*> areq ciField (fslI MsgCourseShorthand
|
||||
-- & addAttr "disabled" "disabled"
|
||||
& setTooltip MsgCourseShorthandUnique) (cfShort <$> template)
|
||||
<*> areq termsField (fslI MsgCourseSemester) (cfTerm <$> template)
|
||||
<*> areq (schoolFieldFor userSchools) (fslI MsgCourseSchool) (cfSchool <$> template)
|
||||
<*> apopt checkBoxField (fslI MsgMaterialFree) (cfMatFree <$> template)
|
||||
<* aformSection MsgCourseFormSectionRegistration
|
||||
<*> allocationForm
|
||||
<*> aopt (natFieldI MsgCourseCapacity) (fslI MsgCourseCapacity
|
||||
& setTooltip MsgCourseCapacityTip) (cfCapacity <$> template)
|
||||
<*> aopt textField (fslpI MsgCourseSecret (mr MsgCourseSecretFormat)
|
||||
& setTooltip MsgCourseSecretTip) (cfSecret <$> template)
|
||||
<*> areq checkBoxField (fslI MsgMaterialFree) (cfMatFree <$> 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
|
||||
@ -269,7 +345,7 @@ getCourseNewR = do
|
||||
return course
|
||||
template <- case listToMaybe oldCourses of
|
||||
(Just oldTemplate) ->
|
||||
let newTemplate = courseToForm oldTemplate [] [] in
|
||||
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
|
||||
@ -302,10 +378,11 @@ pgCEditR tid ssh csh = do
|
||||
mbCourse <- getBy (TermSchoolCourseShort tid ssh csh)
|
||||
mbLecs <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
|
||||
mbLecInvites <- for mbCourse $ sourceInvitationsList . entityKey
|
||||
return $ (,,) <$> mbCourse <*> mbLecs <*> mbLecInvites
|
||||
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 3) courseToForm <$> courseData
|
||||
courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ $(uncurryN 4) courseToForm <$> courseData
|
||||
|
||||
|
||||
-- | Course Creation and Editing
|
||||
@ -343,6 +420,7 @@ courseEditHandler miButtonAction mbCourseForm = do
|
||||
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
|
||||
@ -388,6 +466,7 @@ courseEditHandler miButtonAction mbCourseForm = do
|
||||
sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
|
||||
|
||||
insert_ $ CourseEdit aid now cid
|
||||
upsertAllocationCourse cid $ cfAllocation res
|
||||
addMessageI Success $ MsgCourseEditOk tid ssh csh
|
||||
return True
|
||||
when success $ redirect $ CourseR tid ssh csh CShowR
|
||||
@ -398,3 +477,53 @@ courseEditHandler miButtonAction mbCourseForm = do
|
||||
{ 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
|
||||
prevAllocationCourse <- getBy $ UniqueAllocationCourse cid
|
||||
prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse
|
||||
|
||||
if -- TODO: loophole for admins
|
||||
| Just Allocation{allocationStaffRegisterTo} <- prevAllocation
|
||||
, NTop allocationStaffRegisterTo <= NTop (Just now)
|
||||
-> permissionDeniedI MsgAllocationStaffRegisterToExpired
|
||||
| otherwise
|
||||
-> return ()
|
||||
|
||||
case cfAllocation of
|
||||
Just AllocationCourseForm{..} -> do
|
||||
Entity acId _ <- upsert AllocationCourse
|
||||
{ allocationCourseAllocation = acfAllocation
|
||||
, allocationCourseCourse = cid
|
||||
, allocationCourseMinCapacity = acfMinCapacity
|
||||
, allocationCourseInstructions = acfInstructions
|
||||
, allocationCourseApplicationText = acfApplicationText
|
||||
, allocationCourseApplicationFiles = acfApplicationFiles
|
||||
, allocationCourseRatingsVisible = acfApplicationRatingsVisible
|
||||
}
|
||||
[ AllocationCourseAllocation =. acfAllocation
|
||||
, AllocationCourseCourse =. cid
|
||||
, AllocationCourseMinCapacity =. acfMinCapacity
|
||||
, AllocationCourseInstructions =. acfInstructions
|
||||
, AllocationCourseApplicationText =. acfApplicationText
|
||||
, AllocationCourseApplicationFiles =. acfApplicationFiles
|
||||
, AllocationCourseRatingsVisible =. acfApplicationRatingsVisible
|
||||
]
|
||||
|
||||
let
|
||||
finsert val = do
|
||||
fId <- lift $ either return insert val
|
||||
tell $ Set.singleton fId
|
||||
lift $
|
||||
void . insertUnique $ AllocationCourseFile acId fId
|
||||
keep <- execWriterT . runConduit $ transPipe liftHandlerT (traverse_ id acfFiles) .| C.mapM_ finsert
|
||||
acfs <- selectList [ AllocationCourseFileAllocationCourse ==. acId, AllocationCourseFileFile /<-. Set.toList keep ] []
|
||||
mapM_ deleteCascade $ map (allocationCourseFileFile . entityVal) acfs
|
||||
Nothing
|
||||
| Just (Entity prevId _) <- prevAllocationCourse
|
||||
-> do
|
||||
acfs <- selectList [ AllocationCourseFileAllocationCourse ==. prevId ] []
|
||||
mapM_ deleteCascade $ map (allocationCourseFileFile . entityVal) acfs
|
||||
delete prevId
|
||||
_other -> return ()
|
||||
|
||||
@ -36,6 +36,7 @@ instance IsInvitableJunction CourseParticipant where
|
||||
data InvitableJunction CourseParticipant = JunctionParticipant
|
||||
{ jParticipantRegistration :: UTCTime
|
||||
, jParticipantField :: Maybe StudyFeaturesId
|
||||
, jParticipantAllocated :: Bool
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
data InvitationDBData CourseParticipant = InvDBDataParticipant
|
||||
-- no data needed in DB to manage participant invitation
|
||||
@ -44,8 +45,8 @@ instance IsInvitableJunction CourseParticipant where
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
_InvitableJunction = iso
|
||||
(\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField))
|
||||
(\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField) -> CourseParticipant{..})
|
||||
(\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField courseParticipantAllocated))
|
||||
(\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField courseParticipantAllocated) -> CourseParticipant{..})
|
||||
|
||||
instance ToJSON (InvitableJunction CourseParticipant) where
|
||||
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
@ -83,7 +84,7 @@ participantInvitationConfig = InvitationConfig{..}
|
||||
now <- liftIO getCurrentTime
|
||||
studyFeatures <- wreq (studyFeaturesPrimaryFieldFor False [] $ Just uid)
|
||||
(fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTooltip) Nothing
|
||||
return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures
|
||||
return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure False
|
||||
invitationInsertHook _ _ _ _ = id
|
||||
invitationSuccessMsg (Entity _ Course{..}) _ =
|
||||
return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName)
|
||||
@ -161,6 +162,7 @@ postCAddUserR tid ssh csh = do
|
||||
void . lift . lift . insert $ CourseParticipant
|
||||
{ courseParticipantCourse = cid
|
||||
, courseParticipantUser = uid
|
||||
, courseParticipantAllocated = False
|
||||
, ..
|
||||
}
|
||||
|
||||
|
||||
@ -89,7 +89,7 @@ postCRegisterR tid ssh csh = do
|
||||
addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk
|
||||
| codeOk -> do
|
||||
actTime <- liftIO getCurrentTime
|
||||
regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime mbSfId
|
||||
regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime mbSfId False
|
||||
when (isJust regOk) $ addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
|
||||
| otherwise -> addMessageI Warning MsgCourseSecretWrong
|
||||
-- addMessage Info $ toHtml $ show regResult -- For debugging only
|
||||
|
||||
@ -145,7 +145,7 @@ postCUserR tid ssh csh uCId = do
|
||||
= Just featId
|
||||
| otherwise
|
||||
= Nothing
|
||||
pId <- runDB . insertUnique $ CourseParticipant cid uid now primaryField
|
||||
pId <- runDB . insertUnique $ CourseParticipant cid uid now primaryField False
|
||||
case pId of
|
||||
Just _ -> do
|
||||
addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
|
||||
|
||||
@ -144,6 +144,7 @@ postEAddUserR tid ssh csh examn = do
|
||||
{ courseParticipantCourse = cid
|
||||
, courseParticipantUser = uid
|
||||
, courseParticipantRegistration = now
|
||||
, courseParticipantAllocated = False
|
||||
, ..
|
||||
}
|
||||
lift $ lift examRegister
|
||||
|
||||
@ -94,8 +94,8 @@ examRegistrationInvitationConfig = InvitationConfig{..}
|
||||
return $ (JunctionExamRegistration invDBExamRegistrationOccurrence now, ) . Just <$> fieldRes
|
||||
(True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing)
|
||||
invitationInsertHook (Entity _ Exam{..}) _ ExamRegistration{..} mField act = do
|
||||
whenIsJust mField $
|
||||
insert_ . CourseParticipant examCourse examRegistrationUser examRegistrationTime
|
||||
whenIsJust mField $ \cpField ->
|
||||
insert_ $ CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField False
|
||||
|
||||
Course{..} <- get404 examCourse
|
||||
User{..} <- get404 examRegistrationUser
|
||||
|
||||
@ -441,6 +441,7 @@ postEUsersR tid ssh csh examn = do
|
||||
, courseParticipantUser = examUserCsvActUser
|
||||
, courseParticipantRegistration = now
|
||||
, courseParticipantField = examUserCsvActCourseField
|
||||
, courseParticipantAllocated = False
|
||||
}
|
||||
User{userIdent} <- getJust examUserCsvActUser
|
||||
audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent
|
||||
|
||||
@ -169,9 +169,34 @@ linkButton defWdgt lbl cls url = do
|
||||
-- Interactive fieldset --
|
||||
--------------------------
|
||||
|
||||
optionalAction :: AForm Handler a
|
||||
-> FieldSettings UniWorX
|
||||
-> Maybe Bool
|
||||
-> (Html -> MForm Handler (FormResult (Maybe a), [FieldView UniWorX]))
|
||||
optionalAction justAct fs@FieldSettings{..} defActive csrf = do
|
||||
(doRes, doView) <- mpopt checkBoxField fs defActive
|
||||
(actionRes, actionViews') <- over _2 ($ []) <$> aFormToForm justAct
|
||||
|
||||
let actionViews = over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/optional-action")) actionViews'
|
||||
|
||||
return (doRes >>= bool (pure Nothing) (Just <$> actionRes), over _fvInput (mappend $ toWidget csrf) doView : actionViews)
|
||||
|
||||
optionalActionA :: AForm Handler a
|
||||
-> FieldSettings UniWorX
|
||||
-> Maybe Bool
|
||||
-> AForm Handler (Maybe a)
|
||||
optionalActionA justAct fs defActive = formToAForm $ optionalAction justAct fs defActive mempty
|
||||
|
||||
optionalActionW :: AForm Handler a
|
||||
-> FieldSettings UniWorX
|
||||
-> Maybe Bool
|
||||
-> WForm Handler (FormResult (Maybe a))
|
||||
optionalActionW justAct fs defAction = aFormToWForm $ optionalActionA justAct fs defAction
|
||||
|
||||
|
||||
multiAction :: forall action a.
|
||||
( RenderMessage UniWorX action, PathPiece action, Ord action, Eq action )
|
||||
=> Map action (AForm (HandlerT UniWorX IO) a)
|
||||
=> Map action (AForm Handler a)
|
||||
-> FieldSettings UniWorX
|
||||
-> Maybe action
|
||||
-> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
|
||||
|
||||
@ -18,6 +18,8 @@ import Control.Lens hiding (universe)
|
||||
import Utils.Lens.TH
|
||||
|
||||
import qualified Data.Csv as Csv
|
||||
|
||||
import Database.Persist.Sql
|
||||
|
||||
|
||||
data ExamResult' res = ExamAttended { examResult :: res }
|
||||
@ -170,6 +172,14 @@ instance Csv.FromField ExamGrade where
|
||||
parseField x = (parse =<< Csv.parseField x) <|> (parse . Text.replace "," "." =<< Csv.parseField x) -- Ugh.
|
||||
where parse = maybe (fail "Could not decode PathPiece") return . fromPathPiece
|
||||
|
||||
instance PersistField ExamGrade where
|
||||
toPersistValue = PersistRational . review numberGrade
|
||||
fromPersistValue = maybe (Left "Could not decode Rational to ExamGrade") Right . preview numberGrade <=< fromPersistValue
|
||||
|
||||
instance PersistFieldSql ExamGrade where
|
||||
sqlType _ = SqlNumeric 2 1
|
||||
|
||||
|
||||
data ExamGradingRule
|
||||
= ExamGradingManual
|
||||
| ExamGradingKey
|
||||
@ -186,7 +196,7 @@ derivePersistFieldJSON ''ExamGradingRule
|
||||
|
||||
newtype ExamPassed = ExamPassed { examPassed :: Bool }
|
||||
deriving (Read, Show, Generic, Typeable)
|
||||
deriving newtype (Eq, Ord, Enum, Bounded)
|
||||
deriving newtype (Eq, Ord, Enum, Bounded, PersistField, PersistFieldSql)
|
||||
|
||||
deriveFinite ''ExamPassed
|
||||
finitePathPiece ''ExamPassed ["failed", "passed"]
|
||||
|
||||
@ -621,6 +621,46 @@ checkMap :: (Monad m, RenderMessage (HandlerSite m) msg) => (a -> Either msg b)
|
||||
checkMap f = checkMMap (return . f)
|
||||
|
||||
|
||||
selectField' :: ( Eq a
|
||||
, RenderMessage (HandlerSite m) FormMessage
|
||||
, MonadHandler m
|
||||
)
|
||||
=> Maybe (SomeMessage (HandlerSite m)) -- ^ Caption used for @Nothing@-Option, if Field is optional and whether to show such an option
|
||||
-> HandlerT (HandlerSite m) IO (OptionList a)
|
||||
-> Field m a
|
||||
-- ^ Like @selectField@, but with more control over the @Nothing@-Option, if Field is optional
|
||||
selectField' optMsg mkOpts = Field{..}
|
||||
where
|
||||
fieldEnctype = UrlEncoded
|
||||
|
||||
fieldParse [] _ = return $ Right Nothing
|
||||
fieldParse (s:_) _
|
||||
| s == "" = return $ Right Nothing
|
||||
| otherwise = do
|
||||
OptionList{olReadExternal} <- liftHandlerT mkOpts
|
||||
return . maybe (Left . SomeMessage $ MsgInvalidEntry s) (Right . Just) $ olReadExternal s
|
||||
|
||||
fieldView theId name attrs val isReq = do
|
||||
OptionList{olOptions} <- liftHandlerT mkOpts
|
||||
let
|
||||
rendered = case val of
|
||||
Left _ -> ""
|
||||
Right a -> maybe "" optionExternalValue . listToMaybe $ filter ((== a) . optionInternalValue) olOptions
|
||||
|
||||
isSel Nothing = not $ rendered `elem` map optionExternalValue olOptions
|
||||
isSel (Just opt) = rendered == optionExternalValue opt
|
||||
[whamlet|
|
||||
$newline never
|
||||
<select ##{theId} name=#{name} *{attrs} :isReq:required>
|
||||
$maybe optMsg' <- assertM (const $ not isReq) optMsg
|
||||
<option value="" :isSel Nothing:selected>
|
||||
_{optMsg'}
|
||||
$forall opt <- olOptions
|
||||
<option value=#{optionExternalValue opt} :isSel (Just opt):selected>
|
||||
#{optionDisplay opt}
|
||||
|]
|
||||
|
||||
|
||||
-----------
|
||||
-- Forms --
|
||||
-----------
|
||||
@ -951,6 +991,10 @@ aforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m
|
||||
=> Field m a -> FieldSettings site -> a -> AForm m a
|
||||
aforced field settings val = formToAForm $ over _2 pure <$> mforced field settings val
|
||||
|
||||
wforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
|
||||
=> Field m a -> FieldSettings site -> a -> WForm m (FormResult a)
|
||||
wforced field settings val = mFormToWForm $ mforced field settings val
|
||||
|
||||
mpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
|
||||
=> Field m a -> FieldSettings site -> Maybe a -> MForm m (FormResult a, FieldView site)
|
||||
-- ^ Pseudo required
|
||||
|
||||
4
templates/widgets/multi-action/optional-action.hamlet
Normal file
4
templates/widgets/multi-action/optional-action.hamlet
Normal file
@ -0,0 +1,4 @@
|
||||
<fieldset uw-interactive-fieldset data-conditional-input=#{fvId doView}>
|
||||
<legend>
|
||||
_{fsLabel}
|
||||
^{w}
|
||||
@ -432,7 +432,7 @@ fillDb = do
|
||||
insert_ $ SheetEdit gkleen now feste
|
||||
keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ UploadAny True Nothing) False
|
||||
insert_ $ SheetEdit gkleen now keine
|
||||
void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf)
|
||||
void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf False)
|
||||
[(fhamann , Nothing)
|
||||
,(maxMuster , Just sfMMs)
|
||||
,(tinaTester, Just sfTTc)
|
||||
@ -510,7 +510,7 @@ fillDb = do
|
||||
insert_ $ CourseEdit jost now pmo
|
||||
void . insert $ DegreeCourse pmo sdBsc sdInf
|
||||
void . insert $ Lecturer jost pmo CourseAssistant
|
||||
void . insertMany $ map (\(u,sf) -> CourseParticipant pmo u now sf)
|
||||
void . insertMany $ map (\(u,sf) -> CourseParticipant pmo u now sf False)
|
||||
[(fhamann , Nothing)
|
||||
,(maxMuster , Just sfMMp)
|
||||
,(tinaTester, Just sfTTb)
|
||||
|
||||
@ -25,6 +25,8 @@ import Time.Types (WeekDay(..))
|
||||
|
||||
import qualified Net.IP as IP
|
||||
|
||||
import Web.PathPieces
|
||||
|
||||
|
||||
instance (Arbitrary a, MonoFoldable a) => Arbitrary (NonNull a) where
|
||||
arbitrary = arbitrary `suchThatMap` fromNullable
|
||||
@ -215,6 +217,35 @@ instance Arbitrary Occurrences where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary res => Arbitrary (ExamResult' res) where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary ExamBonusRule where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary ExamOccurrenceRule where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary ExamGrade where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary ExamGradingRule where
|
||||
arbitrary = oneof
|
||||
[ pure ExamGradingManual
|
||||
, ExamGradingKey . reverse . fromOffsets . map getNonNegative <$> replicateM 11 arbitrary
|
||||
]
|
||||
where
|
||||
fromOffsets [] = []
|
||||
fromOffsets (x:xs) = x + sum xs : fromOffsets xs
|
||||
|
||||
instance Arbitrary ExamPassed where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
@ -265,6 +296,8 @@ spec = do
|
||||
[ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
|
||||
lawsCheckHspec (Proxy @Value)
|
||||
[ persistFieldLaws ]
|
||||
lawsCheckHspec (Proxy @Points)
|
||||
[ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws, csvFieldLaws ]
|
||||
lawsCheckHspec (Proxy @NotificationTrigger)
|
||||
[ eqLaws, ordLaws, showReadLaws, jsonLaws, boundedEnumLaws, finiteLaws, hashableLaws, jsonLaws, jsonKeyLaws ]
|
||||
lawsCheckHspec (Proxy @NotificationSettings)
|
||||
@ -278,7 +311,23 @@ spec = do
|
||||
lawsCheckHspec (Proxy @LecturerType)
|
||||
[ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, jsonLaws, pathPieceLaws, persistFieldLaws ]
|
||||
lawsCheckHspec (Proxy @IP)
|
||||
[ eqLaws, ordLaws, showReadLaws, jsonLaws ]
|
||||
[ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
|
||||
lawsCheckHspec (Proxy @ExamResultPoints)
|
||||
[ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws, csvFieldLaws ]
|
||||
lawsCheckHspec (Proxy @ExamResultGrade)
|
||||
[ eqLaws, ordLaws, showReadLaws, finiteLaws, jsonLaws, pathPieceLaws, persistFieldLaws, csvFieldLaws ]
|
||||
lawsCheckHspec (Proxy @ExamResultPassed)
|
||||
[ eqLaws, ordLaws, showReadLaws, finiteLaws, jsonLaws, pathPieceLaws, persistFieldLaws, csvFieldLaws ]
|
||||
lawsCheckHspec (Proxy @ExamBonusRule)
|
||||
[ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
|
||||
lawsCheckHspec (Proxy @ExamOccurrenceRule)
|
||||
[ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
|
||||
lawsCheckHspec (Proxy @ExamGrade)
|
||||
[ eqLaws, ordLaws, showReadLaws, finiteLaws, jsonLaws, pathPieceLaws, persistFieldLaws, csvFieldLaws ]
|
||||
lawsCheckHspec (Proxy @ExamGradingRule)
|
||||
[ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
|
||||
lawsCheckHspec (Proxy @ExamPassed)
|
||||
[ eqLaws, ordLaws, showReadLaws, finiteLaws, jsonLaws, pathPieceLaws, persistFieldLaws, csvFieldLaws ]
|
||||
|
||||
describe "TermIdentifier" $ do
|
||||
it "has compatible encoding/decoding to/from Text" . property $
|
||||
@ -297,6 +346,10 @@ spec = do
|
||||
\pseudonym -> preview _PseudonymText (review _PseudonymText pseudonym) == Just pseudonym
|
||||
it "encodes to Text injectively" . property $
|
||||
\p1 p2 -> p1 /= p2 ==> ((/=) `on` review _PseudonymText) p1 p2
|
||||
describe "ExamPassed" $
|
||||
it "encodes to PathPiece as expected" . example $ do
|
||||
toPathPiece (ExamPassed False) `shouldBe` pack "failed"
|
||||
toPathPiece (ExamPassed True) `shouldBe` pack "passed"
|
||||
|
||||
termExample :: (TermIdentifier, Text) -> Expectation
|
||||
termExample (term, encoded) = example $ do
|
||||
|
||||
20
test/Test/QuickCheck/Classes/Csv.hs
Normal file
20
test/Test/QuickCheck/Classes/Csv.hs
Normal file
@ -0,0 +1,20 @@
|
||||
module Test.QuickCheck.Classes.Csv
|
||||
( csvRecordLaws
|
||||
, csvFieldLaws
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
import Test.QuickCheck
|
||||
import Test.QuickCheck.Classes
|
||||
import qualified Data.Csv as Csv
|
||||
import Data.Proxy
|
||||
|
||||
csvRecordLaws :: forall a. (Arbitrary a, Csv.ToNamedRecord a, Csv.FromNamedRecord a, Eq a, Show a) => Proxy a -> Laws
|
||||
csvRecordLaws _ = Laws "Csv.NamedRecord"
|
||||
[ ("Partial Isomorphism", property $ \(a :: a) -> Csv.runParser (Csv.parseNamedRecord $ Csv.toNamedRecord a) == Right a)
|
||||
]
|
||||
|
||||
csvFieldLaws :: forall a. (Arbitrary a, Csv.ToField a, Csv.FromField a, Eq a, Show a) => Proxy a -> Laws
|
||||
csvFieldLaws _ = Laws "Csv.Field"
|
||||
[ ("Partial Isomorphism", property $ \(a :: a) -> Csv.runParser (Csv.parseField $ Csv.toField a) == Right a)
|
||||
]
|
||||
@ -28,6 +28,7 @@ import Test.QuickCheck.Classes.JSON as X
|
||||
import Test.QuickCheck.Classes.HttpApiData as X
|
||||
import Test.QuickCheck.Classes.Universe as X
|
||||
import Test.QuickCheck.Classes.Binary as X
|
||||
import Test.QuickCheck.Classes.Csv as X
|
||||
import Data.Proxy as X
|
||||
import Data.UUID as X (UUID)
|
||||
import System.IO as X (hPrint, hPutStrLn, stderr)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user