98 lines
4.9 KiB
Haskell
98 lines
4.9 KiB
Haskell
module Handler.Allocation.Show
|
|
( getAShowR
|
|
) where
|
|
|
|
import Import
|
|
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
|
|
|
|
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
|
|
|
|
(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
|
|
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.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)
|
|
|
|
registration <- fmap join . for muid $ getBy . UniqueAllocationUser aId
|
|
|
|
return (alloc, 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 Course{..} = cEntry ^. resultCourse
|
|
hasApplicationTemplate = cEntry ^. resultHasTemplate
|
|
mApp = cEntry ^? resultCourseApplication
|
|
cID <- encrypt cid :: WidgetT UniWorX IO CryptoUUIDCourse
|
|
mayApply <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplyR cID
|
|
isLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
|
|
mApplyFormView <- liftHandlerT . for muid $ \uid -> generateFormPost . applicationForm aId cid uid $ ApplicationFormMode True mayApply isLecturer
|
|
subRoute <- fmap (fromMaybe $ AApplyR cID) . for mApp $ \(Entity appId _) -> AApplicationR <$> encrypt appId
|
|
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 $ AllocationR tid ssh ash subRoute
|
|
, 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
|
|
$(widgetFile "allocation/show")
|