From bd1b64b14492e7ca60112edec29f224f7e93b93b Mon Sep 17 00:00:00 2001
From: Nicolas Pouillard <np.t0@nicolaspouillard.fr>
Date: Thu, 2 Jul 2020 12:57:11 +0200
Subject: [PATCH] Fix ToSchema instances to workaround swagger2#issue94
---
src/Gargantext/API/Ngrams.hs | 10 +++++-----
src/Gargantext/Core/Types.hs | 8 ++++----
src/Gargantext/Core/Types/Main.hs | 6 +++---
src/Gargantext/Core/Utils/Prefix.hs | 6 +++++-
.../Database/Admin/Types/Hyperdata.hs | 6 +++---
.../Database/Admin/Types/Metrics.hs | 6 +++---
src/Gargantext/Database/Admin/Types/Node.hs | 19 ++++++++++---------
src/Gargantext/Database/Query/Facet.hs | 14 ++++++++++----
src/Gargantext/Prelude.hs | 2 ++
stack.yaml | 2 +-
10 files changed, 46 insertions(+), 33 deletions(-)
diff --git a/src/Gargantext/API/Ngrams.hs b/src/Gargantext/API/Ngrams.hs
index 006e72db..522f3ae8 100644
--- a/src/Gargantext/API/Ngrams.hs
+++ b/src/Gargantext/API/Ngrams.hs
@@ -116,7 +116,7 @@ import Formatting.Clock (timeSpecs)
import GHC.Generics (Generic)
import Gargantext.Core.Types (ListType(..), NodeId, ListId, DocId, Limit, Offset, HasInvalidError, assertValid)
import Gargantext.Core.Types (TODO)
-import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
+import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema)
import Gargantext.Database.Action.Metrics.NgramsByNode (getOccByNgramsOnlyFast')
import Gargantext.Database.Query.Table.Node.Select
import Gargantext.Database.Query.Table.Ngrams hiding (NgramsType(..), ngrams, ngramsType, ngrams_terms)
@@ -200,7 +200,7 @@ instance (Ord a, FromJSON a) => FromJSON (MSet a) where
instance (ToJSONKey a, ToSchema a) => ToSchema (MSet a) where
-- TODO
- declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy TODO)
+ declareNamedSchema _ = wellNamedSchema "" (Proxy :: Proxy TODO)
------------------------------------------------------------------------
type NgramsTerm = Text
@@ -492,7 +492,7 @@ instance (Ord a, Arbitrary a) => Arbitrary (PatchMSet a) where
instance ToSchema a => ToSchema (PatchMSet a) where
-- TODO
- declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy TODO)
+ declareNamedSchema _ = wellNamedSchema "" (Proxy :: Proxy TODO)
type instance Patched (PatchMSet a) = MSet a
@@ -665,8 +665,8 @@ data Versioned a = Versioned
deriving (Generic, Show, Eq)
deriveJSON (unPrefix "_v_") ''Versioned
makeLenses ''Versioned
-instance ToSchema a => ToSchema (Versioned a) where
- declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_v_")
+instance (Typeable a, ToSchema a) => ToSchema (Versioned a) where
+ declareNamedSchema = wellNamedSchema "_v_"
instance Arbitrary a => Arbitrary (Versioned a) where
arbitrary = Versioned 1 <$> arbitrary -- TODO 1 is constant so far
diff --git a/src/Gargantext/Core/Types.hs b/src/Gargantext/Core/Types.hs
index 5659c7e2..9f639151 100644
--- a/src/Gargantext/Core/Types.hs
+++ b/src/Gargantext/Core/Types.hs
@@ -34,13 +34,13 @@ import Data.Monoid
import Data.Semigroup
import Data.Set (Set, empty)
import Data.Swagger (ToParamSchema)
-import Data.Swagger (ToSchema(..), genericDeclareNamedSchema)
+import Data.Swagger (ToSchema(..))
import Data.Text (Text, unpack)
import Data.Validity
import GHC.Generics
import Gargantext.Core.Types.Main
import Gargantext.Database.Admin.Types.Node
-import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
+import Gargantext.Core.Utils.Prefix (unPrefix, wellNamedSchema)
import Gargantext.Prelude
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
@@ -150,8 +150,8 @@ data TableResult a = TableResult { tr_count :: Int
$(deriveJSON (unPrefix "tr_") ''TableResult)
-instance ToSchema a => ToSchema (TableResult a) where
- declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "tr_")
+instance (Typeable a, ToSchema a) => ToSchema (TableResult a) where
+ declareNamedSchema = wellNamedSchema "tr_"
instance Arbitrary a => Arbitrary (TableResult a) where
arbitrary = TableResult <$> arbitrary <*> arbitrary
diff --git a/src/Gargantext/Core/Types/Main.hs b/src/Gargantext/Core/Types/Main.hs
index 0c32ef04..1462359c 100644
--- a/src/Gargantext/Core/Types/Main.hs
+++ b/src/Gargantext/Core/Types/Main.hs
@@ -26,7 +26,7 @@ import Data.Monoid ((<>))
import Data.Swagger
import Data.Text (Text, unpack)
import GHC.Generics (Generic)
-import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
+import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema)
import Gargantext.Database.Admin.Types.Node -- (NodeType(..), Node, Hyperdata(..))
import Gargantext.Prelude
import Prelude (Enum, Bounded, minBound, maxBound)
@@ -98,8 +98,8 @@ data Tree a = TreeN { _tn_node :: a, _tn_children :: [Tree a] }
$(deriveJSON (unPrefix "_tn_") ''Tree)
-instance ToSchema a => ToSchema (Tree a) where
- declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_tn_")
+instance (Typeable a, ToSchema a) => ToSchema (Tree a) where
+ declareNamedSchema = wellNamedSchema "_tn_"
instance Arbitrary (Tree NodeTree) where
arbitrary = elements [userTree, userTree]
diff --git a/src/Gargantext/Core/Utils/Prefix.hs b/src/Gargantext/Core/Utils/Prefix.hs
index d669b0d3..5d7d980f 100644
--- a/src/Gargantext/Core/Utils/Prefix.hs
+++ b/src/Gargantext/Core/Utils/Prefix.hs
@@ -12,7 +12,10 @@ commentary with @some markup@.
-}
-module Gargantext.Core.Utils.Prefix where
+module Gargantext.Core.Utils.Prefix
+ ( module Gargantext.Core.Utils.Prefix
+ , wellNamedSchema
+ ) where
import Prelude
@@ -22,6 +25,7 @@ import Data.Aeson.Types (Parser)
import Data.Char (toLower)
import Data.Monoid ((<>))
import Data.Swagger.SchemaOptions (SchemaOptions, fromAesonOptions)
+import Servant.Job.Utils (wellNamedSchema)
import Text.Read (Read(..),readMaybe)
diff --git a/src/Gargantext/Database/Admin/Types/Hyperdata.hs b/src/Gargantext/Database/Admin/Types/Hyperdata.hs
index 43cea68b..5a164729 100644
--- a/src/Gargantext/Database/Admin/Types/Hyperdata.hs
+++ b/src/Gargantext/Database/Admin/Types/Hyperdata.hs
@@ -29,7 +29,7 @@ import Test.QuickCheck.Arbitrary
import Gargantext.API.Ngrams.NTree (MyTree)
import Gargantext.Database.Admin.Types.Metrics (ChartMetrics(..), Metrics)
import Gargantext.Database.Prelude (fromField')
-import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
+import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema)
import Gargantext.Viz.Phylo (Phylo(..))
import Gargantext.Viz.Types (Histo(..))
@@ -179,9 +179,9 @@ $(makeLenses ''HyperdataField)
defaultHyperdataField :: HyperdataField CorpusField
defaultHyperdataField = HyperdataField Markdown "name" defaultCorpusField
-instance (ToSchema a) => ToSchema (HyperdataField a) where
+instance (Typeable a, ToSchema a) => ToSchema (HyperdataField a) where
declareNamedSchema =
- genericDeclareNamedSchema (unPrefixSwagger "_hf_")
+ wellNamedSchema "_hf_"
-- & mapped.schema.description ?~ "HyperdataField"
-- & mapped.schema.example ?~ toJSON defaultHyperdataField
diff --git a/src/Gargantext/Database/Admin/Types/Metrics.hs b/src/Gargantext/Database/Admin/Types/Metrics.hs
index 16c31977..30661c60 100644
--- a/src/Gargantext/Database/Admin/Types/Metrics.hs
+++ b/src/Gargantext/Database/Admin/Types/Metrics.hs
@@ -11,7 +11,7 @@ import Protolude
import Test.QuickCheck.Arbitrary
import Gargantext.Core.Types (ListType(..))
-import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
+import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema)
----------------------------------------------------------------------------
@@ -48,8 +48,8 @@ deriveJSON (unPrefix "m_") ''Metric
data ChartMetrics a = ChartMetrics { chartMetrics_data :: a }
deriving (Generic, Show)
-instance (ToSchema a) => ToSchema (ChartMetrics a) where
- declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "chartMetrics_")
+instance (Typeable a, ToSchema a) => ToSchema (ChartMetrics a) where
+ declareNamedSchema = wellNamedSchema "chartMetrics_"
instance (Arbitrary a) => Arbitrary (ChartMetrics a)
where
arbitrary = ChartMetrics <$> arbitrary
diff --git a/src/Gargantext/Database/Admin/Types/Node.hs b/src/Gargantext/Database/Admin/Types/Node.hs
index ef12c0f8..03e323e5 100644
--- a/src/Gargantext/Database/Admin/Types/Node.hs
+++ b/src/Gargantext/Database/Admin/Types/Node.hs
@@ -29,6 +29,7 @@ import Data.Eq (Eq)
import Data.Swagger
import Data.Text (Text, unpack)
import Data.Time (UTCTime)
+import Data.Typeable (Typeable)
import Database.PostgreSQL.Simple.FromField (FromField, fromField)
import Database.PostgreSQL.Simple.ToField (ToField, toField)
import GHC.Generics (Generic)
@@ -43,7 +44,7 @@ import Test.QuickCheck.Instances.Time ()
import Text.Read (read)
import Text.Show (Show())
-import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
+import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema)
import Gargantext.Database.Prelude (fromField')
import Gargantext.Database.Schema.Node
import Gargantext.Prelude
@@ -60,37 +61,37 @@ type NodeSearch json = NodePolySearch NodeId NodeTypeId UserId (Maybe ParentId
------------------------------------------------------------------------
-instance ToSchema hyperdata =>
+instance (Typeable hyperdata, ToSchema hyperdata) =>
ToSchema (NodePoly NodeId NodeTypeId
(Maybe UserId)
ParentId NodeName
UTCTime hyperdata
) where
- declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_node_")
+ declareNamedSchema = wellNamedSchema "_node_"
-instance ToSchema hyperdata =>
+instance (Typeable hyperdata, ToSchema hyperdata) =>
ToSchema (NodePoly NodeId NodeTypeId
UserId
(Maybe ParentId) NodeName
UTCTime hyperdata
) where
- declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_node_")
+ declareNamedSchema = wellNamedSchema "_node_"
-instance ToSchema hyperdata =>
+instance (Typeable hyperdata, ToSchema hyperdata) =>
ToSchema (NodePolySearch NodeId NodeTypeId
(Maybe UserId)
ParentId NodeName
UTCTime hyperdata (Maybe TSVector)
) where
- declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_ns_")
+ declareNamedSchema = wellNamedSchema "_ns_"
-instance ToSchema hyperdata =>
+instance (Typeable hyperdata, ToSchema hyperdata) =>
ToSchema (NodePolySearch NodeId NodeTypeId
UserId
(Maybe ParentId) NodeName
UTCTime hyperdata (Maybe TSVector)
) where
- declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_ns_")
+ declareNamedSchema = wellNamedSchema "_ns_"
instance (Arbitrary hyperdata
,Arbitrary nodeId
diff --git a/src/Gargantext/Database/Query/Facet.hs b/src/Gargantext/Database/Query/Facet.hs
index 9363ba2c..2e80d909 100644
--- a/src/Gargantext/Database/Query/Facet.hs
+++ b/src/Gargantext/Database/Query/Facet.hs
@@ -44,6 +44,7 @@ import Data.Swagger
import Data.Text (Text)
import Data.Time (UTCTime)
import Data.Time.Segment (jour)
+import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Opaleye
import Prelude hiding (null, id, map, sum, not, read)
@@ -53,7 +54,7 @@ import Test.QuickCheck.Arbitrary
import qualified Opaleye.Internal.Unpackspec()
import Gargantext.Core.Types
-import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
+import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema)
import Gargantext.Database.Admin.Config (nodeTypeId)
import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Query.Filter
@@ -105,8 +106,8 @@ data Pair i l = Pair {_p_id :: i
$(deriveJSON (unPrefix "_p_") ''Pair)
$(makeAdaptorAndInstance "pPair" ''Pair)
-instance (ToSchema i, ToSchema l) => ToSchema (Pair i l) where
- declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_p_")
+instance (Typeable i, Typeable l, ToSchema i, ToSchema l) => ToSchema (Pair i l) where
+ declareNamedSchema = wellNamedSchema "_p_"
instance (Arbitrary i, Arbitrary l) => Arbitrary (Pair i l) where
arbitrary = Pair <$> arbitrary <*> arbitrary
@@ -125,8 +126,13 @@ instance ( ToSchema id
, ToSchema hyperdata
, ToSchema score
, ToSchema pair
+ , Typeable id
+ , Typeable date
+ , Typeable hyperdata
+ , Typeable score
+ , Typeable pair
) => ToSchema (FacetPaired id date hyperdata score pair) where
- declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_fp_")
+ declareNamedSchema = wellNamedSchema "_fp_"
instance ( Arbitrary id
, Arbitrary date
diff --git a/src/Gargantext/Prelude.hs b/src/Gargantext/Prelude.hs
index 75548393..e7edb4c3 100644
--- a/src/Gargantext/Prelude.hs
+++ b/src/Gargantext/Prelude.hs
@@ -26,6 +26,7 @@ module Gargantext.Prelude
, sortWith
, module Prelude
, MonadBase(..)
+ , Typeable
)
where
@@ -36,6 +37,7 @@ import GHC.Real (round)
import Data.Map (Map, lookup)
import Data.Maybe (isJust, fromJust, maybe)
import Data.Text (Text)
+import Data.Typeable (Typeable)
import Protolude ( Bool(True, False), Int, Int64, Double, Integer
, Fractional, Num, Maybe(Just,Nothing)
, Enum, Bounded, Float
diff --git a/stack.yaml b/stack.yaml
index 1c4e5608..3207ec0d 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -47,7 +47,7 @@ extra-deps:
#- git: https://github.com/delanoe/servant-job.git
#commit: 7a7b7100e6d132adb4c11b25b2128e6309690ac0
- git: https://github.com/np/servant-job.git
- commit: 5b994e20e90e344b67368b8c6ae3bd917322a35e
+ commit: 6487744c322baaa9229fdabd321a878a5b363c61
- git: https://gitlab.iscpif.fr/gargantext/clustering-louvain.git
commit: 7d74f96dfea8e51fbab1793cc0429b2fe741f73d
- git: https://github.com/np/patches-map
--
2.21.0