module Handler.Allocation.Application ( AllocationApplicationButton(..) , ApplicationFormView(..) , ApplicationForm(..) , ApplicationFormMode(..) , ApplicationFormException(..) , applicationForm, editApplicationR , postAApplyR ) where import Import hiding (hash) import Handler.Utils import qualified Data.Text as Text import qualified Data.Set as Set import qualified Database.Esqueleto as E import qualified Data.Conduit.List as C 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 makePrisms ''AllocationApplicationButton instance Button UniWorX AllocationApplicationButton where btnLabel BtnAllocationApply = [whamlet|#{iconApply True} _{MsgBtnAllocationApply}|] btnLabel BtnAllocationApplicationRetract = [whamlet|#{iconApply False} _{MsgBtnAllocationApplicationRetract}|] btnLabel BtnAllocationApplicationEdit = [whamlet|#{iconAllocationApplicationEdit} _{MsgBtnAllocationApplicationEdit}|] btnLabel BtnAllocationApplicationRate = i18n BtnAllocationApplicationRate 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 , afText :: Maybe Text , afFiles :: Maybe FileUploads , 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 :: Maybe AllocationId -> CourseId -> Maybe UserId -> ApplicationFormMode -- ^ Which parts of the shared form to display -> Maybe Html -- ^ If @Just@ also include action buttons for usage as standalone form -> MForm Handler (FormResult ApplicationForm, ApplicationFormView) applicationForm maId@(is _Just -> isAlloc) cid muid ApplicationFormMode{..} mcsrf = do (mApp, coursesNum, Course{..}, maxPrio) <- liftHandler . runDB $ do mApplication <- fmap join . for muid $ \uid -> listToMaybe <$> selectList [CourseApplicationAllocation ==. maId, CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid] [LimitTo 1] coursesNum <- fromIntegral . fromMaybe 1 <$> for maId (\aId -> count [AllocationCourseAllocation ==. aId]) course <- getJust cid (fromMaybe 0 -> maxPrio) <- fmap join . for muid $ \uid -> fmap (E.unValue <=< listToMaybe) . E.select . E.from $ \courseApplication -> do E.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val uid E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.val maId E.&&. E.not_ (E.isNothing $ courseApplication E.^. CourseApplicationAllocationPriority) return . E.joinV . E.max_ $ courseApplication E.^. CourseApplicationAllocationPriority return (mApplication, coursesNum, course, maxPrio) MsgRenderer mr <- getMsgRenderer let oldPrio :: Maybe Natural oldPrio = mApp >>= courseApplicationAllocationPriority . entityVal coursesNum' = succ maxPrio `max` 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 .. pred coursesNum'] , olReadExternal = readMay } prioField = selectField' (Just $ SomeMessage MsgAllocationCourseNoApplication) $ return prioOptions (prioRes, prioView) <- case (isAlloc, afmApplicant, afmApplicantEdit, mApp) of (True , True , True , Nothing) -> over _2 Just <$> mopt prioField (fslI MsgApplicationPriority) (Just oldPrio) (True , True , True , Just _ ) -> over (_1 . _FormSuccess) Just . over _2 Just <$> mreq prioField (fslI MsgApplicationPriority) oldPrio (True , True , False, _ ) -> over _2 Just <$> mforcedOpt prioField (fslI MsgApplicationPriority) oldPrio (True , False, _ , Just _ ) | is _Just oldPrio -> pure (FormSuccess oldPrio, Nothing) (True , _ , _ , _ ) -> throwM ApplicationFormNoApplication (False, _ , _ , _ ) -> pure (FormSuccess Nothing, Nothing) 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) appFilesInfo <- for mApp $ \(Entity appId _) -> liftHandler . runDB $ do hasFiles <- exists [ CourseApplicationFileApplication ==. appId ] appCID <- encrypt appId appFilesLink <- toTextUrl <=< withFileDownloadToken (selectSource [ CourseApplicationFileApplication ==. appId ] []) $ CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR return (hasFiles, appFilesLink) let hasFiles = maybe False (view _1) appFilesInfo filesLinkView <- if | 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, appFilesLink) _{MsgCourseApplicationFiles} $of _ _{MsgCourseApplicationNoFiles} |] in Just . snd <$> mforced filesLinkField (fslI MsgCourseApplicationFiles) () | otherwise -> return Nothing filesWarningView <- if | hasFiles && isn't _NoUpload courseApplicationsFiles && afmApplicantEdit -> fmap (Just . snd) . formMessage =<< messageIconI Info IconFileUpload MsgCourseApplicationFilesNeedReupload | 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 $ Just True == fmap (courseApplicationRatingVeto . entityVal) mApp) | otherwise -> return (FormSuccess $ Just True == fmap (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 && afmLecturer) BtnAllocationApplicationRate , guardOn ( afmApplicantEdit && is _Just mApp ) BtnAllocationApplicationEdit , guardOn ( afmApplicantEdit && is _Nothing mApp ) BtnAllocationApply , guardOn ( afmApplicantEdit && is _Just mApp ) BtnAllocationApplicationRetract ] (actionRes, buttonsView) <- case mcsrf of Just csrf -> buttonForm' buttons csrf Nothing -> return (pure BtnAllocationApplicationEdit, mempty) ratingSection <- if | afmLecturer , afmApplicantEdit -> Just . set _fvTooltip (Just . toHtml $ mr MsgApplicationRatingSectionSelfTip) . snd <$> formSection MsgApplicationRatingSection | afmLecturer -> Just . snd <$> formSection MsgApplicationRatingSection | otherwise -> return Nothing return ( ApplicationForm <$> prioRes <*> textRes <*> filesRes <*> vetoRes <*> pointsRes <*> commentRes <*> actionRes , ApplicationFormView { afvPriority = prioView , afvForm = catMaybes $ [ textView , filesLinkView , filesWarningView ] ++ maybe [] (map Just) filesView ++ [ ratingSection , vetoView , pointsView , commentView ] , afvButtons = (buttons, buttonsView) } ) editApplicationR :: Maybe AllocationId -> UserId -> CourseId -> Maybe CourseApplicationId -> ApplicationFormMode -> (AllocationApplicationButton -> Bool) -> SomeRoute UniWorX -> Handler (ApplicationFormView, Enctype) editApplicationR maId uid cid mAppId afMode allowAction postAction = do Course{..} <- runDB $ get404 cid ((appRes, appView), appEnc) <- runFormPost $ applicationForm maId cid (Just uid) afMode . Just formResult appRes $ \ApplicationForm{..} -> do if | BtnAllocationApply <- afAction , allowAction afAction -> runDB . setSerializable $ do haveOld <- exists [ CourseApplicationCourse ==. cid , CourseApplicationUser ==. uid , CourseApplicationAllocation ==. maId ] when haveOld $ invalidArgsI [MsgCourseApplicationExists] now <- liftIO getCurrentTime let rated = afRatingVeto || is _Just afRatingPoints appId <- insert CourseApplication { courseApplicationCourse = cid , courseApplicationUser = uid , courseApplicationText = afText , courseApplicationRatingVeto = afRatingVeto , courseApplicationRatingPoints = afRatingPoints , courseApplicationRatingComment = afRatingComment , courseApplicationAllocation = maId , courseApplicationAllocationPriority = afPriority , courseApplicationTime = now , courseApplicationRatingTime = guardOn rated now } runConduit $ transPipe liftHandler (sequence_ afFiles) .| C.mapM_ (insert_ . review _FileReference . (, CourseApplicationFileResidual appId)) audit $ TransactionCourseApplicationEdit cid uid appId addMessageI Success $ MsgCourseApplicationCreated courseShorthand | is _BtnAllocationApplicationEdit afAction || is _BtnAllocationApplicationRate afAction , allowAction afAction , Just appId <- mAppId -> runDB . setSerializable $ do now <- liftIO getCurrentTime changes <- if | afmApplicantEdit afMode -> let mkFilter CourseApplicationFileResidual{..} = [ CourseApplicationFileApplication ==. courseApplicationFileResidualApplication ] in view _2 <$> replaceFileReferences mkFilter (CourseApplicationFileResidual appId) (forM_ afFiles id) | otherwise -> return Set.empty oldApp <- get404 appId let newApp = oldApp { courseApplicationText = afText , courseApplicationRatingVeto = afRatingVeto , courseApplicationRatingPoints = afRatingPoints , courseApplicationRatingComment = afRatingComment , courseApplicationAllocation = maId , courseApplicationAllocationPriority = afPriority } newRating = any (\f -> f oldApp newApp) [ (/=) `on` courseApplicationRatingVeto , (/=) `on` courseApplicationRatingPoints , (/=) `on` courseApplicationRatingComment ] hasRating = any ($ newApp) [ courseApplicationRatingVeto , is _Just . courseApplicationRatingPoints ] appChanged = any (\f -> f oldApp newApp) [ (/=) `on` courseApplicationText , \_ _ -> not $ Set.null changes ] newApp' = newApp & bool id (set _courseApplicationRatingTime Nothing) appChanged & bool id (set _courseApplicationRatingTime $ Just now) (newRating && hasRating) & bool id (set _courseApplicationTime now) appChanged replace appId newApp' audit $ TransactionCourseApplicationEdit cid uid appId uncurry addMessageI =<< case (afmLecturer afMode, newRating, hasRating, appChanged) of (_, False, _, True) -> return (Success, MsgCourseApplicationEdited courseShorthand) (_, False, _, False) -> return (Info, MsgCourseApplicationNotEdited courseShorthand) (True, True, True, _) -> return (Success, MsgCourseApplicationRated) (True, True, False, _) -> return (Success, MsgCourseApplicationRatingDeleted) (False, True, _, _) -> permissionDenied "rating changed without lecturer rights" | is _BtnAllocationApplicationRetract afAction , allowAction afAction , Just appId <- mAppId -> runDB $ do deleteCascade appId audit $ TransactionCourseApplicationDeleted cid uid appId addMessageI Success $ MsgCourseApplicationDeleted courseShorthand | otherwise -> invalidArgsI [MsgCourseApplicationInvalidAction] redirect postAction return (appView, appEnc) postAApplyR :: TermId -> SchoolId -> AllocationShorthand -> CryptoUUIDCourse -> Handler Void postAApplyR tid ssh ash cID = do uid <- requireAuthId cid <- decrypt cID (aId, Course{..}) <- runDB $ do aId <- getKeyBy404 $ TermSchoolAllocationShort tid ssh ash course <- get404 cid return (aId, course) afmLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR let afMode = ApplicationFormMode { afmApplicant = True , afmApplicantEdit = True , afmLecturer } void . editApplicationR (Just aId) uid cid Nothing afMode (== BtnAllocationApply) . SomeRoute $ AllocationR tid ssh ash AShowR :#: cID invalidArgs ["Application form required"]