Skip to content

haskell-gargantext
haskell-gargantext
Unverified Commit 1bc15610 authored by Nicolas Pouillard's avatar Nicolas Pouillard
Browse files
Options

Use HyperdataAny instead of Value, improve instances

parent 871b48ee
Hide whitespace changes
Inline Side-by-side
Showing with 93 additions and 78 deletions
src/Gargantext/API.hs
View file @ 1bc15610
......@@ -45,7 +45,6 @@ import GHC.Generics (D1, Meta (..), Rep)
import GHC.TypeLits (AppendSymbol, Symbol)
import Control.Lens
import Data.Aeson (Value)
import Data.Aeson.Encode.Pretty (encodePretty)
import qualified Data.ByteString.Lazy.Char8 as BL8
import Data.Swagger
......@@ -71,7 +70,9 @@ import Gargantext.API.Node ( Roots , roots
, NodesAPI , nodesAPI
, GraphAPI , graphAPI
, TreeAPI , treeAPI
, HyperdataAny
, HyperdataCorpus
, HyperdataAnnuaire
)
import Gargantext.Database.Types.Node ()
import Gargantext.API.Count ( CountAPI, count, Query)
......@@ -208,12 +209,16 @@ type GargAPI' =
-- Node endpoint
:<|> "node" :> Summary "Node endpoint"
:> Capture "id" Int :> NodeAPI Value
:> Capture "id" Int :> NodeAPI HyperdataAny
-- Corpus endpoint
:<|> "corpus":> Summary "Corpus endpoint"
:> Capture "id" Int :> NodeAPI HyperdataCorpus
-- Annuaire endpoint
:<|> "annuaire":> Summary "Annuaire endpoint"
:> Capture "id" Int :> NodeAPI HyperdataAnnuaire
-- Corpus endpoint
:<|> "nodes" :> Summary "Nodes endpoint"
:> ReqBody '[JSON] [Int] :> NodesAPI
......@@ -256,8 +261,9 @@ server env = do
-- orchestrator <- scrapyOrchestrator env
pure $ swaggerFront
:<|> roots conn
:<|> nodeAPI conn (Proxy :: Proxy Value)
:<|> nodeAPI conn (Proxy :: Proxy HyperdataAny)
:<|> nodeAPI conn (Proxy :: Proxy HyperdataCorpus)
:<|> nodeAPI conn (Proxy :: Proxy HyperdataAnnuaire)
:<|> nodesAPI conn
:<|> count -- TODO: undefined
:<|> search conn
......
src/Gargantext/API/Node.hs
View file @ 1bc15610
......@@ -23,6 +23,8 @@ Node API
-------------------------------------------------------------------
module Gargantext.API.Node
( module Gargantext.API.Node
, HyperdataAny(..)
, HyperdataAnnuaire(..)
, HyperdataCorpus(..)
, HyperdataResource(..)
, HyperdataUser(..)
......@@ -37,7 +39,7 @@ import Control.Monad ((>>))
--import System.IO (putStrLn, readFile)
import Data.Either(Either(Left))
import Data.Aeson (FromJSON, ToJSON, Value())
import Data.Aeson (FromJSON, ToJSON)
--import Data.Text (Text(), pack)
import Data.Text (Text())
import Data.Swagger
......@@ -83,7 +85,7 @@ nodesAPI conn ids = deleteNodes' conn ids
------------------------------------------------------------------------
-- | TODO: access by admin only
-- To manager the Users roots
type Roots = Get '[JSON] [Node Value]
type Roots = Get '[JSON] [NodeAny]
:<|> Post '[JSON] Int -- TODO
:<|> Put '[JSON] Int -- TODO
:<|> Delete '[JSON] Int -- TODO
......
src/Gargantext/Database/Bashql.hs
View file @ 1bc15610
......@@ -77,7 +77,6 @@ module Gargantext.Database.Bashql ( get
import Control.Monad.Reader -- (Reader, ask)
import Data.Text (Text)
import Data.Aeson
import Data.List (concat, last)
import Gargantext.Core.Types
......@@ -101,7 +100,7 @@ mv :: NodeId -> ParentId -> Cmd [Int]
mv n p = mkCmd $ \conn -> U.update (U.Move n p) conn
-- | TODO get Children or Node
get :: PWD -> Cmd [Node Value]
get :: PWD -> Cmd [NodeAny]
get [] = pure []
get pwd = Cmd . ReaderT $ \conn -> runQuery conn $ selectNodesWithParentID (last pwd)
......@@ -110,10 +109,10 @@ home :: Cmd PWD
home = map _node_id <$> Cmd (ReaderT (getNodesWithParentId 0 Nothing))
-- | ls == get Children
ls :: PWD -> Cmd [Node Value]
ls :: PWD -> Cmd [NodeAny]
ls = get
tree :: PWD -> Cmd [Node Value]
tree :: PWD -> Cmd [NodeAny]
tree p = do
ns <- get p
children <- mapM (\n -> get [_node_id n]) ns
......
src/Gargantext/Database/Node.hs
View file @ 1bc15610
......@@ -95,6 +95,9 @@ type DocId = Int
type UserId = Int
type TypeId = Int
------------------------------------------------------------------------
instance FromField HyperdataAny where
fromField = fromField'
instance FromField HyperdataCorpus where
fromField = fromField'
......@@ -106,7 +109,13 @@ instance FromField HyperdataDocumentV3 where
instance FromField HyperdataUser where
fromField = fromField'
instance FromField HyperdataAnnuaire where
fromField = fromField'
------------------------------------------------------------------------
instance QueryRunnerColumnDefault PGJsonb HyperdataAny where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault PGJsonb HyperdataDocument where
queryRunnerColumnDefault = fieldQueryRunnerColumn
......@@ -118,6 +127,9 @@ instance QueryRunnerColumnDefault PGJsonb HyperdataCorpus where
instance QueryRunnerColumnDefault PGJsonb HyperdataUser where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault PGJsonb HyperdataAnnuaire where
queryRunnerColumnDefault = fieldQueryRunnerColumn
------------------------------------------------------------------------
fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
......@@ -184,7 +196,7 @@ selectNode id = proc () -> do
restrict -< _node_id row .== id
returnA -< row
runGetNodes :: Query NodeRead -> Cmd [Node Value]
runGetNodes :: Query NodeRead -> Cmd [NodeAny]
runGetNodes q = mkCmd $ \conn -> runQuery conn q
------------------------------------------------------------------------
......@@ -248,11 +260,11 @@ getNodesWith conn parentId _ nodeType maybeOffset maybeLimit =
-- NP check type
getNodesWithParentId :: Int
-> Maybe Text -> Connection -> IO [Node Value]
-> Maybe Text -> Connection -> IO [NodeAny]
getNodesWithParentId n _ conn = runQuery conn $ selectNodesWithParentID n
getNodesWithParentId' :: Int
-> Maybe Text -> Connection -> IO [Node Value]
-> Maybe Text -> Connection -> IO [NodeAny]
getNodesWithParentId' n _ conn = runQuery conn $ selectNodesWithParentID n
......
src/Gargantext/Database/Types/Node.hs
View file @ 1bc15610
......@@ -11,17 +11,18 @@ Portability : POSIX
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
-- {-# LANGUAGE DuplicateRecordFields #-}
module Gargantext.Database.Types.Node where
import Prelude (Enum, Bounded, minBound, maxBound, mempty)
import Prelude (Enum, Bounded, minBound, maxBound)
import GHC.Generics (Generic)
......@@ -30,11 +31,13 @@ import qualified Control.Lens as L
import Control.Applicative ((<*>))
import Data.Aeson
import Data.Aeson (Value(),toJSON)
import Data.Aeson.Types (emptyObject)
import Data.Aeson (Object, toJSON)
import Data.Aeson.TH (deriveJSON)
import Data.ByteString.Lazy (ByteString)
import Data.Either
import Data.Eq (Eq)
import Data.Monoid (mempty)
import Data.Text (Text, unpack)
import Data.Time (UTCTime)
import Data.Time.Segment (jour, timesAfter, Granularity(D))
......@@ -221,17 +224,44 @@ data HyperdataCorpus = HyperdataCorpus { hyperdataCorpus_title :: Maybe T
} deriving (Show, Generic)
$(deriveJSON (unPrefix "hyperdataCorpus_") ''HyperdataCorpus)
corpusExample :: ByteString
corpusExample = "" -- TODO
defaultCorpus :: HyperdataCorpus
defaultCorpus = (HyperdataCorpus (Just "Title") (Just "Descr") (Just "Bool query") (Just "Authors") Nothing)
hyperdataCorpus :: HyperdataCorpus
hyperdataCorpus = case decode corpusExample of
Just hp -> hp
Nothing -> defaultCorpus
instance Arbitrary HyperdataCorpus where
arbitrary = pure hyperdataCorpus -- TODO
------------------------------------------------------------------------
data HyperdataAnnuaire = HyperdataAnnuaire { hyperdataAnnuaire_title :: Maybe Text
, hyperdataAnnuaire_desc :: Maybe Text
} deriving (Show, Generic)
$(deriveJSON (unPrefix "hyperdataAnnuaire_") ''HyperdataAnnuaire)
hyperdataAnnuaire :: HyperdataAnnuaire
hyperdataAnnuaire = HyperdataAnnuaire (Just "Annuaire Title") (Just "Annuaire Description")
instance Arbitrary HyperdataAnnuaire where
arbitrary = pure hyperdataAnnuaire -- TODO
------------------------------------------------------------------------
data HyperdataContact = HyperdataContact { hyperdataContact_name :: Maybe Text
, hyperdataContact_mail :: Maybe Text
} deriving (Show, Generic)
$(deriveJSON (unPrefix "hyperdataContact_") ''HyperdataContact)
------------------------------------------------------------------------
newtype HyperdataAny = HyperdataAny Object
deriving (Show, Generic, ToJSON, FromJSON)
instance Arbitrary HyperdataAny where
arbitrary = pure $ HyperdataAny mempty -- TODO produce arbitrary objects
------------------------------------------------------------------------
data HyperdataList = HyperdataList { hyperdataList_preferences :: Maybe Text
} deriving (Show, Generic)
......@@ -279,6 +309,8 @@ type NodeName = Text
--type NodeUser = Node HyperdataUser
type NodeAny = Node HyperdataAny
-- | Then a Node can be either a Folder or a Corpus or a Document
type NodeUser = Node HyperdataUser
type NodeFolder = Node HyperdataFolder
......@@ -334,23 +366,11 @@ data NodePoly id typename userId parentId name date hyperdata = Node { _node_id
$(deriveJSON (unPrefix "_node_") ''NodePoly)
$(makeLenses ''NodePoly)
instance Arbitrary hyperdata => Arbitrary (NodePoly NodeId NodeTypeId (Maybe NodeUserId) NodeParentId NodeName UTCTime hyperdata) where
arbitrary = Node 1 1 (Just 1) 1 "name" (jour 2018 01 01) <$> arbitrary
instance Arbitrary (NodePoly NodeId NodeTypeId (Maybe NodeUserId) NodeParentId NodeName UTCTime Value) where
arbitrary = elements [Node 1 1 (Just 1) 1 "name" (jour 2018 01 01) (Object mempty)]
instance Arbitrary (NodePoly NodeId NodeTypeId NodeUserId (Maybe NodeParentId) NodeName UTCTime Value) where
arbitrary = elements [Node 1 1 1 (Just 1) "name" (jour 2018 01 01) (Object mempty)]
instance Arbitrary (NodePoly NodeId NodeTypeId (Maybe NodeUserId) NodeParentId NodeName UTCTime HyperdataDocument) where
arbitrary = elements [Node 1 1 (Just 1) 1 "name" (jour 2018 01 01) ((hyperdataDocument))]
instance Arbitrary (NodePoly NodeId NodeTypeId NodeUserId (Maybe NodeParentId) NodeName UTCTime HyperdataDocument) where
arbitrary = elements [Node 1 1 1 (Just 1) "name" (jour 2018 01 01) hyperdataDocument]
instance Arbitrary (NodePoly NodeId NodeTypeId NodeUserId (Maybe NodeParentId) NodeName UTCTime HyperdataCorpus) where
arbitrary = elements [Node 1 1 1 (Just 1) "name" (jour 2018 01 01) hyperdataCorpus]
instance Arbitrary hyperdata => Arbitrary (NodePoly NodeId NodeTypeId NodeUserId (Maybe NodeParentId) NodeName UTCTime hyperdata) where
arbitrary = Node 1 1 1 (Just 1) "name" (jour 2018 01 01) <$> arbitrary
------------------------------------------------------------------------
hyperdataDocument :: HyperdataDocument
......@@ -364,69 +384,45 @@ hyperdataDocument = case decode docExample of
docExample :: ByteString
docExample = "{\"doi\":\"sdfds\",\"publication_day\":6,\"language_iso2\":\"en\",\"publication_minute\":0,\"publication_month\":7,\"language_iso3\":\"eng\",\"publication_second\":0,\"authors\":\"Nils Hovdenak, Kjell Haram\",\"publication_year\":2012,\"publication_date\":\"2012-07-06 00:00:00+00:00\",\"language_name\":\"English\",\"realdate_full_\":\"2012 01 12\",\"source\":\"European journal of obstetrics, gynecology, and reproductive biology\",\"abstract\":\"The literature was searched for publications on minerals and vitamins during pregnancy and the possible influence of supplements on pregnancy outcome.\",\"title\":\"Influence of mineral and vitamin supplements on pregnancy outcome.\",\"publication_hour\":0}"
corpusExample :: ByteString
corpusExample = "" -- TODO
defaultCorpus :: HyperdataCorpus
defaultCorpus = (HyperdataCorpus (Just "Title") (Just "Descr") (Just "Bool query") (Just "Authors") Nothing)
hyperdataCorpus :: HyperdataCorpus
hyperdataCorpus = case decode corpusExample of
Just hp -> hp
Nothing -> defaultCorpus
instance ToSchema HyperdataCorpus where
declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
L.& mapped.schema.description ?~ "a corpus"
L.& mapped.schema.example ?~ toJSON hyperdataCorpus
instance ToSchema HyperdataDocument where
instance ToSchema HyperdataAnnuaire where
declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
L.& mapped.schema.description ?~ "a document"
L.& mapped.schema.example ?~ toJSON hyperdataDocument
L.& mapped.schema.description ?~ "an annuaire"
L.& mapped.schema.example ?~ toJSON hyperdataAnnuaire
instance ToSchema Value where
declareNamedSchema proxy = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions proxy
instance ToSchema HyperdataDocument where
declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
L.& mapped.schema.description ?~ "a document"
L.& mapped.schema.example ?~ toJSON ("" :: Text) -- TODO
L.& mapped.schema.example ?~ toJSON hyperdataDocument
instance ToSchema (NodePoly NodeId NodeTypeId NodeUserId
(Maybe NodeParentId) NodeName
UTCTime HyperdataDocument
)
instance ToSchema HyperdataAny where
declareNamedSchema proxy =
pure $ genericNameSchema defaultSchemaOptions proxy mempty
L.& schema.description ?~ "a node"
L.& schema.example ?~ emptyObject -- TODO
instance ToSchema (NodePoly NodeId NodeTypeId
(Maybe NodeUserId)
NodeParentId NodeName
UTCTime HyperdataDocument
)
instance ToSchema (NodePoly NodeId NodeTypeId
instance ToSchema hyperdata =>
ToSchema (NodePoly NodeId NodeTypeId
(Maybe NodeUserId)
NodeParentId NodeName
UTCTime HyperdataCorpus
UTCTime hyperdata
)
instance ToSchema (NodePoly NodeId NodeTypeId
(NodeUserId)
instance ToSchema hyperdata =>
ToSchema (NodePoly NodeId NodeTypeId
NodeUserId
(Maybe NodeParentId) NodeName
UTCTime HyperdataCorpus
UTCTime hyperdata
)
instance ToSchema (NodePoly NodeId NodeTypeId
(Maybe NodeUserId)
NodeParentId NodeName
UTCTime Value
)
instance ToSchema (NodePoly NodeId NodeTypeId
(NodeUserId)
(Maybe NodeParentId) NodeName
UTCTime Value
)
instance ToSchema Status
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment