feat(labels): actions for setting and removing labels
This commit is contained in:
Sarah Vaupel
parent
a2a8957c57
commit
9e81f03742
@ -69,3 +69,7 @@ ExamOfficeLabelStatus !ident-ok: Status
|
||||
ExamOfficeLabelPriority: Priorität
|
||||
ExamOfficeLabelAlreadyExists: Es existiert bereits ein Prüfungs-Label mit diesem Namen!
|
||||
ExamOfficeExamsNoLabel: Kein Label
|
||||
ExamSetLabel: Label setzen
|
||||
ExamLabelsSet n@Int: #{n} Prüfungs-#{pluralDE n "Label" "Labels"} gesetzt
|
||||
ExamRemoveLabel: Label entfernen
|
||||
ExamLabelsRemoved n@Int: #{n} Prüfungs-#{pluralDE n "Label" "Labels"} entfernt
|
||||
|
||||
@ -67,3 +67,7 @@ ExamOfficeLabelStatus: Status
|
||||
ExamOfficeLabelPriority: Priority
|
||||
ExamOfficeLabelAlreadyExists: There already exists an exam label with this name!
|
||||
ExamOfficeExamsNoLabel: No label
|
||||
ExamSetLabel: Set label
|
||||
ExamLabelsSet n: Successfully set #{n} exam #{pluralEN n "label" "labels"}
|
||||
ExamRemoveLabel: Remove label
|
||||
ExamLabelsRemoved n: Successfully removed #{n} exam #{pluralEN n "label" "labels"}
|
||||
|
||||
2
routes
2
routes
@ -112,7 +112,7 @@
|
||||
/user/storage-key StorageKeyR POST !free
|
||||
|
||||
/exam-office ExamOfficeR !exam-office:
|
||||
/ EOExamsR GET !system-exam-office
|
||||
/ EOExamsR GET POST !system-exam-office
|
||||
/fields EOFieldsR GET POST
|
||||
/users EOUsersR GET POST !system-exam-office
|
||||
/users/invite EOUsersInviteR GET POST !system-exam-office
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
||||
|
||||
module Handler.ExamOffice.Exams
|
||||
( getEOExamsR
|
||||
( getEOExamsR, postEOExamsR
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -16,6 +16,22 @@ import qualified Database.Esqueleto.Utils as E
|
||||
import qualified Colonnade
|
||||
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
|
||||
data ExamAction = ExamSetLabel | ExamRemoveLabel
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
nullaryPathPiece ''ExamAction $ camelToPathPiece' 1
|
||||
embedRenderMessage ''UniWorX ''ExamAction id
|
||||
|
||||
data ExamActionData = ExamSetLabelData
|
||||
{ easlNewLabel :: ExamOfficeLabelId
|
||||
}
|
||||
| ExamRemoveLabelData
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
|
||||
data ExamsTableFilterProj = ExamsTableFilterProj
|
||||
@ -114,8 +130,9 @@ resultIsSynced = to $ (>=) <$> view resultSynchronised <*> view resultResults
|
||||
|
||||
-- | List of all exams where the current user may (in her function as
|
||||
-- exam-office) access users grades
|
||||
getEOExamsR :: Handler Html
|
||||
getEOExamsR = do
|
||||
getEOExamsR, postEOExamsR :: Handler Html
|
||||
getEOExamsR = postEOExamsR
|
||||
postEOExamsR = do
|
||||
(uid, User{..}) <- requireAuthPair
|
||||
now <- liftIO getCurrentTime
|
||||
mr <- getMessageRender
|
||||
@ -130,7 +147,7 @@ getEOExamsR = do
|
||||
Just "no" -> False
|
||||
_ -> userExamOfficeGetLabels
|
||||
|
||||
examsTable <- runDB $ do
|
||||
(examsRes, examsTable) <- runDB $ do
|
||||
let labelFilterNoLabelOption = Option
|
||||
{ optionDisplay = mr MsgExamOfficeExamsNoLabel
|
||||
, optionInternalValue = Nothing
|
||||
@ -160,6 +177,7 @@ getEOExamsR = do
|
||||
externalExamLink ExternalExam{..}
|
||||
= SomeRoute $ EExamR externalExamTerm externalExamSchool externalExamCourseName externalExamExamName EEGradesR
|
||||
|
||||
|
||||
examsDBTable = DBTable{..}
|
||||
where
|
||||
dbtSQLQuery = runReaderT $ do
|
||||
@ -203,7 +221,7 @@ getEOExamsR = do
|
||||
dbtRowKey = views ($(multifocusG 2) queryExam queryExternalExam) (bimap (E.?. ExamId) (E.?. ExternalExamId))
|
||||
|
||||
dbtProj :: _ ExamsTableData
|
||||
dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do -- dbtProjSimple . runReaderT $ do
|
||||
dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do
|
||||
exam <- view $ _dbtProjRow . _dbrOutput . _1
|
||||
course <- view $ _dbtProjRow . _dbrOutput . _2
|
||||
school <- view $ _dbtProjRow . _dbrOutput . _3
|
||||
@ -313,18 +331,18 @@ getEOExamsR = do
|
||||
, emptyOpticColonnade (resultCourse . _entityVal . _courseTerm <> resultExternalExam . _entityVal . _externalExamTerm) colTermShort
|
||||
]
|
||||
dbtSorting = mconcat $
|
||||
(bool mempty
|
||||
bool mempty
|
||||
[ singletonMap "label-prio" $
|
||||
SortProjected . comparing $ (fmap . fmap $ examOfficeLabelPriority . entityVal) <$> preview resultLabel
|
||||
, singletonMap "label-status" $
|
||||
SortProjected . comparing $ (fmap . fmap $ examOfficeLabelStatus . entityVal) <$> preview resultLabel
|
||||
] getLabels) <>
|
||||
(bool mempty
|
||||
] getLabels <>
|
||||
bool mempty
|
||||
[ singletonMap "synced" $
|
||||
SortProjected . comparing $ ((/) `on` toRational . fromMaybe 0) <$> view resultSynchronised <*> view resultResults
|
||||
, singletonMap "is-synced" $
|
||||
SortProjected . comparing $ (>=) <$> view resultSynchronised <*> view resultResults
|
||||
] getSynced) <>
|
||||
] getSynced <>
|
||||
[ sortExamName (to $ E.unsafeCoalesce . sequence [views queryExam (E.?. ExamName), views queryExternalExam (E.?. ExternalExamExamName)])
|
||||
, sortExamTime (queryExam . $(multifocusG 2) (to $ E.joinV . (E.?. ExamStart)) (to $ E.joinV . (E.?. ExamEnd)))
|
||||
, sortExamFinished (queryExam . to (E.joinV . (E.?. ExamFinished)))
|
||||
@ -347,7 +365,28 @@ getEOExamsR = do
|
||||
| getSynced ]
|
||||
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
dbtParams = def
|
||||
|
||||
dbtParams = DBParamsForm
|
||||
{ dbParamsFormMethod = POST
|
||||
, dbParamsFormAction = Just . SomeRoute $ ExamOfficeR EOExamsR
|
||||
, dbParamsFormAttrs = []
|
||||
, dbParamsFormSubmit = FormSubmit
|
||||
, dbParamsFormAdditional
|
||||
= let actions :: Map ExamAction (AForm Handler ExamActionData)
|
||||
actions = Map.fromList $
|
||||
bool mempty
|
||||
[ ( ExamSetLabel, ExamSetLabelData
|
||||
<$> apopt (selectField' Nothing . fmap (fmap entityKey) $ optionsPersist [ExamOfficeLabelUser ==. uid] [Asc ExamOfficeLabelName] examOfficeLabelName) (fslI MsgExamLabel) Nothing
|
||||
)
|
||||
, ( ExamRemoveLabel, pure ExamRemoveLabelData )
|
||||
] getLabels
|
||||
in renderAForm FormStandard
|
||||
$ (, mempty) . First . Just
|
||||
<$> multiActionA actions (fslI MsgTableAction) Nothing
|
||||
, dbParamsFormEvaluate = liftHandler . runFormPost
|
||||
, dbParamsFormResult = id
|
||||
, dbParamsFormIdent = def
|
||||
}
|
||||
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "exams"
|
||||
@ -362,7 +401,22 @@ getEOExamsR = do
|
||||
& forceFilter "may-access" (Any True)
|
||||
& forceFilter "has-results" (Any True)
|
||||
|
||||
dbTableWidget' examsDBTableValidator examsDBTable
|
||||
postprocess :: FormResult (First ExamActionData, DBFormResult (Either ExternalExamId ExamId) Bool (DBRow (Either (Entity ExternalExam) (Entity Exam)))) -> FormResult (ExamActionData, Set (Either ExternalExamId ExamId))
|
||||
postprocess (FormFailure errs) = FormFailure errs
|
||||
postprocess FormMissing = FormMissing
|
||||
postprocess (FormSuccess (First mExamActionData, examRes)) = maybe FormMissing (\act -> FormSuccess . (act,) . Map.keysSet . Map.filter id $ getDBFormResult (const False) examRes) mExamActionData
|
||||
|
||||
over _1 postprocess <$> dbTable examsDBTableValidator examsDBTable
|
||||
|
||||
formResult examsRes $ \(examAction, exams) -> case examAction of
|
||||
ExamSetLabelData{..} -> do
|
||||
runDB . forM_ (Set.toList exams) $ either (\eeid -> void $ upsert (ExamOfficeExternalExamLabel eeid easlNewLabel) [ExamOfficeExternalExamLabelLabel =. easlNewLabel]) (\eid -> void $ upsert (ExamOfficeExamLabel eid easlNewLabel) [ExamOfficeExamLabelLabel =. easlNewLabel])
|
||||
addMessageI Success $ MsgExamLabelsSet (Set.size exams)
|
||||
redirect $ ExamOfficeR EOExamsR
|
||||
ExamRemoveLabelData -> do
|
||||
runDB . forM_ (Set.toList exams) $ either delete delete
|
||||
addMessageI Success $ MsgExamLabelsRemoved (Set.size exams)
|
||||
redirect $ ExamOfficeR EOExamsR
|
||||
|
||||
siteLayoutMsg MsgHeadingExamList $ do
|
||||
setTitleI MsgHeadingExamList
|
||||
|
||||
Reference in New Issue
Block a user