228 lines
12 KiB
Haskell
228 lines
12 KiB
Haskell
module Handler.Allocation.UserForm
|
|
( AllocationUserForm(..)
|
|
, allocationUserForm
|
|
, CourseParticipantForm(..)
|
|
, _CourseParticipantFormNotAllocated, _CourseParticipantFormDeregistered, _CourseParticipantFormRegistered, _cpfDeregisterReason, _cpfEverRegistered
|
|
, CourseParticipantForm'
|
|
, courseParticipantForm
|
|
) where
|
|
|
|
import Import
|
|
import Handler.Allocation.Application
|
|
|
|
import Handler.Utils
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
import qualified Database.Esqueleto.PostgreSQL as E
|
|
import qualified Data.Map.Strict as Map
|
|
|
|
import Text.Blaze (toMarkup)
|
|
|
|
|
|
data AllocationUserForm = AllocationUserForm
|
|
{ aauUser :: UserId
|
|
, aauTotalCourses :: Word64
|
|
, aauPriority :: Maybe AllocationPriority
|
|
, aauApplications :: Map CourseId ApplicationForm
|
|
}
|
|
|
|
|
|
allocationUserForm :: forall m backend.
|
|
( MonadHandler m, HandlerSite m ~ UniWorX
|
|
, E.SqlBackendCanRead backend, IsSqlBackend backend
|
|
)
|
|
=> AllocationId
|
|
-> Maybe AllocationUserForm
|
|
-> AForm (ReaderT backend m) AllocationUserForm
|
|
allocationUserForm aId mTemplate = wFormToAForm $ do
|
|
allocCourses <- lift . lift . E.select . E.from $ \(course `E.InnerJoin` allocationCourse) -> do
|
|
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
|
|
E.where_ $ allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId
|
|
return ( course
|
|
, E.exists . E.from $ \courseAppInstructionFile ->
|
|
E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. course E.^. CourseId
|
|
, allocationCourse
|
|
)
|
|
|
|
MsgRenderer mr <- getMsgRenderer
|
|
|
|
userRes <- case aauUser <$> mTemplate of
|
|
Just u -> do
|
|
User{..} <- lift . lift $ get404 u
|
|
fvId <- newIdent
|
|
lift . tell $ pure FieldView
|
|
{ fvLabel = toMarkup $ mr MsgAllocationAddUserUser
|
|
, fvTooltip = Nothing
|
|
, fvId
|
|
, fvInput = nameWidget userDisplayName userSurname
|
|
, fvErrors = Nothing
|
|
, fvRequired = False
|
|
}
|
|
return $ FormSuccess u
|
|
Nothing -> wreq (checkMap (first $ const MsgAllocationAddUserUserNotFound) Right $ userField False Nothing) (fslpI MsgAllocationAddUserUser (mr MsgAllocationAddUserUserPlaceholder)) Nothing
|
|
|
|
totalCoursesRes <- wreq (posIntFieldI MsgAllocationAddUserTotalCoursesLessThanOne) (fslI MsgAllocationAddUserTotalCourses) ((aauTotalCourses <$> mTemplate) <|> Just 1)
|
|
|
|
priorityRes <- hoist (hoist liftHandler) $ optionalActionW (allocationPriorityForm (fslI MsgAllocationAddUserPriority) $ aauPriority =<< mTemplate) (fslI MsgAllocationAddUserSetPriority) ((is _Just . aauPriority <$> mTemplate) <|> Just True)
|
|
|
|
applicationsRes <- aFormToWForm $ allocationApplicationsForm aId (aauUser <$> mTemplate) (Map.fromList [ (cId, (course, allocationCourse, hasTemplate)) | (Entity cId course, E.Value hasTemplate, Entity _ allocationCourse) <- allocCourses ]) (fslI MsgAllocationAddUserApplications) False
|
|
|
|
return $ AllocationUserForm
|
|
<$> userRes
|
|
<*> totalCoursesRes
|
|
<*> priorityRes
|
|
<*> applicationsRes
|
|
|
|
|
|
allocationApplicationsForm :: forall m backend.
|
|
( MonadHandler m, HandlerSite m ~ UniWorX
|
|
, E.SqlBackendCanRead backend
|
|
)
|
|
=> AllocationId
|
|
-> Maybe UserId
|
|
-> Map CourseId (Course, AllocationCourse, Bool)
|
|
-> FieldSettings UniWorX
|
|
-> Bool
|
|
-> AForm (ReaderT backend m) (Map CourseId ApplicationForm)
|
|
allocationApplicationsForm aId muid courses FieldSettings{..} fvRequired = formToAForm $ do
|
|
now <- liftIO getCurrentTime
|
|
|
|
let afmApplicant = True
|
|
afmApplicantEdit = True
|
|
afmLecturer = True
|
|
|
|
appsRes' <- iforM courses $ \cId (course, allocCourse, hasApplicationTemplate) -> do
|
|
mApplicationTemplate <- runMaybeT $ do
|
|
guard hasApplicationTemplate
|
|
let Course{..} = course
|
|
toTextUrl $ CourseR courseTerm courseSchool courseShorthand CRegisterTemplateR
|
|
counts <- lift . fmap (maybe (Nothing, 0) $ bimap (assertM' (> 0) . E.unValue) E.unValue) . E.selectMaybe . E.from $ \courseApplication -> do
|
|
E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cId
|
|
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.justVal aId
|
|
let hasRating = E.isJust (courseApplication E.^. CourseApplicationRatingPoints)
|
|
E.||. E.isJust (courseApplication E.^. CourseApplicationRatingComment)
|
|
E.||. courseApplication E.^. CourseApplicationRatingVeto
|
|
return ( E.count (courseApplication E.^. CourseApplicationId) `E.filterWhere` hasRating
|
|
, E.count (courseApplication E.^. CourseApplicationId) `E.filterWhere` (courseApplication E.^. CourseApplicationRatingVeto)
|
|
)
|
|
hoist liftHandler $ over _2 (course, allocCourse, mApplicationTemplate, counts, ) <$> applicationForm (Just aId) cId muid ApplicationFormMode{..} Nothing
|
|
let appsRes = sequenceA $ view _1 <$> appsRes'
|
|
appsViews = view _2 <$> appsRes'
|
|
|
|
let fvInput =
|
|
[whamlet|
|
|
$newline never
|
|
<div .allocation__courses>
|
|
$forall (Course{courseTerm, courseSchool, courseShorthand, courseName, courseApplicationsInstructions}, AllocationCourse{allocationCourseAcceptSubstitutes}, mApplicationTemplate, (mRatings, vetos), ApplicationFormView{afvPriority, afvForm}) <- Map.elems appsViews
|
|
<div .allocation-course>
|
|
<div .allocation-course__priority-label .allocation__label>
|
|
_{MsgAllocationPriority}
|
|
<div .allocation-course__priority>
|
|
$maybe prioView <- afvPriority
|
|
^{fvWidget prioView}
|
|
<a .allocation-course__name href=@{CourseR courseTerm courseSchool courseShorthand CShowR} target="_blank">
|
|
#{courseName}
|
|
<div .allocation-course__admin-info>
|
|
<p>
|
|
$maybe deadline <- allocationCourseAcceptSubstitutes
|
|
_{MsgCourseAllocationCourseAcceptsSubstitutesUntil}: #
|
|
^{formatTimeW SelFormatDateTime deadline}
|
|
$nothing
|
|
_{MsgCourseAllocationCourseAcceptsSubstitutesNever}
|
|
$if allocationCourseAcceptSubstitutes >= Just now
|
|
\ ^{iconOK}
|
|
$maybe ratings <- mRatings
|
|
^{notification NotificationBroad =<< messageI Warning (MsgAllocationCourseHasRatings ratings vetos)}
|
|
$if is _Just mApplicationTemplate || is _Just courseApplicationsInstructions
|
|
<div .allocation-course__instructions-label .allocation__label>
|
|
_{MsgCourseAllocationApplicationInstructionsApplication}
|
|
<div .allocation-course__instructions>
|
|
$maybe aInst <- courseApplicationsInstructions
|
|
<p>
|
|
#{aInst}
|
|
$maybe templateUrl <- mApplicationTemplate
|
|
<p>
|
|
<a href=#{templateUrl}>
|
|
#{iconRegisterTemplate} _{MsgCourseAllocationApplicationTemplateApplication}
|
|
<div .allocation-course__application-label .interactive-fieldset__target .allocation__label uw-interactive-fieldset data-conditional-input=#{maybe "" fvId afvPriority} data-conditional-value="" data-conditional-negated>
|
|
_{MsgCourseApplication}
|
|
<div .allocation-course__application .interactive-fieldset__target uw-interactive-fieldset data-conditional-input=#{maybe "" fvId afvPriority} data-conditional-value="" data-conditional-negated>
|
|
^{renderFieldViews FormStandard afvForm}
|
|
|]
|
|
MsgRenderer mr <- getMsgRenderer
|
|
let fvLabel = toHtml $ mr fsLabel
|
|
fvTooltip = toHtml . mr <$> fsTooltip
|
|
fvErrors = case appsRes of
|
|
FormFailure errs -> Just
|
|
[shamlet|
|
|
$newline never
|
|
<ul>
|
|
$forall err <- errs
|
|
<li>#{err}
|
|
|]
|
|
_other -> Nothing
|
|
fvId <- maybe newIdent return fsId
|
|
|
|
return (appsRes, pure FieldView{..})
|
|
|
|
|
|
data CourseParticipantForm
|
|
= CourseParticipantFormNotAllocated -- ^ User is registered but not through allocation; no control
|
|
| CourseParticipantFormDeregistered -- ^ User is not currently registered
|
|
{ cpfDeregisterReason :: Maybe Text -- ^ `Just` if user was deregistered "self-inflicted", reason is required
|
|
, cpfEverRegistered :: Bool
|
|
}
|
|
| CourseParticipantFormRegistered -- ^ User is currently registered
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
type CourseParticipantForm' = Map CourseId CourseParticipantForm
|
|
|
|
makePrisms ''CourseParticipantForm
|
|
makeLenses_ ''CourseParticipantForm
|
|
|
|
courseParticipantForm :: forall m.
|
|
( MonadHandler m, HandlerSite m ~ UniWorX )
|
|
=> Map CourseId ((TermId, SchoolId, CourseShorthand), CourseName, CourseParticipantForm)
|
|
-> (Html -> MForm m (FormResult CourseParticipantForm', Widget))
|
|
courseParticipantForm courses csrf = do
|
|
lines' <- iforM courses $ \_cId ((tid, ssh, csh), cname, prevSt)
|
|
-> let toLine fCell = $(widgetFile "allocation/user-course-participant-form/line")
|
|
in over _2 toLine <$> case prevSt of
|
|
CourseParticipantFormNotAllocated -> do
|
|
(_, isRegView) <- mforced checkBoxField def True
|
|
return ( FormSuccess CourseParticipantFormNotAllocated
|
|
, $(widgetFile "allocation/user-course-participant-form/not-allocated")
|
|
)
|
|
_other -> do
|
|
let deregReason = prevSt ^? _cpfDeregisterReason . _Just
|
|
isRegPrev = is _CourseParticipantFormRegistered prevSt
|
|
everRegistered = fromMaybe True $ prevSt ^? _cpfEverRegistered
|
|
(isRegRes, isRegView) <- mpopt checkBoxField def $ Just isRegPrev
|
|
let selfInflictedFS = def
|
|
& addAttr "uw-interactive-fieldset" ""
|
|
& addAttr "data-conditional-input" (fvId isRegView)
|
|
& addAttr "data-conditional-negated" ""
|
|
(isSelfInflictedRes, isSelfInflictedView) <- if
|
|
| everRegistered -> over _2 Just <$> mopt (textField & cfStrip) selfInflictedFS (Just deregReason)
|
|
| otherwise -> return (FormSuccess Nothing, Nothing)
|
|
return ( case isRegRes of
|
|
FormMissing -> FormMissing
|
|
FormFailure es1 -> FormFailure $ es1 <> view _FormFailure isSelfInflictedRes
|
|
FormSuccess True
|
|
| FormFailure es2 <- isSelfInflictedRes
|
|
-> FormFailure es2
|
|
| otherwise
|
|
-> FormSuccess CourseParticipantFormRegistered
|
|
FormSuccess False
|
|
-> CourseParticipantFormDeregistered <$> isSelfInflictedRes <*> pure everRegistered
|
|
, $(widgetFile "allocation/user-course-participant-form/cell")
|
|
)
|
|
let linesWidget = Map.intersectionWith (,) courses lines'
|
|
& Map.elems
|
|
& sortOn (view $ _1 . _1)
|
|
& view (folded . _2 . _2)
|
|
return ( forM lines' $ view _1
|
|
, $(widgetFile "allocation/user-course-participant-form/layout")
|
|
)
|