118 lines
6.0 KiB
Haskell
118 lines
6.0 KiB
Haskell
module Handler.Allocation.Show
|
|
( getAShowR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Utils.Course
|
|
|
|
import Handler.Utils
|
|
|
|
import Handler.Allocation.Register
|
|
import Handler.Allocation.Application
|
|
|
|
import qualified Database.Esqueleto as E
|
|
|
|
|
|
getAShowR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
|
|
getAShowR tid ssh ash = do
|
|
muid <- maybeAuthId
|
|
now <- liftIO getCurrentTime
|
|
ata <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
|
|
|
|
let
|
|
resultCourse :: Simple Field1 a (Entity Course) => Lens' a (Entity Course)
|
|
resultCourse = _1
|
|
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
|
|
resultIsRegistered :: Simple Field4 a (E.Value Bool) => Lens' a Bool
|
|
resultIsRegistered = _4 . _Value
|
|
|
|
(Entity aId Allocation{..}, School{..}, isAnyLecturer, courses, registration) <- runDB $ do
|
|
alloc@(Entity aId Allocation{allocationSchool}) <- getBy404 $ TermSchoolAllocationShort tid ssh ash
|
|
school <- getJust allocationSchool
|
|
|
|
courses <- E.select . E.from $ \((allocationCourse `E.InnerJoin` course) `E.LeftOuterJoin` courseApplication `E.LeftOuterJoin` registration) -> do
|
|
E.on $ registration E.?. CourseParticipantCourse E.==. E.just (course E.^. CourseId)
|
|
E.&&. registration E.?. CourseParticipantUser E.==. E.val muid
|
|
E.&&. registration E.?. CourseParticipantState E.==. E.just (E.val CourseParticipantActive)
|
|
E.on $ courseApplication E.?. CourseApplicationCourse E.==. E.just (course E.^. CourseId)
|
|
E.&&. courseApplication E.?. CourseApplicationUser E.==. E.val muid
|
|
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.&&. mayViewCourse muid ata now course
|
|
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, E.not_ . E.isNothing $ registration E.?. CourseParticipantId)
|
|
|
|
registration <- fmap join . for muid $ getBy . UniqueAllocationUser aId
|
|
|
|
isAnyLecturer <- hasWriteAccessTo CourseNewR
|
|
|
|
return (alloc, school, isAnyLecturer, nubOn (view $ resultCourse . _entityKey) courses, registration)
|
|
|
|
MsgRenderer mr <- getMsgRenderer
|
|
let title = MsgAllocationTitle (mr . ShortTermIdentifier $ unTermKey allocationTerm) (unSchoolKey allocationSchool) allocationName
|
|
shortTitle = MsgAllocationShortTitle (mr . ShortTermIdentifier $ unTermKey allocationTerm) (unSchoolKey allocationSchool) allocationShorthand
|
|
|
|
-- staffInformation <- anyM courses $ \(view $ resultCourse . _entityVal -> Course{..}) ->
|
|
-- hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CApplicationsR
|
|
mayRegister <- hasWriteAccessTo $ AllocationR tid ssh ash ARegisterR
|
|
(registerForm, registerEnctype) <- generateFormPost . renderAForm FormStandard . allocationRegisterForm $ allocationUserToForm . entityVal <$> registration
|
|
let
|
|
registerBtn = bool BtnAllocationRegister BtnAllocationRegistrationEdit $ is _Just registration
|
|
registerForm' = wrapForm' registerBtn registerForm FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute $ AllocationR tid ssh ash ARegisterR
|
|
, formEncoding = registerEnctype
|
|
, formAttrs = []
|
|
, formSubmit = FormSubmit
|
|
, formAnchor = Nothing :: Maybe Text
|
|
}
|
|
|
|
siteLayoutMsg title $ do
|
|
setTitleI shortTitle
|
|
|
|
let courseWidgets = flip map courses $ \cEntry -> do
|
|
let Entity cid c@Course{..} = cEntry ^. resultCourse
|
|
hasApplicationTemplate = cEntry ^. resultHasTemplate
|
|
mApp = cEntry ^? resultCourseApplication
|
|
isRegistered = cEntry ^. resultIsRegistered
|
|
courseVisible = courseIsVisible' now c
|
|
cID <- encrypt cid :: WidgetFor UniWorX CryptoUUIDCourse
|
|
mayApply <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplyR cID
|
|
mayEdit <- hasWriteAccessTo $ CourseR tid ssh courseShorthand CEditR
|
|
isLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
|
|
mApplyFormView <- liftHandler . for muid $ \uid -> generateFormPost . applicationForm (Just aId) cid uid $ ApplicationFormMode True mayApply isLecturer
|
|
tRoute <- case mApp of
|
|
Nothing -> return . AllocationR tid ssh ash $ AApplyR cID
|
|
Just (Entity appId _) -> CApplicationR courseTerm courseSchool courseShorthand <$> encrypt appId <*> pure CAEditR
|
|
let mApplyFormView' = view _1 <$> mApplyFormView
|
|
overrideVisible = not mayApply && is _Just mApp
|
|
case mApplyFormView of
|
|
Just (_, appFormEnctype)
|
|
-> wrapForm $(widgetFile "allocation/show/course") FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just $ SomeRoute tRoute
|
|
, formEncoding = appFormEnctype
|
|
, formAttrs = [ ("class", "allocation-course")
|
|
]
|
|
, formSubmit = FormNoSubmit
|
|
, formAnchor = Just cID
|
|
}
|
|
Nothing
|
|
-> let wdgt = $(widgetFile "allocation/show/course")
|
|
in [whamlet|
|
|
<div .allocation-course ##{toPathPiece cID}>
|
|
^{wdgt}
|
|
|]
|
|
let daysToRegistrationStart = assertM (>0) $ (`diffUTCTime` now) <$> allocationRegisterFrom
|
|
allocationInfoModal = modal [whamlet|_{MsgMenuAllocationInfo}|] $ Left $ SomeRoute InfoAllocationR
|
|
numCourses = length courses
|
|
numAppliedCourses = lengthOf (folded . _2 . _Just) courses
|
|
$(widgetFile "allocation/show")
|