module Handler.Allocation.Application ( AllocationApplicationButton(..) , ApplicationFormView(..) , ApplicationForm(..) , ApplicationFormMode(..) , ApplicationFormException(..) , applicationForm , postAApplyR , getAApplicationR, postAApplicationR ) where import Import hiding (hash) import Handler.Utils import Utils.Lens import qualified Data.Text as Text import qualified Data.Set as Set import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E import qualified Data.Conduit.List as C import Crypto.Hash (hash) import Control.Monad.Trans.State (execStateT) import Control.Monad.State.Class (modify) 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 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 , afField :: Maybe StudyFeaturesId , afText :: Maybe Text , afFiles :: Maybe (Source Handler File) , 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 :: AllocationId -> CourseId -> UserId -> ApplicationFormMode -- ^ Which parts of the shared form to display -> Html -> MForm Handler (FormResult ApplicationForm, ApplicationFormView) applicationForm aId cid uid ApplicationFormMode{..} csrf = do (mApp, coursesNum, Course{..}, maxPrio) <- liftHandlerT . runDB $ do mApplication <- listToMaybe <$> selectList [CourseApplicationAllocation ==. Just aId, CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid] [LimitTo 1] coursesNum <- fromIntegral <$> count [AllocationCourseAllocation ==. aId] course <- getJust cid [E.Value (fromMaybe 0 -> maxPrio)] <- E.select . E.from $ \courseApplication -> do E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cid E.&&. courseApplication E.^. CourseApplicationUser E.==. E.val uid E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (E.val aId) 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 (afmApplicant, afmApplicantEdit, mApp) of (True , True , Nothing) -> over _2 Just <$> mopt prioField (fslI MsgApplicationPriority) (Just $ oldPrio) (True , True , Just _ ) -> over (_1 . _FormSuccess) Just . over _2 Just <$> mreq prioField (fslI MsgApplicationPriority) oldPrio (True , False, _ ) -> over _2 Just <$> mforcedOpt prioField (fslI MsgApplicationPriority) oldPrio (False, _ , Just _ ) | is _Just oldPrio -> pure (FormSuccess oldPrio, Nothing) _other -> throwM ApplicationFormNoApplication (fieldRes, fieldView') <- if | afmApplicantEdit || afmLecturer -> mreq (studyFeaturesFieldFor Nothing False [] $ Just uid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) (courseApplicationField . entityVal <$> mApp) | otherwise -> mforced (studyFeaturesFieldFor Nothing True (maybeToList $ mApp >>= courseApplicationField . entityVal) $ Just uid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) (mApp >>= courseApplicationField . entityVal) 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) hasFiles <- for mApp $ \(Entity appId _) -> fmap (not . null) . liftHandlerT . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ] appCID <- for mApp $ encrypt . entityKey let appFilesInfo = (,) <$> hasFiles <*> appCID filesLinkView <- if | fromMaybe False 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, appCID) _{MsgCourseApplicationFiles} $of _ _{MsgCourseApplicationNoFiles} |] in Just . snd <$> mforced filesLinkField (fslI MsgCourseApplicationFiles) () | otherwise -> return Nothing filesWarningView <- if | fromMaybe False 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 . fromMaybe False $ courseApplicationRatingVeto . entityVal <$> mApp) | otherwise -> return (FormSuccess . fromMaybe False $ 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) <- buttonForm' buttons csrf return ( ApplicationForm <$> prioRes <*> fieldRes <*> textRes <*> filesRes <*> vetoRes <*> pointsRes <*> commentRes <*> actionRes , ApplicationFormView { afvPriority = prioView , afvForm = catMaybes $ [ Just fieldView' , textView , filesLinkView , filesWarningView ] ++ maybe [] (map Just) filesView ++ [ vetoView , pointsView , commentView ] , afvButtons = (buttons, buttonsView) } ) editApplicationR :: AllocationId -> UserId -> CourseId -> Maybe CourseApplicationId -> ApplicationFormMode -> (AllocationApplicationButton -> Bool) -> SomeRoute UniWorX -> Handler (ApplicationFormView, Enctype) editApplicationR aId uid cid mAppId afMode allowAction postAction = do Course{..} <- runDB $ get404 cid ((appRes, appView), appEnc) <- runFormPost $ applicationForm aId cid uid afMode formResult appRes $ \ApplicationForm{..} -> do if | BtnAllocationApply <- afAction , allowAction afAction -> runDB $ do haveOld <- exists [ CourseApplicationCourse ==. cid , CourseApplicationUser ==. uid , CourseApplicationAllocation ==. Just aId ] when haveOld $ invalidArgsI [MsgCourseApplicationExists] now <- liftIO getCurrentTime let rated = afRatingVeto || is _Just afRatingPoints appId <- insert CourseApplication { courseApplicationCourse = cid , courseApplicationUser = uid , courseApplicationField = afField , courseApplicationText = afText , courseApplicationRatingVeto = afRatingVeto , courseApplicationRatingPoints = afRatingPoints , courseApplicationRatingComment = afRatingComment , courseApplicationAllocation = Just aId , courseApplicationAllocationPriority = afPriority , courseApplicationTime = now , courseApplicationRatingTime = guardOn rated now } let sinkFile' file = do fId <- insert file insert_ $ CourseApplicationFile appId fId forM_ afFiles $ \afFiles' -> runConduit $ transPipe liftHandlerT afFiles' .| C.mapM_ sinkFile' audit $ TransactionCourseApplicationEdit cid uid appId addMessageI Success $ MsgCourseApplicationCreated courseShorthand | is _BtnAllocationApplicationEdit afAction || is _BtnAllocationApplicationRate afAction , allowAction afAction , Just appId <- mAppId -> runDB $ do now <- liftIO getCurrentTime changes <- if | afmApplicantEdit afMode -> do oldFiles <- Set.fromList . map (courseApplicationFileFile . entityVal) <$> selectList [CourseApplicationFileApplication ==. appId] [] changes <- flip execStateT oldFiles . forM_ afFiles $ \afFiles' -> let sinkFile' file = do oldFiles' <- lift . E.select . E.from $ \(courseApplicationFile `E.InnerJoin` file') -> do E.on $ courseApplicationFile E.^. CourseApplicationFileFile E.==. file' E.^. FileId E.where_ $ file' E.^. FileTitle E.==. E.val (fileTitle file) E.&&. E.maybe (E.val . is _Nothing $ fileContent file) (\fc' -> maybe E.false (\fc -> E.sha256 fc' E.==. E.val (hash fc)) $ fileContent file) (file' E.^. FileContent) E.&&. file' E.^. FileId `E.in_` E.valList (Set.toList oldFiles) return $ file' E.^. FileId if | [E.Value oldFileId] <- oldFiles' -> modify $ Set.delete oldFileId | otherwise -> do fId <- lift $ insert file lift . insert_ $ CourseApplicationFile appId fId modify $ Set.insert fId in runConduit $ transPipe liftHandlerT afFiles' .| C.mapM_ sinkFile' deleteCascadeWhere [ FileId <-. Set.toList (oldFiles `Set.intersection` changes) ] return changes | otherwise -> return Set.empty oldApp <- get404 appId let newApp = oldApp { courseApplicationField = afField , courseApplicationText = afText , courseApplicationRatingVeto = afRatingVeto , courseApplicationRatingPoints = afRatingPoints , courseApplicationRatingComment = afRatingComment , courseApplicationAllocation = Just aId , 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` courseApplicationField , (/=) `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 aId uid cid Nothing afMode (== BtnAllocationApply) . SomeRoute $ AllocationR tid ssh ash AShowR :#: cID invalidArgs ["Application form required"] getAApplicationR, postAApplicationR :: TermId -> SchoolId -> AllocationShorthand -> CryptoFileNameCourseApplication -> Handler Html getAApplicationR = postAApplicationR postAApplicationR tid ssh ash cID = do uid <- requireAuthId appId <- decrypt cID (Entity aId Allocation{..}, Entity cid Course{..}, CourseApplication{..}, isAdmin, User{..}) <- runDB $ do alloc <- getBy404 $ TermSchoolAllocationShort tid ssh ash app <- get404 appId Just course <- getEntity $ courseApplicationCourse app Just appUser <- get $ courseApplicationUser app isAdmin <- exists [UserAdminUser ==. uid, UserAdminSchool ==. alloc ^. _entityVal . _allocationSchool] return (alloc, course, app, isAdmin, appUser) afmLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR afmApplicantEdit <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplicationR cID courseCID <- encrypt cid :: Handler CryptoUUIDCourse let afMode = ApplicationFormMode { afmApplicant = uid == courseApplicationUser || isAdmin , afmApplicantEdit , afmLecturer } (ApplicationFormView{..}, appEnc) <- editApplicationR aId uid cid (Just appId) afMode (/= BtnAllocationApply) $ if | uid == courseApplicationUser -> SomeRoute $ AllocationR tid ssh ash AShowR :#: courseCID | otherwise -> SomeRoute . AllocationR tid ssh ash $ AApplicationR cID let title = MsgCourseApplicationTitle userDisplayName courseShorthand siteLayoutMsg title $ do setTitleI title wrapForm ((<> snd afvButtons) . renderFieldViews FormStandard . maybe id (:) afvPriority$ afvForm) FormSettings { formMethod = POST , formAction = Just . SomeRoute . AllocationR tid ssh ash $ AApplicationR cID , formEncoding = appEnc , formAttrs = [] , formSubmit = FormNoSubmit , formAnchor = Nothing :: Maybe Text }