378 lines
16 KiB
Haskell
378 lines
16 KiB
Haskell
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 $ 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)
|
|
<a ##{theId} *{attrs} href=#{appFilesLink}>
|
|
_{MsgCourseApplicationFiles}
|
|
$of _
|
|
<span ##{theId} *{attrs}>
|
|
_{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"]
|