From 341d912ba805d0c38f8436e6461e347b5ff2b610 Mon Sep 17 00:00:00 2001
From: Filip Gralinski <filipg@amu.edu.pl>
Date: Thu, 11 Mar 2021 21:23:18 +0100
Subject: [PATCH] End-point for listing tags

---
 Foundation.hs      |  1 +
 Handler/Swagger.hs |  3 +++
 Handler/Tags.hs    | 61 ++++++++++++++++++++++++++++++++++++++++++++--
 config/routes      |  1 +
 4 files changed, 64 insertions(+), 2 deletions(-)

diff --git a/Foundation.hs b/Foundation.hs
index 8c4c408..9a83e70 100644
--- a/Foundation.hs
+++ b/Foundation.hs
@@ -179,6 +179,7 @@ instance Yesod App where
     isAuthorized (ChallengeSubmissionJsonR _) _ = return Authorized
     isAuthorized (ChallengeReadmeInMarkdownR _) _ = regularAuthorization
     isAuthorized (QueryJsonR _) _ = return Authorized
+    isAuthorized ListTagsJsonR _ = regularAuthorization
 
     isAuthorized (ChallengeGraphDataR _) _ = regularAuthorization
     isAuthorized (ChallengeDiscussionR _) _ = regularAuthorization
diff --git a/Handler/Swagger.hs b/Handler/Swagger.hs
index 5e8e9a3..2e98012 100644
--- a/Handler/Swagger.hs
+++ b/Handler/Swagger.hs
@@ -6,6 +6,8 @@ import Data.Swagger
 import Handler.ListChallenges
 import Handler.ShowChallenge
 import Handler.Query
+import Handler.Tags
+
 
 import Control.Lens hiding ((.=))
 
@@ -22,6 +24,7 @@ apiDescription = generalApi
                  <> queryApi
                  <> challengeSubmissionApi
                  <> versionInfoApi
+                 <> listTagsApi
 
 generalApi :: Swagger
 generalApi = (mempty :: Swagger)
diff --git a/Handler/Tags.hs b/Handler/Tags.hs
index 139f3d9..c3fe891 100644
--- a/Handler/Tags.hs
+++ b/Handler/Tags.hs
@@ -1,6 +1,8 @@
+{-# LANGUAGE OverloadedLists #-}
+
 module Handler.Tags where
 
-import Import
+import Import hiding (fromList, get)
 import Handler.Common (checkIfAdmin)
 import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs)
 
@@ -8,6 +10,55 @@ import qualified Yesod.Table as Table
 
 import Handler.TagUtils
 
+import Data.Swagger.Declare
+import Data.Swagger hiding (Tag, tags)
+import Data.Proxy as DPR
+import Control.Lens hiding ((.=))
+import Data.HashMap.Strict.InsOrd (fromList)
+
+instance ToJSON (Entity Tag) where
+    toJSON v = object
+        [ "name" .= (tagName $ entityVal v)
+        , "description" .= (tagDescription $ entityVal v)
+        , "id" .= (entityKey v)
+        ]
+
+instance ToSchema (Entity Tag) where
+  declareNamedSchema _ = do
+    stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String)
+    intSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Int)
+    return $ NamedSchema (Just "Tag") $ mempty
+        & type_ .~ SwaggerObject
+        & properties .~
+           fromList [  ("name", stringSchema)
+                     , ("description", stringSchema)
+                     , ("id", intSchema)
+                    ]
+        & required .~ [ "name", "description", "id" ]
+
+listTagsApi :: Swagger
+listTagsApi = spec & definitions .~ defs
+  where
+    (defs, spec) = runDeclare declareListTagsSwagger mempty
+
+declareListTagsSwagger :: Declare (Definitions Schema) Swagger
+declareListTagsSwagger = do
+  listTagsResponse      <- declareResponse (DPR.Proxy :: DPR.Proxy [Entity Tag])
+
+  return $ mempty
+    & paths .~
+        [ ("/api/list-tags", mempty & get ?~ (mempty
+                                              & produces ?~ MimeList ["application/json"]
+                                              & description ?~ "Returns the list of all tags"
+                                              & at 200 ?~ Inline listTagsResponse))
+        ]
+
+
+getListTagsJsonR :: Handler Value
+getListTagsJsonR = do
+  allTags <- fetchAllTags
+  return $ toJSON allTags
+
 getTagsR :: Handler Html
 getTagsR = do
   (formWidget, formEnctype) <- generateFormPost tagForm
@@ -39,8 +90,14 @@ canAddTags = do
     EverybodyCanAddNewTags -> return $ isJust mUser
 
 
+fetchAllTags :: (PersistQueryRead (YesodPersistBackend site),
+                YesodPersist site,
+                BaseBackend (YesodPersistBackend site) ~ SqlBackend)
+               => HandlerFor site [Entity Tag]
+fetchAllTags = runDB $ selectList [] [Asc TagName]
+
 doTags formWidget formEnctype = do
-  tags <- runDB $ selectList [] [Asc TagName]
+  tags <- fetchAllTags
   canTagsBeAdded <- canAddTags
   defaultLayout $ do
     setTitle "Tags"
diff --git a/config/routes b/config/routes
index 09af0a6..f6fb0f0 100644
--- a/config/routes
+++ b/config/routes
@@ -25,6 +25,7 @@
 /api/query/#Text QueryJsonR GET
 /api/challenge-info/#Text ChallengeInfoJsonR GET
 /api/version-info/#Text VersionInfoJsonR GET
+/api/list-tags ListTagsJsonR GET
 /list-archived-challenges ListArchivedChallengesR GET
 
 /my-teams MyTeamsR GET