diff --git a/frontend/src/services/util-registry/util-registry.js b/frontend/src/services/util-registry/util-registry.js index d96d7a4b3..c6e866adf 100644 --- a/frontend/src/services/util-registry/util-registry.js +++ b/frontend/src/services/util-registry/util-registry.js @@ -1,4 +1,4 @@ -const DEBUG_MODE = /localhost/.test(window.location.href) && 0; +const DEBUG_MODE = /localhost/.test(window.location.href) ? 2 : 0; export class UtilRegistry { diff --git a/frontend/src/utils/form/interactive-fieldset.js b/frontend/src/utils/form/interactive-fieldset.js index 4155a81c9..9c080e04f 100644 --- a/frontend/src/utils/form/interactive-fieldset.js +++ b/frontend/src/utils/form/interactive-fieldset.js @@ -44,7 +44,7 @@ export class InteractiveFieldset { } // param conditionalValue - if (!this._element.dataset.conditionalValue && !this._isCheckbox()) { + if (!('conditionalValue' in this._element.dataset) && !this._isCheckbox()) { throw new Error('Interactive Fieldset needs a conditional value!'); } this.conditionalValue = this._element.dataset.conditionalValue; diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 871c909ca..0d12afe08 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -332,7 +332,7 @@ MaterialArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand materialName@Mat Unauthorized: Sie haben hierfür keine explizite Berechtigung. UnauthorizedAnd l@Text r@Text: (#{l} UND #{r}) UnauthorizedOr l@Text r@Text: (#{l} ODER #{r}) -UnauthorizedNot i@Text: (NICHT #{i}) +UnauthorizedNot r@Text: (NICHT #{r}) UnauthorizedNoToken: Ihrer Anfrage war kein Authorisierungs-Token beigefügt. UnauthorizedTokenExpired: Ihr Authorisierungs-Token ist abgelaufen. UnauthorizedTokenNotStarted: Ihr Authorisierungs-Token ist noch nicht gültig. @@ -1473,4 +1473,18 @@ BtnAllocationRegister: Teilnahme registrieren BtnAllocationRegistrationEdit: Teilnahme anpassen AllocationParticipation: Teilnahme an der Zentralanmeldung AllocationCourses: Kurse -AllocationData: Organisatorisches \ No newline at end of file +AllocationData: Organisatorisches +AllocationCoursePriority i@Natural: #{i}. Wahl +AllocationCourseNoApplication: Keine Bewerbung +BtnAllocationApply: Bewerben +BtnAllocationApplicationEdit: Bewerbung ersetzen +BtnAllocationApplicationRetract: Bewerbung zurückziehen +BtnAllocationApplicationRate: Bewerbung bewerten +ApplicationPriority: Priorität +ApplicationVeto: Veto +ApplicationVetoTip: Bewerber mit Veto werden garantiert nicht dem Kurs zugeteilt +ApplicationRatingPoints: Bewertung +ApplicationRatingPointsTip: Bewerber mit 5.0 werden garantiert nicht dem Kurs zugeteilt +ApplicationRatingComment: Kommentar +ApplicationRatingCommentVisibleTip: Feedback an den Bewerbers +ApplicationRatingCommentInvisibleTip: Dient zunächst nur als Notiz für Kursverwalter \ No newline at end of file diff --git a/models/courses b/models/courses index bcbdf4979..dd1099e55 100644 --- a/models/courses +++ b/models/courses @@ -76,11 +76,13 @@ CourseApplication user UserId field StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades text Text Maybe -- free text entered by user + ratingVeto Bool default=false ratingPoints ExamGrade Maybe ratingComment Text Maybe allocation AllocationId Maybe allocationPriority Natural Maybe time UTCTime default=now() + ratingTime UTCTime Maybe CourseApplicationFile application CourseApplicationId file FileId diff --git a/routes b/routes index ac009ecc1..cec9b58f7 100644 --- a/routes +++ b/routes @@ -81,10 +81,10 @@ /school/#SchoolId SchoolShowR GET !development /allocation/#TermId/#SchoolId/#AllocationShorthand AllocationR: - / AShowR GET !free - /register ARegisterR POST !time - /course/#CryptoUUIDCourse/apply AApplyR POST !timeANDallocation-registered - /application/#CryptoFileNameCourseApplication AEditR GET POST !timeANDself !lecturerANDstaff-time + / AShowR GET !free + /register ARegisterR POST !time + /course/#CryptoUUIDCourse/apply AApplyR POST !timeANDallocation-registered + /application/#CryptoFileNameCourseApplication AApplicationR GET POST !timeANDself !lecturerANDstaff-time !selfANDread -- For Pattern Synonyms see Foundation diff --git a/src/Foundation.hs b/src/Foundation.hs index 78b3c0e8b..6b47320ad 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -261,6 +261,8 @@ instance RenderMessage UniWorX Int64 where renderMessage f ls = renderMessage f ls . tshow instance RenderMessage UniWorX Integer where renderMessage f ls = renderMessage f ls . tshow +instance RenderMessage UniWorX Natural where + renderMessage f ls = renderMessage f ls . tshow instance HasResolution a => RenderMessage UniWorX (Fixed a) where renderMessage f ls = renderMessage f ls . showFixed True @@ -371,6 +373,8 @@ instance ToMessage Int64 where toMessage = tshow instance ToMessage Integer where toMessage = tshow +instance ToMessage Natural where + toMessage = tshow instance HasResolution a => ToMessage (Fixed a) where toMessage = toMessage . showFixed True @@ -652,7 +656,7 @@ tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of E.&&. course E.^. CourseShorthand E.==. E.val csh guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedLecturer) return Authorized - AllocationR tid ssh ash (AEditR cID) -> $cachedHereBinary (mAuthId, tid, ssh, ash, cID) . exceptT return return $ do + AllocationR tid ssh ash (AApplicationR cID) -> $cachedHereBinary (mAuthId, tid, ssh, ash, cID) . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId appId <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedLecturer) (const True :: CryptoIDError -> Bool) $ decrypt cID isLecturer <- lift . E.selectExists . E.from $ \(courseApplication `E.InnerJoin` allocation `E.InnerJoin` allocationCourse `E.InnerJoin` course `E.InnerJoin` lecturer) -> do @@ -1733,7 +1737,7 @@ instance YesodBreadcrumbs UniWorX where mr <- getMessageRender Entity _ Allocation{allocationName} <- runDB . getBy404 $ TermSchoolAllocationShort tid ssh ash return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{original (unSchoolKey ssh)})|], Just $ HomeR) - breadcrumb (AllocationR tid ssh ash (AEditR _)) = return ("Bewerbung", Just $ AllocationR tid ssh ash AShowR) + breadcrumb (AllocationR tid ssh ash (AApplicationR _)) = return ("Bewerbung", Just $ AllocationR tid ssh ash AShowR) breadcrumb CourseListR = return ("Kurse" , Nothing) breadcrumb CourseNewR = return ("Neu" , Just CourseListR) diff --git a/src/Handler/Allocation.hs b/src/Handler/Allocation.hs index 5f97daec5..286a87aa1 100644 --- a/src/Handler/Allocation.hs +++ b/src/Handler/Allocation.hs @@ -3,5 +3,5 @@ module Handler.Allocation ) where import Handler.Allocation.Show as Handler.Allocation -import Handler.Allocation.Edit as Handler.Allocation +import Handler.Allocation.Application as Handler.Allocation import Handler.Allocation.Register as Handler.Allocation diff --git a/src/Handler/Allocation/Application.hs b/src/Handler/Allocation/Application.hs new file mode 100644 index 000000000..0b970cb0f --- /dev/null +++ b/src/Handler/Allocation/Application.hs @@ -0,0 +1,223 @@ +module Handler.Allocation.Application + ( AllocationApplicationButton(..) + , ApplicationFormView(..) + , ApplicationForm(..) + , ApplicationFormMode(..) + , ApplicationFormException(..) + , applicationForm + , postAApplyR + , getAApplicationR, postAApplicationR + ) where + +import Import + +import Handler.Utils +import Utils.Lens + +import qualified Data.Text as Text + + +data AllocationApplicationButton = BtnAllocationApply + | BtnAllocationApplicationEdit + | BtnAllocationApplicationRetract + | BtnAllocationApplicationRate + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) +instance Universe AllocationApplicationButton +instance Finite AllocationApplicationButton + +nullaryPathPiece ''AllocationApplicationButton $ camelToPathPiece' 1 +embedRenderMessage ''UniWorX ''AllocationApplicationButton id + +instance Button UniWorX AllocationApplicationButton where + btnClasses BtnAllocationApplicationRetract = [BCIsButton, BCDanger] + btnClasses _ = [BCIsButton, BCPrimary] + + +data ApplicationFormView = ApplicationFormView + { afvPriority :: Maybe (FieldView UniWorX) + , afvForm :: [FieldView UniWorX] + , afvButtons :: ([AllocationApplicationButton], Widget) + } + +data ApplicationForm = ApplicationForm + { afPriority :: Maybe Natural + , afField :: Maybe StudyFeaturesId + , afText :: Maybe Text + , afFiles :: Maybe (Source Handler File) + , afRatingVeto :: Bool + , afRatingPoints :: Maybe ExamGrade + , afRatingComment :: Maybe Text + , afAction :: AllocationApplicationButton + } + +data ApplicationFormMode = ApplicationFormMode + { afmApplicant :: Bool -- ^ Show priority + , afmApplicantEdit :: Bool -- ^ Allow editing text, files, priority (if shown) + , afmLecturer :: Bool -- ^ Allow editing rating + } + +data ApplicationFormException = ApplicationFormNoApplication -- ^ Could not fill forced fields of application form with data from application + deriving (Eq, Ord, Read, Show, Generic, Typeable) +instance Exception ApplicationFormException + +applicationForm :: AllocationId + -> CourseId + -> UserId + -> Natural -- ^ Maximum @courseApplicationAllocationPriority@ among all applications + -> ApplicationFormMode -- ^ Which parts of the shared form to display + -> Html -> MForm Handler (FormResult ApplicationForm, ApplicationFormView) +applicationForm aId cid uid maxPrio ApplicationFormMode{..} csrf = do + (mApp, coursesNum, Course{..}) <- liftHandlerT . runDB $ do + mApplication <- listToMaybe <$> selectList [CourseApplicationAllocation ==. Just aId, CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid] [LimitTo 1] + coursesNum <- fromIntegral <$> count [AllocationCourseAllocation ==. aId] + course <- getJust cid + return (mApplication, coursesNum, course) + MsgRenderer mr <- getMsgRenderer + + let + oldPrio :: Maybe Natural + oldPrio = mApp >>= courseApplicationAllocationPriority . entityVal + + coursesNum' = succ maxPrio `max` pred coursesNum + + mkPrioOption :: Natural -> Option Natural + mkPrioOption i = Option + { optionDisplay = mr . MsgAllocationCoursePriority $ coursesNum' - i + , optionInternalValue = i + , optionExternalValue = tshow i + } + + prioOptions :: OptionList Natural + prioOptions = OptionList + { olOptions = sortOn (Down . optionInternalValue) . map mkPrioOption $ [0 .. coursesNum'] + , olReadExternal = readMay + } + prioField = selectField' (Just $ SomeMessage MsgAllocationCourseNoApplication) $ return prioOptions + + (prioRes, prioView) <- case (afmApplicant, afmApplicantEdit, mApp) of + (True , True , Nothing) + -> over _2 Just <$> mopt prioField (fslI MsgApplicationPriority) (Just $ oldPrio) + (True , True , Just _ ) + -> over (_1 . _FormSuccess) Just . over _2 Just <$> mreq prioField (fslI MsgApplicationPriority) oldPrio + (True , False, _ ) + -> over _2 Just <$> mforcedOpt prioField (fslI MsgApplicationPriority) oldPrio + (False, _ , Just _ ) + | is _Just oldPrio + -> pure (FormSuccess oldPrio, Nothing) + _other + -> throwM ApplicationFormNoApplication + + (fieldRes, fieldView') <- if + | afmApplicantEdit || afmLecturer + -> mreq (studyFeaturesFieldFor Nothing False [] $ Just uid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) (courseApplicationField . entityVal <$> mApp) + | otherwise + -> mforced (studyFeaturesFieldFor Nothing True (maybeToList $ mApp >>= courseApplicationField . entityVal) $ Just uid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) (mApp >>= courseApplicationField . entityVal) + + let textField' = convertField (Text.strip . unTextarea) Textarea textareaField + textFs + | is _Just courseApplicationsInstructions + = fslI MsgCourseApplicationText & setTooltip MsgCourseApplicationFollowInstructions + | otherwise + = fslI MsgCourseApplicationText + (textRes, textView) <- if + | not courseApplicationsText + -> pure (FormSuccess Nothing, Nothing) + | not afmApplicantEdit + -> over _2 Just <$> mforcedOpt textField' textFs (mApp >>= courseApplicationText . entityVal) + | otherwise + -> over _2 Just . over (_1 . _FormSuccess) (assertM $ not . Text.null) <$> mopt textField' textFs (Just $ mApp >>= courseApplicationText . entityVal) + + hasFiles <- for mApp $ \(Entity appId _) + -> fmap (not . null) . liftHandlerT . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ] + appCID <- for mApp $ encrypt . entityKey + let appFilesInfo = (,) <$> hasFiles <*> appCID + + filesLinkView <- if + | fromMaybe False hasFiles || (isn't _NoUpload courseApplicationsFiles && not afmApplicantEdit) + -> let filesLinkField = Field{..} + where + fieldParse _ _ = return $ Right Nothing + fieldEnctype = mempty + fieldView theId _ attrs _ _ + = [whamlet| + $newline never + $case appFilesInfo + $of Just (True, appCID) + + _{MsgCourseApplicationFiles} + $of _ + + _{MsgCourseApplicationNoFiles} + |] + in Just . snd <$> mforced filesLinkField (fslI MsgCourseApplicationFiles) () + | otherwise + -> return Nothing + + (filesRes, filesView) <- + let mkFs = bool MsgCourseApplicationFile MsgCourseApplicationArchive + in if + | not afmApplicantEdit || is _NoUpload courseApplicationsFiles + -> return $ (FormSuccess Nothing, Nothing) + | otherwise + -> fmap (over _2 $ Just . ($ [])) . aFormToForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles + + (vetoRes, vetoView) <- if + | afmLecturer + -> over _2 Just <$> mpopt checkBoxField (fslI MsgApplicationVeto & setTooltip MsgApplicationVetoTip) (Just . fromMaybe False $ courseApplicationRatingVeto . entityVal <$> mApp) + | otherwise + -> return (FormSuccess . fromMaybe False $ courseApplicationRatingVeto . entityVal <$> mApp, Nothing) + + (pointsRes, pointsView) <- if + | afmLecturer + -> over _2 Just <$> mopt examGradeField (fslI MsgApplicationRatingPoints & setTooltip MsgApplicationRatingPointsTip) (fmap Just $ mApp >>= courseApplicationRatingPoints . entityVal) + | otherwise + -> return (FormSuccess $ courseApplicationRatingPoints . entityVal =<< mApp, Nothing) + + (commentRes, commentView) <- if + | afmLecturer + -> over _2 Just . over (_1 . _FormSuccess) (assertM $ not . Text.null) <$> mopt textField' (fslI MsgApplicationRatingComment & setTooltip (bool MsgApplicationRatingCommentInvisibleTip MsgApplicationRatingCommentVisibleTip courseApplicationsRatingsVisible)) (fmap Just $ mApp >>= courseApplicationRatingComment . entityVal) + | otherwise + -> return (FormSuccess $ courseApplicationRatingComment . entityVal =<< mApp, Nothing) + + let + buttons = catMaybes + [ guardOn (not afmApplicantEdit && is _Just mApp) BtnAllocationApplicationRate + , guardOn ( afmApplicantEdit && is _Just mApp) BtnAllocationApplicationEdit + , guardOn ( afmApplicantEdit && is _Nothing mApp) BtnAllocationApply + , guardOn ( afmApplicantEdit && is _Just mApp) BtnAllocationApplicationRetract + ] + (actionRes, buttonsView) <- buttonForm' buttons csrf + + return ( ApplicationForm + <$> prioRes + <*> fieldRes + <*> textRes + <*> filesRes + <*> vetoRes + <*> pointsRes + <*> commentRes + <*> actionRes + , ApplicationFormView + { afvPriority = prioView + , afvForm = catMaybes $ + [ Just fieldView' + , textView + , filesLinkView + ] ++ maybe [] (map Just) filesView ++ + [ vetoView + , pointsView + , commentView + ] + , afvButtons = (buttons, buttonsView) + } + ) + + + + +postAApplyR :: TermId -> SchoolId -> AllocationShorthand -> CryptoUUIDCourse -> Handler Void +postAApplyR = fail "Not implemented" + +getAApplicationR, postAApplicationR :: TermId -> SchoolId -> AllocationShorthand -> CryptoFileNameCourseApplication -> Handler Void +getAApplicationR = postAApplicationR +postAApplicationR = fail "Not implemented" diff --git a/src/Handler/Allocation/Edit.hs b/src/Handler/Allocation/Edit.hs deleted file mode 100644 index d9362babb..000000000 --- a/src/Handler/Allocation/Edit.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Handler.Allocation.Edit - ( postAApplyR - , getAEditR, postAEditR - ) where - -import Import - -postAApplyR :: TermId -> SchoolId -> AllocationShorthand -> CryptoUUIDCourse -> Handler Void -postAApplyR = fail "Not implemented" - -getAEditR, postAEditR :: TermId -> SchoolId -> AllocationShorthand -> CryptoFileNameCourseApplication -> Handler Void -getAEditR = postAEditR -postAEditR = fail "Not implemented" diff --git a/src/Handler/Allocation/Show.hs b/src/Handler/Allocation/Show.hs index f1eba5304..b386021c3 100644 --- a/src/Handler/Allocation/Show.hs +++ b/src/Handler/Allocation/Show.hs @@ -7,6 +7,7 @@ import Handler.Utils import Utils.Lens import Handler.Allocation.Register +import Handler.Allocation.Application import qualified Database.Esqueleto as E @@ -16,12 +17,14 @@ getAShowR tid ssh ash = do muid <- maybeAuthId let - resultCourse :: Lens' (Entity Course, _, _) (Entity Course) + resultCourse :: Simple Field1 a (Entity Course) => Lens' a (Entity Course) resultCourse = _1 - -- resultCourseApplication = _2 + resultCourseApplication :: Simple Field2 a (Maybe (Entity CourseApplication)) => Traversal' a (Entity CourseApplication) + resultCourseApplication = _2 . _Just + resultHasTemplate :: Simple Field3 a (E.Value Bool) => Lens' a Bool resultHasTemplate = _3 . _Value - (Entity _ Allocation{..}, courses, registration) <- runDB $ do + (Entity aId Allocation{..}, courses, registration) <- runDB $ do alloc@(Entity aId _) <- getBy404 $ TermSchoolAllocationShort tid ssh ash courses <- E.select . E.from $ \((allocationCourse `E.InnerJoin` course) `E.LeftOuterJoin` courseApplication) -> do @@ -30,6 +33,7 @@ getAShowR tid ssh ash = do E.&&. courseApplication E.?. CourseApplicationAllocation E.==. E.just (E.just $ E.val aId) E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId E.where_ $ allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId + E.orderBy [E.asc $ course E.^. CourseName] let hasTemplate = E.exists . E.from $ \courseAppInstructionFile -> E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. course E.^. CourseId return (course, courseApplication, hasTemplate) @@ -56,6 +60,8 @@ getAShowR tid ssh ash = do , formSubmit = FormSubmit , formAnchor = Nothing :: Maybe Text } + let + maxPrio = maybe 0 maximum . fromNullable $ courses ^.. folded . resultCourseApplication . _entityVal . _courseApplicationAllocationPriority . _Just siteLayoutMsg title $ do setTitleI shortTitle @@ -63,8 +69,24 @@ getAShowR tid ssh ash = do let courseWidgets = flip map courses $ \cEntry -> do let Entity cid Course{..} = cEntry ^. resultCourse hasApplicationTemplate = cEntry ^. resultHasTemplate + mApp = cEntry ^? resultCourseApplication cID <- encrypt cid :: WidgetT UniWorX IO CryptoUUIDCourse mayApply <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplyR cID - $(widgetFile "allocation/show/course") + isLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR + mApplyFormView <- liftHandlerT . for muid $ \uid -> generateFormPost . applicationForm aId cid uid maxPrio $ ApplicationFormMode True mayApply isLecturer + subRoute <- fmap (fromMaybe $ AApplyR cID) . for mApp $ \(Entity appId _) -> AApplicationR <$> encrypt appId + let mApplyFormView' = view _1 <$> mApplyFormView + case mApplyFormView of + Just (_, appFormEnctype) + -> wrapForm $(widgetFile "allocation/show/course") FormSettings + { formMethod = POST + , formAction = Just . SomeRoute $ AllocationR tid ssh ash subRoute + , formEncoding = appFormEnctype + , formAttrs = [] + , formSubmit = FormNoSubmit + , formAnchor = Nothing :: Maybe Text + } + Nothing + -> $(widgetFile "allocation/show/course") $(widgetFile "allocation/show") diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index 0d42bba87..860835bf3 100644 --- a/src/Handler/Course/Register.hs +++ b/src/Handler/Course/Register.hs @@ -177,7 +177,7 @@ postCRegisterR tid ssh csh = do = void <$> do appIds <- selectKeysList [ CourseApplicationAllocation ==. Nothing, CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] [] appRes <- case appIds of - [] -> insertUnique $ CourseApplication cid uid crfStudyFeatures crfApplicationText Nothing Nothing Nothing Nothing cTime + [] -> insertUnique $ CourseApplication cid uid crfStudyFeatures crfApplicationText False Nothing Nothing Nothing Nothing cTime Nothing (prevId:ps) -> do forM_ ps $ \appId -> do deleteApplicationFiles appId diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index c54ed44b3..a56ebbdd3 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -720,6 +720,18 @@ renderWForm :: (RenderMessage (HandlerSite m) AFormMessage, MonadHandler m) => F (Markup -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ())) renderWForm formLayout = renderAForm formLayout . wFormToAForm +renderFieldViews :: ( RenderMessage site AFormMessage + , RenderMessage site FormMessage + ) + => FormLayout -> [FieldView site] -> WidgetT site IO () +renderFieldViews layout + = join + . fmap (view _1) + . generateFormPost + . lmap (const mempty) + . renderWForm layout + . (FormSuccess () <$) + . lift . tell -- | special id to identify form section headers, see 'aformSection' and 'formSection' -- currently only treated by form generation through 'renderAForm' @@ -997,6 +1009,29 @@ mforced Field{..} FieldSettings{..} val = do } ) +mforcedOpt :: MonadHandler m + => Field m a + -> FieldSettings (HandlerSite m) + -> Maybe a + -> MForm m (FormResult (Maybe a), FieldView (HandlerSite m)) +mforcedOpt Field{..} FieldSettings{..} mVal = do + tell fieldEnctype + name <- maybe newFormIdent return fsName + theId <- lift $ maybe newIdent return fsId + mr <- getMessageRender + let fsAttrs' = fsAttrs <> [("disabled", "")] + return ( FormSuccess mVal + , FieldView + { fvLabel = toHtml $ mr fsLabel + , fvTooltip = toHtml <$> fmap mr fsTooltip + , fvId = theId + , fvInput = fieldView theId name fsAttrs' (maybe (Left "") Right mVal) False + , fvErrors = Nothing + , fvRequired = False + } + ) + + 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 diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 4c015f185..c47836273 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -154,6 +154,8 @@ makePrisms ''AuthenticationMode makeLenses_ ''CourseUserNote +makeLenses_ ''CourseApplication + -- makeClassy_ ''Load diff --git a/templates/allocation/show/course.hamlet b/templates/allocation/show/course.hamlet index 4714f18b5..146844919 100644 --- a/templates/allocation/show/course.hamlet +++ b/templates/allocation/show/course.hamlet @@ -1,8 +1,8 @@
- $if mayApply - Prio $# TODO - $else + $maybe prioView <- mApplyFormView' >>= afvPriority + ^{fvInput prioView} + $nothing _{MsgAllocationNoApplication} #{courseName} @@ -14,6 +14,7 @@

#{iconRegisterTemplate} _{MsgCourseApplicationTemplateApplication} - $if mayApply -

- + $maybe ApplicationFormView{ ..} <- mApplyFormView' +
+ ^{renderFieldViews FormStandard afvForm} + ^{snd afvButtons}