Add simple annotation option

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

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)

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

gonito.cabal

@@ -47,6 +47,7 @@ library
                      Handler.Tags
                      Handler.EditSubmission
                      Handler.SubmissionView
+                     Handler.Annotations
                      Handler.Achievements
                      Handler.TagUtils
                      Handler.Score

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

templates/annotation-task-results.hamlet

@@ -0,0 +1,9 @@
+$if null results
+  <h2> No results found!
+
+$else
+  <h2> #{length results} results:
+  ^{Table.buildBootstrap annotationResultsTable results}
+
+  <h3> Value of Answers:
+  ^{Table.buildBootstrap annotationLabelsTable labels}

templates/annotation-task.hamlet

@@ -0,0 +1,19 @@
+$maybe task <- annotationTask
+  <h2> Annotation: #{annotationTaskName task}
+
+  $maybe (Entity itemId itemData) <- maybeItem
+    <h5> Progress: #{decisionLength} / #{taskItemsLength}
+    <h3> #{annotationItemContent itemData}
+
+    $forall (Entity labelId labelData) <- labels
+      <form method=post action=@{AnnotationTaskDecisionR annotationTaskId itemId labelId}>
+        <button .btn .btn-primary type="submit">#{annotationLabelName labelData}
+
+  $nothing
+    $if allDone
+      <h3> You've done all (#{decisionLength}) the annotations, congratulations!
+    $else
+      <h3> Annotation is not ready yet, come back later!
+
+$nothing
+  <h2> Nothing to do!

templates/annotation-task.lucius

@@ -0,0 +1,3 @@
+form {
+   display: inline-block;
+}

templates/default-layout.hamlet

@@ -36,6 +36,7 @@
                             <li><a href="@{ExtraPointsR}">_{MsgAddExtraPoints}</a>
                             <li><a href="@{CoursesITeachR}">_{MsgCoursesITeach}</a>
                             <li><a href="@{ListArchivedChallengesR}">_{MsgShowArchivedChallenges}</a>
+                            <li><a href="@{ListAnnotationsR}">_{MsgShowAnnotations}</a>
 
           <ul class="nav navbar-nav navbar-collapse collapse navbar-right">
             <li class="dropdown">

templates/list-annotations.hamlet

@@ -0,0 +1,5 @@
+$if null annotations
+  <h3> Not found annotation tasks!
+
+$else
+  ^{Table.buildBootstrap annotationListTable annotations}