feat(allocations): add application form(s)

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 {
 

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;

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
+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

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

routes

@@ -81,10 +81,10 @@
 /school/#SchoolId          SchoolShowR         GET             !development
 
 /allocation/#TermId/#SchoolId/#AllocationShorthand AllocationR:
-  /                                              AShowR     GET             !free
+  /                                              AShowR         GET             !free
-  /register                                      ARegisterR     POST        !time
+  /register                                      ARegisterR         POST        !time
-  /course/#CryptoUUIDCourse/apply                AApplyR        POST        !timeANDallocation-registered
+  /course/#CryptoUUIDCourse/apply                AApplyR            POST        !timeANDallocation-registered
-  /application/#CryptoFileNameCourseApplication  AEditR     GET POST        !timeANDself !lecturerANDstaff-time
+  /application/#CryptoFileNameCourseApplication  AApplicationR  GET POST        !timeANDself !lecturerANDstaff-time !selfANDread
 
 
 -- For Pattern Synonyms see Foundation

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)

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

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)
+                             <a ##{theId} *{attrs} href=@{CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR}>
+                               _{MsgCourseApplicationFiles}
+                           $of _
+                             <span ##{theId} *{attrs}>
+                               _{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"

src/Handler/Allocation/Edit.hs

@@ -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"

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")

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

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

src/Utils/Lens.hs

@@ -154,6 +154,8 @@ makePrisms ''AuthenticationMode
 
 makeLenses_ ''CourseUserNote
 
+makeLenses_ ''CourseApplication
+
 
 -- makeClassy_ ''Load
 

templates/allocation/show/course.hamlet

@@ -1,8 +1,8 @@
 <div .allocation-course id=#{toPathPiece cID}>
   <div .allocation-course__priority>
-    $if mayApply
+    $maybe prioView <- mApplyFormView' >>= afvPriority
-      Prio $# TODO
+      ^{fvInput prioView}
-    $else
+    $nothing
       _{MsgAllocationNoApplication}
   <a .allocation-course__name href=@{CourseR courseTerm courseSchool courseShorthand CShowR}>
     #{courseName}
@@ -14,6 +14,7 @@
         <p>
           <a href=@{CourseR courseTerm courseSchool courseShorthand CRegisterTemplateR}>
             #{iconRegisterTemplate} _{MsgCourseApplicationTemplateApplication}
-  $if mayApply
+  $maybe ApplicationFormView{ ..} <- mApplyFormView'
-    <div .allocation-course__application uw-interactive-fieldset data-conditional-input="" data-conditional-value="" data-conditional-negated>
+    <div .allocation-course__application uw-interactive-fieldset data-conditional-input=#{maybe "" fvId afvPriority} data-conditional-value="" data-conditional-negated>
-      
+      ^{renderFieldViews FormStandard afvForm}
+      ^{snd afvButtons}