feat(allocations): add application form(s)
This commit is contained in:
Gregor Kleen
parent
c5b18fcfcf
commit
ef625cd901
@ -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 {
|
||||
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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
|
||||
@ -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
|
||||
|
||||
8
routes
8
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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
223
src/Handler/Allocation/Application.hs
Normal file
223
src/Handler/Allocation/Application.hs
Normal file
@ -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"
|
||||
@ -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"
|
||||
@ -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")
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -154,6 +154,8 @@ makePrisms ''AuthenticationMode
|
||||
|
||||
makeLenses_ ''CourseUserNote
|
||||
|
||||
makeLenses_ ''CourseApplication
|
||||
|
||||
|
||||
-- makeClassy_ ''Load
|
||||
|
||||
|
||||
@ -1,8 +1,8 @@
|
||||
<div .allocation-course id=#{toPathPiece cID}>
|
||||
<div .allocation-course__priority>
|
||||
$if mayApply
|
||||
Prio $# TODO
|
||||
$else
|
||||
$maybe prioView <- mApplyFormView' >>= afvPriority
|
||||
^{fvInput prioView}
|
||||
$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
|
||||
<div .allocation-course__application uw-interactive-fieldset data-conditional-input="" data-conditional-value="" data-conditional-negated>
|
||||
|
||||
$maybe ApplicationFormView{ ..} <- mApplyFormView'
|
||||
<div .allocation-course__application uw-interactive-fieldset data-conditional-input=#{maybe "" fvId afvPriority} data-conditional-value="" data-conditional-negated>
|
||||
^{renderFieldViews FormStandard afvForm}
|
||||
^{snd afvButtons}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user