From ac1c41f5867d6229748c98f617c5f4d36464f6b2 Mon Sep 17 00:00:00 2001 From: Karol Kaczmarek Date: Sat, 11 Jul 2020 14:14:35 +0200 Subject: [PATCH] Add simple annotation option --- Application.hs | 1 + Handler/Annotations.hs | 114 +++++++++++++++++++++++ config/routes | 5 + gonito.cabal | 1 + messages/en.msg | 1 + templates/annotation-task-results.hamlet | 9 ++ templates/annotation-task.hamlet | 19 ++++ templates/annotation-task.lucius | 3 + templates/default-layout.hamlet | 1 + templates/list-annotations.hamlet | 5 + 10 files changed, 159 insertions(+) create mode 100644 Handler/Annotations.hs create mode 100644 templates/annotation-task-results.hamlet create mode 100644 templates/annotation-task.hamlet create mode 100644 templates/annotation-task.lucius create mode 100644 templates/list-annotations.hamlet diff --git a/Application.hs b/Application.hs index ab3b050..e93376d 100644 --- a/Application.hs +++ b/Application.hs @@ -53,6 +53,7 @@ import Handler.AccountReset import Handler.Presentation import Handler.Tags import Handler.EditSubmission +import Handler.Annotations import Handler.Achievements import Handler.Score import Handler.ExtraPoints diff --git a/Handler/Annotations.hs b/Handler/Annotations.hs new file mode 100644 index 0000000..6dd20ba --- /dev/null +++ b/Handler/Annotations.hs @@ -0,0 +1,114 @@ +module Handler.Annotations where + +import Import + +import qualified Database.Esqueleto as E + +import qualified Yesod.Table as Table +import Handler.Tables (timestampCell) + + +getListAnnotationsR :: Handler Html +getListAnnotationsR = do + annotations <- runDB $ selectList [] [Asc AnnotationTaskId] + + defaultLayout $ do + setTitle "List annotation tasks" + $(widgetFile "list-annotations") + + + +getAnnotationTaskR :: AnnotationTaskId -> Handler Html +getAnnotationTaskR annotationTaskId = do + (Entity userId _) <- requireAuth + + annotationTask <- runDB $ get annotationTaskId + + -- Get all labels + labels <- runDB $ selectList [AnnotationLabelAnnotationTask ==. annotationTaskId] [Asc AnnotationLabelOrder] + + -- Get list of user decisions for this annotation task + taskDecisionIds' <- runDB $ E.select + $ E.from $ \(annotationItem `E.InnerJoin` annotationDecision) -> do + E.on (annotationItem E.^. AnnotationItemId E.==. annotationDecision E.^. AnnotationDecisionAnnotationItem) + E.where_ (annotationItem E.^. AnnotationItemAnnotationTask E.==. E.val annotationTaskId + E.&&. annotationDecision E.^. AnnotationDecisionUser E.==. E.val userId) + return $ annotationDecision E.^. AnnotationDecisionAnnotationItem + let decisionLength = length taskDecisionIds' + + -- Get number of items for this annotation task + taskItemsLength <- runDB $ count [AnnotationItemAnnotationTask ==. annotationTaskId] + + -- Get first item to annotate which was not annotated + let taskDecisionIds = map E.unValue taskDecisionIds' + maybeItem <- runDB $ selectFirst [AnnotationItemAnnotationTask ==. annotationTaskId, + AnnotationItemId /<-. taskDecisionIds] [Asc AnnotationItemOrder] + let allDone = decisionLength == taskItemsLength && decisionLength > 0 + + defaultLayout $ do + setTitle "Annotation task" + $(widgetFile "annotation-task") + + +postAnnotationTaskDecisionR :: AnnotationTaskId -> AnnotationItemId -> AnnotationLabelId -> Handler Html +postAnnotationTaskDecisionR annotationTaskId itemId labelId = do + (Entity userId _) <- requireAuth + now <- liftIO getCurrentTime + label <- runDB $ get404 labelId + + -- Check decision exists + maybeSaveDecision <- runDB $ selectFirst [AnnotationDecisionAnnotationItem ==. itemId, + AnnotationDecisionUser ==. userId] [] + case maybeSaveDecision of + -- Update if exists + Nothing -> do + _ <- runDB $ insert $ AnnotationDecision itemId userId (annotationLabelValue label) now + return () + -- Insert new + Just (Entity saveDecisionId _) -> do + _ <- runDB $ updateWhere [AnnotationDecisionId ==. saveDecisionId] [AnnotationDecisionValue =. annotationLabelValue label, + AnnotationDecisionStamp =. now] + return () + + -- Redirect to annotation page + redirect $ AnnotationTaskR annotationTaskId + + +getAnnotationTaskResultsR :: AnnotationTaskId -> Handler Html +getAnnotationTaskResultsR annotationTaskId = do + results <- runDB $ E.select + $ E.from $ \(annotationDecision `E.InnerJoin` annotationItem) -> do + E.on (annotationDecision E.^. AnnotationDecisionAnnotationItem E.==. annotationItem E.^. AnnotationItemId) + E.where_ (annotationItem E.^. AnnotationItemAnnotationTask E.==. E.val annotationTaskId) + E.orderBy [E.asc (annotationItem E.^. AnnotationItemOrder), + E.asc (annotationDecision E.^. AnnotationDecisionUser)] + return (annotationItem E.^. AnnotationItemContent, + annotationItem E.^. AnnotationItemOrder, + annotationDecision E.^. AnnotationDecisionValue) + + labels <- runDB $ selectList [AnnotationLabelAnnotationTask ==. annotationTaskId] [Asc AnnotationLabelOrder] + + defaultLayout $ do + setTitle "Annotation task results" + $(widgetFile "annotation-task-results") + + +annotationListTable :: Table.Table App (Entity AnnotationTask) +annotationListTable = mempty + ++ Table.text "Name" (annotationTaskName . entityVal) + ++ Table.linked "Annotation link" (const "Annotation link") (AnnotationTaskR . entityKey) + ++ Table.linked "Results link" (const "Results link") (AnnotationTaskResultsR . entityKey) + ++ timestampCell "Date added" (annotationTaskAdded . entityVal) + + +annotationResultsTable :: Table.Table App (E.Value Text, E.Value Int, E.Value Text) +annotationResultsTable = mempty + ++ Table.int "ID" (\(_, order, _) -> E.unValue order) + ++ Table.text "Answer value" (\(_, _, answer) -> E.unValue answer) + ++ Table.text "Text" (\(content, _, _) -> E.unValue content) + + +annotationLabelsTable :: Table.Table App (Entity AnnotationLabel) +annotationLabelsTable = mempty + ++ Table.text "Answer value" (annotationLabelValue . entityVal) + ++ Table.text "Text" (annotationLabelName . entityVal) diff --git a/config/routes b/config/routes index 74c6588..bcee45a 100644 --- a/config/routes +++ b/config/routes @@ -30,6 +30,11 @@ -- trigger by JSON payload (from e.g. GitLab or Gogs) /trigger-by-webhook/#Text/#Text TriggerByWebhookR POST +/list-anotations ListAnnotationsR GET +/annotation/#{AnnotationTaskId} AnnotationTaskR GET +/annotation/decision/#{AnnotationTaskId}/#{AnnotationItemId}/#{AnnotationLabelId} AnnotationTaskDecisionR POST +/annotation/results/#{AnnotationTaskId} AnnotationTaskResultsR GET + /indicator-graph-data/#IndicatorId IndicatorGraphDataR GET /q QueryFormR GET POST diff --git a/gonito.cabal b/gonito.cabal index 0a1c681..3f76d68 100644 --- a/gonito.cabal +++ b/gonito.cabal @@ -47,6 +47,7 @@ library Handler.Tags Handler.EditSubmission Handler.SubmissionView + Handler.Annotations Handler.Achievements Handler.TagUtils Handler.Score diff --git a/messages/en.msg b/messages/en.msg index bda1485..40321cf 100644 --- a/messages/en.msg +++ b/messages/en.msg @@ -91,3 +91,4 @@ UserIdentifier: user login/identifier AltRepoScheme: alternative git repo scheme (URL without the challenge name pointing to some external server) AltRepoSchemeTooltip: set this if you want to use an alternative git server for all your submissions ShouldChallengeBeValidated: validate challenge (do not switch off unless you have a good reason) +ShowAnnotations: show annotations \ No newline at end of file diff --git a/templates/annotation-task-results.hamlet b/templates/annotation-task-results.hamlet new file mode 100644 index 0000000..b493cc7 --- /dev/null +++ b/templates/annotation-task-results.hamlet @@ -0,0 +1,9 @@ +$if null results +

No results found! + +$else +

#{length results} results: + ^{Table.buildBootstrap annotationResultsTable results} + +

Value of Answers: + ^{Table.buildBootstrap annotationLabelsTable labels} diff --git a/templates/annotation-task.hamlet b/templates/annotation-task.hamlet new file mode 100644 index 0000000..4c6fab9 --- /dev/null +++ b/templates/annotation-task.hamlet @@ -0,0 +1,19 @@ +$maybe task <- annotationTask +

Annotation: #{annotationTaskName task} + + $maybe (Entity itemId itemData) <- maybeItem +

Progress: #{decisionLength} / #{taskItemsLength} +

#{annotationItemContent itemData} + + $forall (Entity labelId labelData) <- labels +
+