Skip to content

haskell-gargantext
haskell-gargantext
Commit 4f6c0893 authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

[REFACT] Hyperdata and Node API (WIP)

parent b1b47e90
Pipeline #949 failed with stage
    Hide whitespace changes
    Inline Side-by-side
    Showing with 227 additions and 238 deletions
    src/Gargantext/Database/Action/Node.hs
    View file @ 4f6c0893
    ...@@ -28,6 +28,7 @@ import Gargantext.Database.Query.Table.Node ...@@ -28,6 +28,7 @@ import Gargantext.Database.Query.Table.Node
    import Gargantext.Database.Query.Table.Node.Error import Gargantext.Database.Query.Table.Node.Error
    import Gargantext.Database.Query.Table.Node.User import Gargantext.Database.Query.Table.Node.User
    import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata) import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
    import Gargantext.Viz.Graph (defaultHyperdataGraph)
    import Gargantext.Prelude import Gargantext.Prelude
    import Gargantext.Prelude.Utils (sha) import Gargantext.Prelude.Utils (sha)
    import Gargantext.Database.Prelude import Gargantext.Database.Prelude
    ...@@ -53,47 +54,47 @@ mkNodeWithParent _ Nothing _ _ = nodeError HasParent ...@@ -53,47 +54,47 @@ mkNodeWithParent _ Nothing _ _ = nodeError HasParent
    mkNodeWithParent NodeFolder (Just i) uId name = mkNodeWithParent NodeFolder (Just i) uId name =
    insertNodesWithParentR (Just i) [node NodeFolder name hd Nothing uId] insertNodesWithParentR (Just i) [node NodeFolder name hd Nothing uId]
    where where
    hd = defaultFolder hd = defaultHyperdataFolder
    mkNodeWithParent NodeFolderPrivate (Just i) uId _ = mkNodeWithParent NodeFolderPrivate (Just i) uId _ =
    insertNodesWithParentR (Just i) [node NodeFolderPrivate "Private" hd Nothing uId] insertNodesWithParentR (Just i) [node NodeFolderPrivate "Private" hd Nothing uId]
    where where
    hd = defaultFolder hd = defaultHyperdataFolder
    mkNodeWithParent NodeFolderShared (Just i) uId _ = mkNodeWithParent NodeFolderShared (Just i) uId _ =
    insertNodesWithParentR (Just i) [node NodeFolderShared "Shared" hd Nothing uId] insertNodesWithParentR (Just i) [node NodeFolderShared "Shared" hd Nothing uId]
    where where
    hd = defaultFolder hd = defaultHyperdataFolder
    mkNodeWithParent NodeFolderPublic (Just i) uId _ = mkNodeWithParent NodeFolderPublic (Just i) uId _ =
    insertNodesWithParentR (Just i) [node NodeFolderPublic "Public" hd Nothing uId] insertNodesWithParentR (Just i) [node NodeFolderPublic "Public" hd Nothing uId]
    where where
    hd = defaultFolder hd = defaultHyperdataFolder
    mkNodeWithParent NodeTeam (Just i) uId name = mkNodeWithParent NodeTeam (Just i) uId name =
    insertNodesWithParentR (Just i) [node NodeTeam name hd Nothing uId] insertNodesWithParentR (Just i) [node NodeTeam name hd Nothing uId]
    where where
    hd = defaultFolder hd = defaultHyperdataFolder
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    mkNodeWithParent NodeCorpus (Just i) uId name = mkNodeWithParent NodeCorpus (Just i) uId name =
    insertNodesWithParentR (Just i) [node NodeCorpus name hd Nothing uId] insertNodesWithParentR (Just i) [node NodeCorpus name hd Nothing uId]
    where where
    hd = defaultCorpus hd = defaultHyperdataCorpus
    mkNodeWithParent NodeAnnuaire (Just i) uId name = mkNodeWithParent NodeAnnuaire (Just i) uId name =
    insertNodesWithParentR (Just i) [node NodeAnnuaire name hd Nothing uId] insertNodesWithParentR (Just i) [node NodeAnnuaire name hd Nothing uId]
    where where
    hd = defaultAnnuaire hd = defaultHyperdataAnnuaire
    mkNodeWithParent NodeList (Just i) uId name = mkNodeWithParent NodeList (Just i) uId name =
    insertNodesWithParentR (Just i) [node NodeList name hd Nothing uId] insertNodesWithParentR (Just i) [node NodeList name hd Nothing uId]
    where where
    hd = defaultAnnuaire hd = defaultHyperdataAnnuaire
    mkNodeWithParent NodeGraph (Just i) uId name = mkNodeWithParent NodeGraph (Just i) uId name =
    insertNodesWithParentR (Just i) [node NodeGraph name hd Nothing uId] insertNodesWithParentR (Just i) [node NodeGraph name hd Nothing uId]
    where where
    hd = arbitraryGraph hd = defaultHyperdataGraph
    mkNodeWithParent NodeFrameWrite i u n = mkNodeWithParent NodeFrameWrite i u n =
    mkNodeWithParent_ConfigureHyperdata NodeFrameWrite i u n mkNodeWithParent_ConfigureHyperdata NodeFrameWrite i u n
    ...@@ -101,10 +102,12 @@ mkNodeWithParent NodeFrameWrite i u n = ...@@ -101,10 +102,12 @@ mkNodeWithParent NodeFrameWrite i u n =
    mkNodeWithParent NodeFrameCalc i u n = mkNodeWithParent NodeFrameCalc i u n =
    mkNodeWithParent_ConfigureHyperdata NodeFrameCalc i u n mkNodeWithParent_ConfigureHyperdata NodeFrameCalc i u n
    {-
    mkNodeWithParent n (Just i) uId name = mkNodeWithParent n (Just i) uId name =
    insertNodesWithParentR (Just i) [node NodeDashboard name (hasDefaultData n) Nothing uId] insertNodesWithParentR (Just i) [node NodeDashboard name (hasDefaultData n) Nothing uId]
    -}
    -- mkNodeWithParent _ _ _ _ = nodeError NotImplYet mkNodeWithParent _ _ _ _ = nodeError NotImplYet
    -- | Sugar to create a node, get his NodeId and update his Hyperdata after -- | Sugar to create a node, get his NodeId and update his Hyperdata after
    ...@@ -148,6 +151,3 @@ mkNodeWithParent_ConfigureHyperdata' nt (Just i) uId name = do ...@@ -148,6 +151,3 @@ mkNodeWithParent_ConfigureHyperdata' nt (Just i) uId name = do
    (_:_:_) -> nodeError MkNode (_:_:_) -> nodeError MkNode
    mkNodeWithParent_ConfigureHyperdata' _ _ _ _ = nodeError HasParent mkNodeWithParent_ConfigureHyperdata' _ _ _ _ = nodeError HasParent
    src/Gargantext/Database/Admin/Types/Hyperdata.hs
    View file @ 4f6c0893
    ...@@ -14,6 +14,7 @@ Portability : POSIX ...@@ -14,6 +14,7 @@ Portability : POSIX
    module Gargantext.Database.Admin.Types.Hyperdata module Gargantext.Database.Admin.Types.Hyperdata
    ( module Gargantext.Database.Admin.Types.Hyperdata.Corpus ( module Gargantext.Database.Admin.Types.Hyperdata.Corpus
    , module Gargantext.Database.Admin.Types.Hyperdata.Document , module Gargantext.Database.Admin.Types.Hyperdata.Document
    , module Gargantext.Database.Admin.Types.Hyperdata.List
    , module Gargantext.Database.Admin.Types.Hyperdata.Prelude , module Gargantext.Database.Admin.Types.Hyperdata.Prelude
    ) )
    where where
    ...@@ -21,3 +22,7 @@ module Gargantext.Database.Admin.Types.Hyperdata ...@@ -21,3 +22,7 @@ module Gargantext.Database.Admin.Types.Hyperdata
    import Gargantext.Database.Admin.Types.Hyperdata.Prelude (Hyperdata) import Gargantext.Database.Admin.Types.Hyperdata.Prelude (Hyperdata)
    import Gargantext.Database.Admin.Types.Hyperdata.Corpus import Gargantext.Database.Admin.Types.Hyperdata.Corpus
    import Gargantext.Database.Admin.Types.Hyperdata.Document import Gargantext.Database.Admin.Types.Hyperdata.Document
    import Gargantext.Database.Admin.Types.Hyperdata.List
    src/Gargantext/Database/Admin/Types/Hyperdata/Corpus.hs
    View file @ 4f6c0893
    ...@@ -23,12 +23,9 @@ Portability : POSIX ...@@ -23,12 +23,9 @@ Portability : POSIX
    module Gargantext.Database.Admin.Types.Hyperdata.Corpus module Gargantext.Database.Admin.Types.Hyperdata.Corpus
    where where
    import Gargantext.API.Ngrams.NTree (MyTree) import Gargantext.Prelude
    import Gargantext.Database.Admin.Types.Hyperdata.Prelude import Gargantext.Database.Admin.Types.Hyperdata.Prelude
    import Gargantext.Database.Admin.Types.Metrics (ChartMetrics(..), Metrics)
    import Gargantext.Viz.Phylo (Phylo(..)) import Gargantext.Viz.Phylo (Phylo(..))
    import Gargantext.Viz.Types (Histo(..))
    import Protolude hiding (ByteString)
    data CodeType = JSON | Markdown | Haskell data CodeType = JSON | Markdown | Haskell
    ...@@ -68,16 +65,6 @@ instance ToSchema CorpusField where ...@@ -68,16 +65,6 @@ instance ToSchema CorpusField where
    & mapped.schema.example ?~ toJSON defaultCorpusField & mapped.schema.example ?~ toJSON defaultCorpusField
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    data Chart =
    CDocsHistogram
    | CAuthorsPie
    | CInstitutesTree
    | CTermsMetrics
    deriving (Generic, Show, Eq)
    instance ToJSON Chart
    instance FromJSON Chart
    instance ToSchema Chart
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    data HyperdataField a = data HyperdataField a =
    ...@@ -107,6 +94,7 @@ $(makeLenses ''HyperdataCorpus) ...@@ -107,6 +94,7 @@ $(makeLenses ''HyperdataCorpus)
    instance Hyperdata HyperdataCorpus instance Hyperdata HyperdataCorpus
    type HyperdataFolder = HyperdataCorpus type HyperdataFolder = HyperdataCorpus
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    data HyperdataFrame = data HyperdataFrame =
    HyperdataFrame { base :: !Text HyperdataFrame { base :: !Text
    ...@@ -133,21 +121,18 @@ hyperdataCorpus = case decode corpusExample of ...@@ -133,21 +121,18 @@ hyperdataCorpus = case decode corpusExample of
    Just hp -> hp Just hp -> hp
    Nothing -> defaultCorpus Nothing -> defaultCorpus
    defaultHyperdataCorpus :: HyperdataCorpus
    defaultHyperdataCorpus = defaultCorpus
    defaultHyperdataFolder :: HyperdataFolder
    defaultHyperdataFolder = defaultHyperdataCorpus
    instance Arbitrary HyperdataCorpus where instance Arbitrary HyperdataCorpus where
    arbitrary = pure hyperdataCorpus -- TODO arbitrary = pure hyperdataCorpus -- TODO
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    data HyperdataList =
    HyperdataList { hd_chart :: !(Maybe (ChartMetrics Histo))
    , hd_list :: !(Maybe Text)
    , hd_pie :: !(Maybe (ChartMetrics Histo))
    , hd_scatter :: !(Maybe Metrics)
    , hd_tree :: !(Maybe (ChartMetrics [MyTree]))
    } deriving (Show, Generic)
    $(deriveJSON (unPrefix "hd_") ''HyperdataList)
    instance Hyperdata HyperdataList
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    data HyperdataAnnuaire = HyperdataAnnuaire { hyperdataAnnuaire_title :: !(Maybe Text) data HyperdataAnnuaire = HyperdataAnnuaire { hyperdataAnnuaire_title :: !(Maybe Text)
    , hyperdataAnnuaire_desc :: !(Maybe Text) , hyperdataAnnuaire_desc :: !(Maybe Text)
    ...@@ -156,11 +141,11 @@ $(deriveJSON (unPrefix "hyperdataAnnuaire_") ''HyperdataAnnuaire) ...@@ -156,11 +141,11 @@ $(deriveJSON (unPrefix "hyperdataAnnuaire_") ''HyperdataAnnuaire)
    instance Hyperdata HyperdataAnnuaire instance Hyperdata HyperdataAnnuaire
    hyperdataAnnuaire :: HyperdataAnnuaire defaultHyperdataAnnuaire :: HyperdataAnnuaire
    hyperdataAnnuaire = HyperdataAnnuaire (Just "Annuaire Title") (Just "Annuaire Description") defaultHyperdataAnnuaire = HyperdataAnnuaire (Just "Title") (Just "Description")
    instance Arbitrary HyperdataAnnuaire where instance Arbitrary HyperdataAnnuaire where
    arbitrary = pure hyperdataAnnuaire -- TODO arbitrary = pure defaultHyperdataAnnuaire -- TODO
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    newtype HyperdataAny = HyperdataAny Object newtype HyperdataAny = HyperdataAny Object
    ...@@ -171,34 +156,6 @@ instance Hyperdata HyperdataAny ...@@ -171,34 +156,6 @@ instance Hyperdata HyperdataAny
    instance Arbitrary HyperdataAny where instance Arbitrary HyperdataAny where
    arbitrary = pure $ HyperdataAny mempty -- TODO produce arbitrary objects arbitrary = pure $ HyperdataAny mempty -- TODO produce arbitrary objects
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    {-
    instance Arbitrary HyperdataList' where
    arbitrary = elements [HyperdataList' (Just "from list A")]
    -}
    ----
    data HyperdataListModel =
    HyperdataListModel { _hlm_params :: !(Int, Int)
    , _hlm_path :: !Text
    , _hlm_score :: !(Maybe Double)
    } deriving (Show, Generic)
    instance Hyperdata HyperdataListModel
    instance Arbitrary HyperdataListModel where
    arbitrary = elements [HyperdataListModel (100,100) "models/example.model" Nothing]
    $(deriveJSON (unPrefix "_hlm_") ''HyperdataListModel)
    $(makeLenses ''HyperdataListModel)
    ------------------------------------------------------------------------
    data HyperdataScore = HyperdataScore { hyperdataScore_preferences :: !(Maybe Text)
    } deriving (Show, Generic)
    $(deriveJSON (unPrefix "hyperdataScore_") ''HyperdataScore)
    instance Hyperdata HyperdataScore
    ------------------------------------------------------------------------
    data HyperdataResource = HyperdataResource { hyperdataResource_preferences :: !(Maybe Text) data HyperdataResource = HyperdataResource { hyperdataResource_preferences :: !(Maybe Text)
    } deriving (Show, Generic) } deriving (Show, Generic)
    $(deriveJSON (unPrefix "hyperdataResource_") ''HyperdataResource) $(deriveJSON (unPrefix "hyperdataResource_") ''HyperdataResource)
    ...@@ -212,20 +169,58 @@ instance Hyperdata HyperdataResource ...@@ -212,20 +169,58 @@ instance Hyperdata HyperdataResource
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    -- | TODO CLEAN -- | TODO CLEAN
    -- | TODO FEATURE: Notebook saved in the node -- | TODO FEATURE: Notebook saved in the node
    data HyperData = HyperdataTexts { hd_preferences :: !(Maybe Text)} data HyperdataTexts =
    | HyperdataList' { hd_preferences :: !(Maybe Text)} HyperdataTexts { ht_preferences :: !(Maybe Text)}
    | HyperdataDashboard { hd_preferences :: !(Maybe Text) deriving (Show, Generic)
    , hd_charts :: ![Chart]
    } instance Hyperdata HyperdataTexts
    | HyperdataNotebook { hd_preferences :: !(Maybe Text)} instance ToJSON HyperdataTexts
    | HyperdataPhylo { hd_preferences :: !(Maybe Text) instance FromJSON HyperdataTexts
    , hd_data :: !(Maybe Phylo)
    }
    defaultHyperdataTexts :: HyperdataTexts
    defaultHyperdataTexts = HyperdataTexts Nothing
    data HyperdataDashboard =
    HyperdataDashboard { hda_preferences :: !(Maybe Text)
    , hda_charts :: ![Chart]
    }
    deriving (Show, Generic) deriving (Show, Generic)
    $(deriveJSON (unPrefix "hd_") ''HyperData) instance Hyperdata HyperdataDashboard
    instance Hyperdata HyperData instance ToJSON HyperdataDashboard
    instance FromJSON HyperdataDashboard
    data HyperdataNotebook =
    HyperdataNotebook { hn_preferences :: !(Maybe Text)}
    deriving (Show, Generic)
    data HyperdataPhylo =
    HyperdataPhylo { hp_preferences :: !(Maybe Text)
    , hp_data :: !(Maybe Phylo)
    }
    deriving (Show, Generic)
    instance Hyperdata HyperdataPhylo
    instance ToJSON HyperdataPhylo
    instance FromJSON HyperdataPhylo
    defaultHyperdataPhylo :: HyperdataPhylo
    defaultHyperdataPhylo = HyperdataPhylo Nothing Nothing
    instance FromField HyperdataPhylo where
    fromField = fromField'
    instance QueryRunnerColumnDefault PGJsonb HyperdataPhylo
    where
    queryRunnerColumnDefault = fieldQueryRunnerColumn
    instance ToSchema HyperdataPhylo where
    declareNamedSchema proxy =
    genericDeclareNamedSchema (unPrefixSwagger "hp_") proxy
    & mapped.schema.description ?~ "Phylo"
    & mapped.schema.example ?~ toJSON defaultHyperdataPhylo
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    -- Instances -- Instances
    ...@@ -241,7 +236,7 @@ instance ToSchema HyperdataAnnuaire where ...@@ -241,7 +236,7 @@ instance ToSchema HyperdataAnnuaire where
    declareNamedSchema proxy = declareNamedSchema proxy =
    genericDeclareNamedSchema (unPrefixSwagger "hyperdataAnnuaire_") proxy genericDeclareNamedSchema (unPrefixSwagger "hyperdataAnnuaire_") proxy
    & mapped.schema.description ?~ "an annuaire" & mapped.schema.description ?~ "an annuaire"
    & mapped.schema.example ?~ toJSON hyperdataAnnuaire & mapped.schema.example ?~ toJSON defaultHyperdataAnnuaire
    instance ToSchema HyperdataAny where instance ToSchema HyperdataAny where
    declareNamedSchema proxy = declareNamedSchema proxy =
    ...@@ -258,44 +253,20 @@ instance FromField HyperdataCorpus ...@@ -258,44 +253,20 @@ instance FromField HyperdataCorpus
    where where
    fromField = fromField' fromField = fromField'
    instance FromField HyperData
    where
    fromField = fromField'
    instance FromField HyperdataListModel
    where
    fromField = fromField'
    instance FromField HyperdataAnnuaire instance FromField HyperdataAnnuaire
    where where
    fromField = fromField' fromField = fromField'
    instance FromField HyperdataList
    where
    fromField = fromField'
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    instance QueryRunnerColumnDefault PGJsonb HyperdataAny instance QueryRunnerColumnDefault PGJsonb HyperdataAny
    where where
    queryRunnerColumnDefault = fieldQueryRunnerColumn queryRunnerColumnDefault = fieldQueryRunnerColumn
    instance QueryRunnerColumnDefault PGJsonb HyperdataList
    where
    queryRunnerColumnDefault = fieldQueryRunnerColumn
    instance QueryRunnerColumnDefault PGJsonb HyperData
    where
    queryRunnerColumnDefault = fieldQueryRunnerColumn
    instance QueryRunnerColumnDefault PGJsonb HyperdataCorpus instance QueryRunnerColumnDefault PGJsonb HyperdataCorpus
    where where
    queryRunnerColumnDefault = fieldQueryRunnerColumn queryRunnerColumnDefault = fieldQueryRunnerColumn
    instance QueryRunnerColumnDefault PGJsonb HyperdataListModel
    where
    queryRunnerColumnDefault = fieldQueryRunnerColumn
    instance QueryRunnerColumnDefault PGJsonb HyperdataAnnuaire instance QueryRunnerColumnDefault PGJsonb HyperdataAnnuaire
    where where
    queryRunnerColumnDefault = fieldQueryRunnerColumn queryRunnerColumnDefault = fieldQueryRunnerColumn
    src/Gargantext/Database/Admin/Types/Hyperdata/Document.hs
    View file @ 4f6c0893
    ...@@ -76,18 +76,19 @@ data HyperdataDocument = HyperdataDocument { _hyperdataDocument_bdd ...@@ -76,18 +76,19 @@ data HyperdataDocument = HyperdataDocument { _hyperdataDocument_bdd
    } deriving (Show, Generic) } deriving (Show, Generic)
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    docExample :: ByteString defaultHyperdataDocument :: HyperdataDocument
    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}" defaultHyperdataDocument = case decode docExample of
    Just hp -> hp
    Nothing -> HyperdataDocument Nothing Nothing Nothing Nothing
    Nothing Nothing Nothing Nothing
    Nothing Nothing Nothing Nothing
    Nothing Nothing Nothing Nothing
    Nothing Nothing Nothing
    where
    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}"
    hyperdataDocument :: HyperdataDocument
    hyperdataDocument = case decode docExample of
    Just hp -> hp
    Nothing -> HyperdataDocument Nothing Nothing Nothing Nothing
    Nothing Nothing Nothing Nothing
    Nothing Nothing Nothing Nothing
    Nothing Nothing Nothing Nothing
    Nothing Nothing Nothing
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    -- Instances -- Instances
    ...@@ -99,7 +100,7 @@ instance ToSchema HyperdataDocument where ...@@ -99,7 +100,7 @@ instance ToSchema HyperdataDocument where
    declareNamedSchema proxy = declareNamedSchema proxy =
    genericDeclareNamedSchema (unPrefixSwagger "_hyperdataDocument_") proxy genericDeclareNamedSchema (unPrefixSwagger "_hyperdataDocument_") proxy
    & mapped.schema.description ?~ "a document" & mapped.schema.description ?~ "a document"
    & mapped.schema.example ?~ toJSON hyperdataDocument & mapped.schema.example ?~ toJSON defaultHyperdataDocument
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    instance FromField HyperdataDocument instance FromField HyperdataDocument
    where where
    ......
    src/Gargantext/Database/Admin/Types/Hyperdata/List.hs 0 → 100644
    View file @ 4f6c0893
    {-|
    Module : Gargantext.Database.Admin.Types.Hyperdata.List
    Description :
    Copyright : (c) CNRS, 2017-Present
    License : AGPL + CECILL v3
    Maintainer : team@gargantext.org
    Stability : experimental
    Portability : POSIX
    -}
    {-# LANGUAGE DeriveGeneric #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE GeneralizedNewtypeDeriving #-}
    {-# LANGUAGE MultiParamTypeClasses #-}
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE TemplateHaskell #-}
    module Gargantext.Database.Admin.Types.Hyperdata.List
    where
    import Gargantext.Prelude
    import Gargantext.Viz.Types (Histo(..))
    import Gargantext.API.Ngrams.NTree (MyTree)
    import Gargantext.Database.Admin.Types.Hyperdata.Prelude
    import Gargantext.Database.Admin.Types.Metrics (ChartMetrics(..), Metrics)
    ------------------------------------------------------------------------
    data HyperdataList =
    HyperdataList { hd_chart :: !(Maybe (ChartMetrics Histo))
    , hd_list :: !(Maybe Text)
    , hd_pie :: !(Maybe (ChartMetrics Histo))
    , hd_scatter :: !(Maybe Metrics)
    , hd_tree :: !(Maybe (ChartMetrics [MyTree]))
    } deriving (Show, Generic)
    $(deriveJSON (unPrefix "hd_") ''HyperdataList)
    instance Hyperdata HyperdataList
    defaultHyperdataList :: HyperdataList
    defaultHyperdataList = HyperdataList Nothing Nothing Nothing Nothing Nothing
    ----
    data HyperdataListModel =
    HyperdataListModel { _hlm_params :: !(Int, Int)
    , _hlm_path :: !Text
    , _hlm_score :: !(Maybe Double)
    } deriving (Show, Generic)
    instance Hyperdata HyperdataListModel
    instance Arbitrary HyperdataListModel where
    arbitrary = elements [HyperdataListModel (100,100) "models/example.model" Nothing]
    $(deriveJSON (unPrefix "_hlm_") ''HyperdataListModel)
    $(makeLenses ''HyperdataListModel)
    defaultHyperdataListModel :: HyperdataListModel
    defaultHyperdataListModel = HyperdataListModel (400,500) "data/models/test.model" (Just 0.83)
    ------------------------------------------------------------------------
    data HyperdataScore = HyperdataScore { hyperdataScore_preferences :: !(Maybe Text)
    } deriving (Show, Generic)
    $(deriveJSON (unPrefix "hyperdataScore_") ''HyperdataScore)
    instance Hyperdata HyperdataScore
    ------------------------------------------------------------------------
    -- Instances
    ------------------------------------------------------------------------
    instance FromField HyperdataList
    where
    fromField = fromField'
    instance FromField HyperdataListModel
    where
    fromField = fromField'
    ------------------------------------------------------------------------
    instance QueryRunnerColumnDefault PGJsonb HyperdataList
    where
    queryRunnerColumnDefault = fieldQueryRunnerColumn
    instance QueryRunnerColumnDefault PGJsonb HyperdataListModel
    where
    queryRunnerColumnDefault = fieldQueryRunnerColumn
    src/Gargantext/Database/Admin/Types/Hyperdata/Prelude.hs
    View file @ 4f6c0893
    ...@@ -16,6 +16,7 @@ module Gargantext.Database.Admin.Types.Hyperdata.Prelude ...@@ -16,6 +16,7 @@ module Gargantext.Database.Admin.Types.Hyperdata.Prelude
    , module Data.Aeson.TH , module Data.Aeson.TH
    , module Data.Aeson.Types , module Data.Aeson.Types
    , module Data.ByteString.Lazy.Internal , module Data.ByteString.Lazy.Internal
    , module Data.Maybe
    , module Data.Monoid , module Data.Monoid
    , module Data.Swagger , module Data.Swagger
    , module Data.Text , module Data.Text
    ...@@ -28,27 +29,45 @@ module Gargantext.Database.Admin.Types.Hyperdata.Prelude ...@@ -28,27 +29,45 @@ module Gargantext.Database.Admin.Types.Hyperdata.Prelude
    , module Test.QuickCheck , module Test.QuickCheck
    , module Test.QuickCheck.Arbitrary , module Test.QuickCheck.Arbitrary
    , Hyperdata , Hyperdata
    , Chart(..)
    ) )
    where where
    import Data.Text (Text)
    import Control.Lens hiding (elements, (&), (.=)) import Control.Lens hiding (elements, (&), (.=))
    import Data.Aeson import Data.Aeson
    import Data.Aeson.TH (deriveJSON) import Data.Aeson.TH (deriveJSON)
    import Data.Aeson.Types (emptyObject) import Data.Aeson.Types (emptyObject)
    import Data.ByteString.Lazy.Internal (ByteString) import Data.ByteString.Lazy.Internal (ByteString)
    import Data.Maybe (Maybe(..))
    import Data.Monoid (mempty) import Data.Monoid (mempty)
    import Data.Swagger hiding (unwrapUnaryRecords, constructorTagModifier, allNullaryToStringTag, allOf, fieldLabelModifier) import Data.Swagger hiding (unwrapUnaryRecords, constructorTagModifier, allNullaryToStringTag, allOf, fieldLabelModifier)
    import Data.Text (Text)
    import Database.PostgreSQL.Simple.FromField (FromField, fromField) import Database.PostgreSQL.Simple.FromField (FromField, fromField)
    import Database.PostgreSQL.Simple.ToField (ToField, toField, toJSONField) import Database.PostgreSQL.Simple.ToField (ToField, toField, toJSONField)
    import GHC.Generics (Generic) import GHC.Generics (Generic)
    import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema) import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema)
    import Gargantext.Database.Prelude (fromField') import Gargantext.Database.Prelude (fromField')
    import Gargantext.Prelude
    import Opaleye (QueryRunnerColumnDefault, queryRunnerColumnDefault, PGJsonb, fieldQueryRunnerColumn) import Opaleye (QueryRunnerColumnDefault, queryRunnerColumnDefault, PGJsonb, fieldQueryRunnerColumn)
    import Test.QuickCheck (elements) import Test.QuickCheck (elements)
    import Test.QuickCheck.Arbitrary import Test.QuickCheck.Arbitrary
    ------------------------------------------------------------------------
    -- Only Hyperdata types should be member of this type class. -- Only Hyperdata types should be member of this type class.
    class Hyperdata a class Hyperdata a
    data Chart =
    CDocsHistogram
    | CAuthorsPie
    | CInstitutesTree
    | CTermsMetrics
    deriving (Generic, Show, Eq)
    instance ToJSON Chart
    instance FromJSON Chart
    instance ToSchema Chart
    src/Gargantext/Database/Query/Table/Node.hs
    View file @ 4f6c0893
    ...@@ -41,7 +41,7 @@ import Gargantext.Database.Prelude ...@@ -41,7 +41,7 @@ import Gargantext.Database.Prelude
    import Gargantext.Database.Query.Table.Node.Contact (HyperdataContact(..), arbitraryHyperdataContact) import Gargantext.Database.Query.Table.Node.Contact (HyperdataContact(..), arbitraryHyperdataContact)
    import Gargantext.Database.Schema.Node import Gargantext.Database.Schema.Node
    import Gargantext.Prelude hiding (sum, head) import Gargantext.Prelude hiding (sum, head)
    import Gargantext.Viz.Graph (HyperdataGraph(..)) import Gargantext.Viz.Graph (HyperdataGraph(..), defaultHyperdataGraph)
    queryNodeSearchTable :: Query NodeSearchRead queryNodeSearchTable :: Query NodeSearchRead
    ...@@ -181,79 +181,20 @@ nodeCorpusW maybeName maybeCorpus pId = node NodeCorpus name corpus (Just pId) ...@@ -181,79 +181,20 @@ nodeCorpusW maybeName maybeCorpus pId = node NodeCorpus name corpus (Just pId)
    name = maybe "Corpus" identity maybeName name = maybe "Corpus" identity maybeName
    corpus = maybe defaultCorpus identity maybeCorpus corpus = maybe defaultCorpus identity maybeCorpus
    -------------------------- --------------------------
    defaultDocument :: HyperdataDocument
    defaultDocument = hyperdataDocument
    nodeDocumentW :: Maybe Name -> Maybe HyperdataDocument -> CorpusId -> UserId -> NodeWrite nodeDocumentW :: Maybe Name -> Maybe HyperdataDocument -> CorpusId -> UserId -> NodeWrite
    nodeDocumentW maybeName maybeDocument cId = node NodeDocument name doc (Just cId) nodeDocumentW maybeName maybeDocument cId = node NodeDocument name doc (Just cId)
    where where
    name = maybe "Document" identity maybeName name = maybe "Document" identity maybeName
    doc = maybe defaultDocument identity maybeDocument doc = maybe defaultHyperdataDocument identity maybeDocument
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    defaultAnnuaire :: HyperdataAnnuaire
    defaultAnnuaire = HyperdataAnnuaire (Just "Title") (Just "Description")
    nodeAnnuaireW :: Maybe Name -> Maybe HyperdataAnnuaire -> ParentId -> UserId -> NodeWrite nodeAnnuaireW :: Maybe Name -> Maybe HyperdataAnnuaire -> ParentId -> UserId -> NodeWrite
    nodeAnnuaireW maybeName maybeAnnuaire pId = node NodeAnnuaire name annuaire (Just pId) nodeAnnuaireW maybeName maybeAnnuaire pId = node NodeAnnuaire name annuaire (Just pId)
    where where
    name = maybe "Annuaire" identity maybeName name = maybe "Annuaire" identity maybeName
    annuaire = maybe defaultAnnuaire identity maybeAnnuaire annuaire = maybe defaultHyperdataAnnuaire identity maybeAnnuaire
    ------------------------------------------------------------------------
    {-
    class IsNodeDb a where
    data Node'' a :: *
    data Hyper a :: *
    instance IsNodeDb NodeType where
    data
    instance HasHyperdata NodeType where
    data Hyper NodeType = HyperList HyperdataList
    | HyperCorpus HyperdataCorpus
    hasHyperdata nt = case nt of
    NodeList -> HyperList $ HyperdataList (Just "list")
    unHyper h = case h of
    HyperList h' -> h'
    --}
    class HasDefault a where
    hasDefaultData :: a -> HyperData
    hasDefaultName :: a -> Text
    instance HasDefault NodeType where
    hasDefaultData nt = case nt of
    NodeTexts -> HyperdataTexts (Just "Preferences")
    NodeList -> HyperdataList' (Just "Preferences")
    NodeListCooc -> HyperdataList' (Just "Preferences")
    -- NodeFolder -> defaultFolder
    NodeDashboard -> arbitraryDashboard
    _ -> panic "HasDefaultData undefined"
    --NodeAnnuaire -> HyperdataAnnuaire (Just "Title") (Just "Description")
    hasDefaultName nt = case nt of
    NodeTexts -> "Texts"
    NodeList -> "Lists"
    NodeListCooc -> "Cooc"
    NodePhylo -> "Phylo"
    _ -> panic "HasDefaultName undefined"
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    nodeDefault :: NodeType -> ParentId -> UserId -> NodeWrite
    nodeDefault nt parent = node nt name hyper (Just parent)
    where
    name = (hasDefaultName nt)
    hyper = (hasDefaultData nt)
    ------------------------------------------------------------------------
    arbitraryListModel :: HyperdataListModel
    arbitraryListModel = HyperdataListModel (400,500) "data/models/test.model" (Just 0.83)
    mkListModelNode :: HasNodeError err => ParentId -> UserId -> Cmd err [NodeId] mkListModelNode :: HasNodeError err => ParentId -> UserId -> Cmd err [NodeId]
    mkListModelNode p u = insertNodesR [nodeListModelW Nothing Nothing p u] mkListModelNode p u = insertNodesR [nodeListModelW Nothing Nothing p u]
    ...@@ -261,17 +202,14 @@ nodeListModelW :: Maybe Name -> Maybe HyperdataListModel -> ParentId -> UserId - ...@@ -261,17 +202,14 @@ nodeListModelW :: Maybe Name -> Maybe HyperdataListModel -> ParentId -> UserId -
    nodeListModelW maybeName maybeListModel pId = node NodeListModel name list (Just pId) nodeListModelW maybeName maybeListModel pId = node NodeListModel name list (Just pId)
    where where
    name = maybe "List Model" identity maybeName name = maybe "List Model" identity maybeName
    list = maybe arbitraryListModel identity maybeListModel list = maybe defaultHyperdataListModel identity maybeListModel
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    arbitraryGraph :: HyperdataGraph
    arbitraryGraph = HyperdataGraph Nothing
    nodeGraphW :: Maybe Name -> Maybe HyperdataGraph -> ParentId -> UserId -> NodeWrite nodeGraphW :: Maybe Name -> Maybe HyperdataGraph -> ParentId -> UserId -> NodeWrite
    nodeGraphW maybeName maybeGraph pId = node NodeGraph name graph (Just pId) nodeGraphW maybeName maybeGraph pId = node NodeGraph name graph (Just pId)
    where where
    name = maybe "Graph" identity maybeName name = maybe "Graph" identity maybeName
    graph = maybe arbitraryGraph identity maybeGraph graph = maybe defaultHyperdataGraph identity maybeGraph
    mkGraph :: ParentId -> UserId -> Cmd err [GraphId] mkGraph :: ParentId -> UserId -> Cmd err [GraphId]
    mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u] mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
    ...@@ -279,11 +217,18 @@ mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u] ...@@ -279,11 +217,18 @@ mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
    insertGraph :: ParentId -> UserId -> HyperdataGraph -> Cmd err [GraphId] insertGraph :: ParentId -> UserId -> HyperdataGraph -> Cmd err [GraphId]
    insertGraph p u h = insertNodesR [nodeGraphW Nothing (Just h) p u] insertGraph p u h = insertNodesR [nodeGraphW Nothing (Just h) p u]
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    arbitraryDashboard :: HyperData nodeDefault :: NodeType -> ParentId -> UserId -> NodeWrite
    arbitraryDashboard = HyperdataDashboard (Just "Preferences") [] nodeDefault NodeList parentId = node NodeList "List" defaultHyperdataList (Just parentId)
    ------------------------------------------------------------------------ nodeDefault NodeCorpus parentId = node NodeCorpus "Corpus" defaultHyperdataCorpus (Just parentId)
    nodeDefault NodeDocument parentId = node NodeDocument "Doc" defaultHyperdataDocument (Just parentId)
    nodeDefault NodeTexts parentId = node NodeTexts "Texts" defaultHyperdataTexts (Just parentId)
    nodeDefault NodeListModel parentId = node NodeListModel "Model" defaultHyperdataListModel (Just parentId)
    nodeDefault nt _ = panic $ "G.D.Q.T.Node.nodeDefault " <> (cs $ show nt)
    ------------------------------------------------------------------------
    ------------------------------------------------------------------------
    node :: (ToJSON a, Hyperdata a) node :: (ToJSON a, Hyperdata a)
    => NodeType => NodeType
    -> Name -> Name
    ...@@ -316,19 +261,6 @@ insertNodesWithParent pid ns = insertNodes (set node_parentId (pgNodeId <$> pid) ...@@ -316,19 +261,6 @@ insertNodesWithParent pid ns = insertNodes (set node_parentId (pgNodeId <$> pid)
    insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [NodeId] insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [NodeId]
    insertNodesWithParentR pid ns = insertNodesR (set node_parentId (pgNodeId <$> pid) <$> ns) insertNodesWithParentR pid ns = insertNodesR (set node_parentId (pgNodeId <$> pid) <$> ns)
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    -- TODO Hierachy of Nodes
    -- post and get same types Node' and update if changes
    {- TODO semantic to achieve
    post c uid pid [ Node' NodeCorpus "name" "{}" []
    , Node' NodeFolder "name" "{}" [Node' NodeCorpus "test 2" "" [ Node' NodeDocument "title" "metaData" []
    , Node' NodeDocument "title" "jsonData" []
    ]
    ]
    ]
    -}
    ------------------------------------------------------------------------
    -- TODO -- TODO
    -- currently this function removes the child relation -- currently this function removes the child relation
    -- needs a Temporary type between Node' and NodeWriteT -- needs a Temporary type between Node' and NodeWriteT
    ...@@ -352,41 +284,6 @@ mkNodeR :: [NodeWrite] -> Cmd err [NodeId] ...@@ -352,41 +284,6 @@ mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
    mkNodeR ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns (rReturning _node_id) Nothing mkNodeR ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns (rReturning _node_id) Nothing
    ------------------------------------------------------------------------ ------------------------------------------------------------------------
    {-
    data NewNode = NewNode { _newNodeId :: NodeId
    , _newNodeChildren :: [NodeId] }
    postNode :: HasNodeError err
    => UserId
    -> Maybe ParentId
    -> Node'
    -> Cmd err NewNode
    postNode uid pid (Node' nt txt v []) = do
    pids <- mkNodeR [node2table uid pid (Node' nt txt v [])]
    case pids of
    [pid'] -> pure $ NewNode pid' []
    _ -> nodeError ManyParents
    postNode uid pid (Node' NodeCorpus txt v ns) = do
    NewNode pid' _ <- postNode uid pid (Node' NodeCorpus txt v [])
    pids <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
    pure $ NewNode pid' pids
    postNode uid pid (Node' NodeAnnuaire txt v ns) = do
    NewNode pid' _ <- postNode uid pid (Node' NodeAnnuaire txt v [])
    pids <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
    pure $ NewNode pid' pids
    postNode uid pid (Node' NodeDashboard txt v ns) = do
    NewNode pid' _ <- postNode uid pid (Node' NodeDashboard txt v [])
    pids <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
    pure $ NewNode pid' pids
    postNode _ _ (Node' _ _ _ _) = nodeError NotImplYet
    -}
    childWith :: UserId -> ParentId -> Node' -> NodeWrite childWith :: UserId -> ParentId -> Node' -> NodeWrite
    childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v []) childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
    childWith uId pId (Node' NodeContact txt v []) = node2table uId (Just pId) (Node' NodeContact txt v []) childWith uId pId (Node' NodeContact txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
    ...@@ -439,11 +336,14 @@ mkNode nt p u = insertNodesR [nodeDefault nt p u] ...@@ -439,11 +336,14 @@ mkNode nt p u = insertNodesR [nodeDefault nt p u]
    mkDashboard :: ParentId -> UserId -> Cmd err [NodeId] mkDashboard :: ParentId -> UserId -> Cmd err [NodeId]
    mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u] mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
    where where
    nodeDashboardW :: Maybe Name -> Maybe HyperData -> ParentId -> UserId -> NodeWrite nodeDashboardW :: Maybe Name -> Maybe HyperdataDashboard -> ParentId -> UserId -> NodeWrite
    nodeDashboardW maybeName maybeDashboard pId = node NodeDashboard name dashboard (Just pId) nodeDashboardW maybeName maybeDashboard pId = node NodeDashboard name dashboard (Just pId)
    where where
    name = maybe "Board" identity maybeName name = maybe "Board" identity maybeName
    dashboard = maybe arbitraryDashboard identity maybeDashboard dashboard = maybe arbitraryDashboard identity maybeDashboard
    arbitraryDashboard :: HyperdataDashboard
    arbitraryDashboard = HyperdataDashboard (Just "Preferences") []
    getListsWithParentId :: NodeId -> Cmd err [Node HyperdataList] getListsWithParentId :: NodeId -> Cmd err [Node HyperdataList]
    getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList) getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
    ......
    src/Gargantext/Viz/Graph.hs
    View file @ 4f6c0893
    ...@@ -170,6 +170,10 @@ data HyperdataGraph = ...@@ -170,6 +170,10 @@ data HyperdataGraph =
    } deriving (Show, Generic) } deriving (Show, Generic)
    $(deriveJSON (unPrefix "") ''HyperdataGraph) $(deriveJSON (unPrefix "") ''HyperdataGraph)
    defaultHyperdataGraph :: HyperdataGraph
    defaultHyperdataGraph = HyperdataGraph Nothing
    instance Hyperdata HyperdataGraph instance Hyperdata HyperdataGraph
    makeLenses ''HyperdataGraph makeLenses ''HyperdataGraph
    ......
    src/Gargantext/Viz/Phylo/API.hs
    View file @ 4f6c0893
    ...@@ -96,11 +96,11 @@ type GetPhylo = QueryParam "listId" ListId ...@@ -96,11 +96,11 @@ type GetPhylo = QueryParam "listId" ListId
    -- Fix Filter parameters -- Fix Filter parameters
    getPhylo :: PhyloId -> GargServer GetPhylo getPhylo :: PhyloId -> GargServer GetPhylo
    getPhylo phId _lId l msb = do getPhylo phId _lId l msb = do
    phNode <- getNodeWith phId (Proxy :: Proxy HyperData) phNode <- getNodeWith phId (Proxy :: Proxy HyperdataPhylo)
    let let
    level = maybe 2 identity l level = maybe 2 identity l
    branc = maybe 2 identity msb branc = maybe 2 identity msb
    maybePhylo = hd_data $ _node_hyperdata phNode maybePhylo = hp_data $ _node_hyperdata phNode
    p <- liftBase $ viewPhylo2Svg p <- liftBase $ viewPhylo2Svg
    $ viewPhylo level branc $ viewPhylo level branc
    ......
    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