445 lines
19 KiB
Haskell
445 lines
19 KiB
Haskell
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)
|
|
<a ##{theId} *{attrs} href=@{CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR}>
|
|
_{MsgCourseApplicationFiles}
|
|
$of _
|
|
<span ##{theId} *{attrs}>
|
|
_{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
|
|
}
|