71 lines
3.1 KiB
Haskell
71 lines
3.1 KiB
Haskell
module Handler.Allocation.Show
|
|
( getAShowR
|
|
) where
|
|
|
|
import Import
|
|
import Handler.Utils
|
|
import Utils.Lens
|
|
|
|
import Handler.Allocation.Register
|
|
|
|
import qualified Database.Esqueleto as E
|
|
|
|
|
|
getAShowR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
|
|
getAShowR tid ssh ash = do
|
|
muid <- maybeAuthId
|
|
|
|
let
|
|
resultCourse :: Lens' (Entity Course, _, _) (Entity Course)
|
|
resultCourse = _1
|
|
-- resultCourseApplication = _2
|
|
resultHasTemplate = _3 . _Value
|
|
|
|
(Entity _ 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
|
|
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
|
|
cID <- encrypt cid :: WidgetT UniWorX IO CryptoUUIDCourse
|
|
mayApply <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplyR cID
|
|
$(widgetFile "allocation/show/course")
|
|
|
|
$(widgetFile "allocation/show")
|