Skip to content

H
haskell-gargantext
Commit 35857fe1 authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

[WRONG] this type of refactoring fails in decodeJson

parent 9eaa8799
Hide whitespace changes
Inline Side-by-side
Showing with 120 additions and 127 deletions
bin/gargantext-init/Main.hs
View file @ 35857fe1
......@@ -27,7 +27,7 @@ import Gargantext.Database.Query.Table.User (insertUsersDemo)
import Gargantext.Database.Admin.Config (userMaster, corpusMasterName)
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Admin.Trigger.Init (initTriggers)
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataCorpus)
import Gargantext.Database.Admin.Types.Hyperdata (HyperData)
import Gargantext.Database.Admin.Types.Node (CorpusId, RootId, ListId)
import Gargantext.Database.Prelude (Cmd, )
import Gargantext.Prelude
......@@ -48,7 +48,7 @@ main = do
let
initMaster :: Cmd GargError (UserId, RootId, CorpusId, ListId)
initMaster = do
(masterUserId, masterRootId, masterCorpusId) <- getOrMk_RootWithCorpus (UserName userMaster) (Left corpusMasterName) (Nothing :: Maybe HyperdataCorpus)
(masterUserId, masterRootId, masterCorpusId) <- getOrMk_RootWithCorpus (UserName userMaster) (Left corpusMasterName) (Nothing :: Maybe HyperData)
masterListId <- getOrMkList masterCorpusId masterUserId
_triggers <- initTriggers masterListId
pure (masterUserId, masterRootId, masterCorpusId, masterListId)
......
src/Gargantext/API/Public.hs
View file @ 35857fe1
......@@ -47,13 +47,13 @@ api = catMaybes <$> map toPublicData <$> filterPublicDatas <$> selectPublic
selectPublic :: HasNodeError err
=> Cmd err [( Node HyperdataFolder, Maybe Int)]
=> Cmd err [( Node HyperData, Maybe Int)]
selectPublic = selectPublicNodes
-- | For tests only
-- pure $ replicate 6 defaultPublicData
filterPublicDatas :: [( Node HyperdataFolder, Maybe Int)] -> [(Node HyperdataFolder, [NodeId])]
filterPublicDatas :: [( Node HyperData, Maybe Int)] -> [(Node HyperData, [NodeId])]
filterPublicDatas datas = map (\(n,mi) -> let mi' = NodeId <$> mi in
( _node_id n, (n, maybe [] (:[]) mi' ))
) datas
......@@ -62,7 +62,7 @@ filterPublicDatas datas = map (\(n,mi) -> let mi' = NodeId <$> mi in
& Map.elems
toPublicData :: (Node HyperdataFolder, [NodeId]) -> Maybe PublicData
toPublicData :: (Node HyperData, [NodeId]) -> Maybe PublicData
toPublicData (n , _mn) = PublicData <$> (hd ^? (_Just . hf_data . cf_title))
<*> (hd ^? (_Just . hf_data . cf_desc))
<*> Just "images/Gargantextuel-212x300.jpg"
......@@ -73,7 +73,7 @@ toPublicData (n , _mn) = PublicData <$> (hd ^? (_Just . hf_data . cf_title))
where
hd = head
$ filter (\(HyperdataField cd _ _) -> cd == JSON)
$ n^. (node_hyperdata . hc_fields)
$ n^. (node_hyperdata . hd_fields)
data PublicData = PublicData
......
src/Gargantext/API/Routes.hs
View file @ 35857fe1
......@@ -99,7 +99,7 @@ type GargPrivateAPI' =
-- Corpus endpoints
:<|> "corpus" :> Summary "Corpus endpoint"
:> Capture "corpus_id" CorpusId
:> NodeAPI HyperdataCorpus
:> NodeAPI HyperData
:<|> "corpus" :> Summary "Corpus endpoint"
:> Capture "node1_id" NodeId
......@@ -205,7 +205,7 @@ serverPrivateGargAPI' :: AuthenticatedUser -> GargServer GargPrivateAPI'
serverPrivateGargAPI' (AuthenticatedUser (NodeId uid))
= serverGargAdminAPI
:<|> nodeAPI (Proxy :: Proxy HyperdataAny) uid
:<|> nodeAPI (Proxy :: Proxy HyperdataCorpus) uid
:<|> nodeAPI (Proxy :: Proxy HyperData) uid
:<|> nodeNodeAPI (Proxy :: Proxy HyperdataAny) uid
:<|> Export.getCorpus -- uid
:<|> nodeAPI (Proxy :: Proxy HyperdataAnnuaire) uid
......
src/Gargantext/Database/Action/Flow.hs
View file @ 35857fe1
......@@ -126,7 +126,7 @@ getDataText (InternalOrigin _) _la q _li = do
(_masterUserId, _masterRootId, cId) <- getOrMk_RootWithCorpus
(UserName userMaster)
(Left "")
(Nothing :: Maybe HyperdataCorpus)
(Nothing :: Maybe HyperData)
ids <- map fst <$> searchInDatabase cId (stemIt q)
pure $ DataOld ids
......@@ -139,7 +139,7 @@ flowDataText :: FlowCmdM env err m
-> m CorpusId
flowDataText u (DataOld ids) tt cid = flowCorpusUser (_tt_lang tt) u (Right [cid]) corpusType ids
where
corpusType = (Nothing :: Maybe HyperdataCorpus)
corpusType = (Nothing :: Maybe HyperData)
flowDataText u (DataNew txt) tt cid = flowCorpus u (Right [cid]) tt txt
------------------------------------------------------------------------
......@@ -177,7 +177,7 @@ flowCorpus :: (FlowCmdM env err m, FlowCorpus a)
-> TermType Lang
-> [[a]]
-> m CorpusId
flowCorpus = flow (Nothing :: Maybe HyperdataCorpus)
flowCorpus = flow (Nothing :: Maybe HyperData)
flow :: (FlowCmdM env err m, FlowCorpus a, MkCorpus c)
......
src/Gargantext/Database/Admin/Types/Hyperdata.hs
View file @ 35857fe1
......@@ -7,35 +7,36 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Admin.Types.Hyperdata where
import Control.Lens hiding (elements, (&))
import Data.Aeson
import Data.Aeson (Object, toJSON)
import Data.Aeson.Types (emptyObject)
import Data.Aeson.TH (deriveJSON)
import Data.Aeson.Types (emptyObject)
import Data.ByteString.Lazy.Internal (ByteString)
import Data.Monoid (mempty)
import Data.Swagger
import Database.PostgreSQL.Simple.FromField (FromField, fromField)
import Database.PostgreSQL.Simple.ToField (ToField, toField, toJSONField)
import GHC.Generics (Generic)
import Opaleye (QueryRunnerColumnDefault, queryRunnerColumnDefault, PGJsonb, fieldQueryRunnerColumn)
import Protolude hiding (ByteString)
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary
import Gargantext.API.Ngrams.NTree (MyTree)
import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema)
import Gargantext.Database.Admin.Types.Metrics (ChartMetrics(..), Metrics)
import Gargantext.Database.Prelude (fromField')
import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema)
import Gargantext.Viz.Phylo (Phylo(..))
import Gargantext.Viz.Types (Histo(..))
import Opaleye (QueryRunnerColumnDefault, queryRunnerColumnDefault, PGJsonb, fieldQueryRunnerColumn)
import Protolude hiding (ByteString)
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary
class Hyperdata a
data CodeType = JSON | Markdown | Haskell
deriving (Generic, Eq)
deriving (Generic, Eq, Show)
instance ToJSON CodeType
instance FromJSON CodeType
instance ToSchema CodeType
......@@ -43,7 +44,7 @@ instance ToSchema CodeType
------------------------------------------------------------------------
data StatusV3 = StatusV3 { statusV3_error :: !(Maybe Text)
, statusV3_action :: !(Maybe Text)
} deriving (Show, Generic)
} deriving (Generic, Show)
$(deriveJSON (unPrefix "statusV3_") ''StatusV3)
------------------------------------------------------------------------
......@@ -55,7 +56,7 @@ data CorpusField = MarkdownField { _cf_text :: !Text }
-- , _cf_resources :: ![Resource]
}
| HaskellField { _cf_haskell :: !Text }
deriving (Generic)
deriving (Generic, Show)
isField :: CodeType -> CorpusField -> Bool
isField Markdown (MarkdownField _) = True
......@@ -75,20 +76,73 @@ instance ToSchema CorpusField where
& mapped.schema.description ?~ "CorpusField"
& mapped.schema.example ?~ toJSON defaultCorpusField
data HyperdataField a =
HyperdataField { _hf_type :: !CodeType
, _hf_name :: !Text
, _hf_data :: !a
} deriving (Generic, Show)
$(deriveJSON (unPrefix "_hf_") ''HyperdataField)
$(makeLenses ''HyperdataField)
defaultHyperdataField :: HyperdataField CorpusField
defaultHyperdataField = HyperdataField Markdown "name" defaultCorpusField
instance (Typeable a, ToSchema a) => ToSchema (HyperdataField a) where
declareNamedSchema =
wellNamedSchema "_hf_"
-- & mapped.schema.description ?~ "HyperdataField"
-- & mapped.schema.example ?~ toJSON defaultHyperdataField
------------------------------------------------------------------------
data Chart =
CDocsHistogram
| CAuthorsPie
| CInstitutesTree
| CTermsMetrics
deriving (Generic, Show, Eq)
data Chart = CDocsHistogram
| CAuthorsPie
| CInstitutesTree
| CTermsMetrics
deriving (Generic, Show, Eq)
instance ToJSON Chart
instance FromJSON Chart
instance ToSchema Chart
------------------------------------------------------------------------
-- | TODO FEATURE: Notebook saved in the node
data HyperData = HyperdataTexts { _hd_preferences :: !(Maybe Text)}
| HyperdataList' { _hd_preferences :: !(Maybe Text)}
| HyperdataCorpus { _hd_fields :: ![HyperdataField CorpusField] }
| HyperdataFolder { _hd_fields :: ![HyperdataField CorpusField] }
| HyperdataDashboard { _hd_preferences :: !(Maybe Text)
, _hd_charts :: ![Chart]
}
| HyperdataNotebook { _hd_preferences :: !(Maybe Text)}
| HyperdataPhylo { _hd_preferences :: !(Maybe Text)
, _hd_data :: !(Maybe Phylo)
}
| HyperdataResource { _hd_preferences :: !(Maybe Text)
}
| HyperdataListModel { _hd_params :: !(Int, Int)
, _hd_path :: !Text
, _hd_score :: !(Maybe Double)
}
deriving (Show, Generic)
$(makeLenses ''HyperData)
$(deriveJSON (unPrefix "_hd_") ''HyperData)
instance Hyperdata HyperData
instance Arbitrary HyperData where
arbitrary = elements [HyperdataListModel (100,100) "models/example.model" Nothing]
-- Only Hyperdata types should be member of this type class.
------------------------------------------------------------------------
data HyperdataDocumentV3 = HyperdataDocumentV3 { hyperdataDocumentV3_publication_day :: !(Maybe Int)
......@@ -111,7 +165,6 @@ data HyperdataDocumentV3 = HyperdataDocumentV3 { hyperdataDocumentV3_publication
} deriving (Show, Generic)
$(deriveJSON (unPrefix "hyperdataDocumentV3_") ''HyperdataDocumentV3)
class Hyperdata a
instance Hyperdata HyperdataDocumentV3
------------------------------------------------------------------------
......@@ -174,24 +227,9 @@ arbitraryHyperdataDocuments =
Nothing Nothing (Just t2) Nothing Nothing Nothing Nothing Nothing
Nothing Nothing Nothing Nothing
data HyperdataField a =
HyperdataField { _hf_type :: !CodeType
, _hf_name :: !Text
, _hf_data :: !a
} deriving (Generic)
$(deriveJSON (unPrefix "_hf_") ''HyperdataField)
$(makeLenses ''HyperdataField)
defaultHyperdataField :: HyperdataField CorpusField
defaultHyperdataField = HyperdataField Markdown "name" defaultCorpusField
instance (Typeable a, ToSchema a) => ToSchema (HyperdataField a) where
declareNamedSchema =
wellNamedSchema "_hf_"
-- & mapped.schema.description ?~ "HyperdataField"
-- & mapped.schema.example ?~ toJSON defaultHyperdataField
------------------------------------------------------------------------
{-
data HyperdataCorpus =
HyperdataCorpus { _hc_fields :: ![HyperdataField CorpusField] }
deriving (Generic)
......@@ -199,8 +237,9 @@ $(deriveJSON (unPrefix "_hc_") ''HyperdataCorpus)
$(makeLenses ''HyperdataCorpus)
instance Hyperdata HyperdataCorpus
-}
type HyperdataFolder = HyperdataCorpus
------------------------------------------------------------------------
data HyperdataFrame =
HyperdataFrame { base :: !Text
......@@ -219,19 +258,17 @@ docExample = "{\"doi\":\"sdfds\",\"publication_day\":6,\"language_iso2\":\"en\",
corpusExample :: ByteString
corpusExample = "" -- TODO
defaultCorpus :: HyperdataCorpus
defaultCorpus :: HyperData
defaultCorpus = HyperdataCorpus [
HyperdataField JSON "Mandatory fields" (JsonField "Title" "Descr" "Bool query" "Authors")
, HyperdataField Markdown "Optional Text" (MarkdownField "# title\n## subtitle")
]
hyperdataCorpus :: HyperdataCorpus
hyperdataCorpus :: HyperData
hyperdataCorpus = case decode corpusExample of
Just hp -> hp
Nothing -> defaultCorpus
instance Arbitrary HyperdataCorpus where
arbitrary = pure hyperdataCorpus -- TODO
------------------------------------------------------------------------
data HyperdataList =
......@@ -275,18 +312,7 @@ instance Arbitrary HyperdataList' where
-}
----
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)
......@@ -296,34 +322,6 @@ $(deriveJSON (unPrefix "hyperdataScore_") ''HyperdataScore)
instance Hyperdata HyperdataScore
------------------------------------------------------------------------
data HyperdataResource = HyperdataResource { hyperdataResource_preferences :: !(Maybe Text)
} deriving (Show, Generic)
$(deriveJSON (unPrefix "hyperdataResource_") ''HyperdataResource)
instance Hyperdata HyperdataResource
------------------------------------------------------------------------
------------------------------------------------------------------------
-- TODO add the Graph Structure here
------------------------------------------------------------------------
-- | TODO CLEAN
-- | TODO FEATURE: Notebook saved in the node
data HyperData = HyperdataTexts { hd_preferences :: !(Maybe Text)}
| HyperdataList' { hd_preferences :: !(Maybe Text)}
| HyperdataDashboard { hd_preferences :: !(Maybe Text)
, hd_charts :: ![Chart]
}
| HyperdataNotebook { hd_preferences :: !(Maybe Text)}
| HyperdataPhylo { hd_preferences :: !(Maybe Text)
, hd_data :: !(Maybe Phylo)
}
deriving (Show, Generic)
$(deriveJSON (unPrefix "hd_") ''HyperData)
instance Hyperdata HyperData
------------------------------------------------------------------------
hyperdataDocument :: HyperdataDocument
......@@ -340,11 +338,21 @@ hyperdataDocument = case decode docExample of
-- Instances
------------------------------------------------------------------------
{-
instance ToSchema HyperdataCorpus where
declareNamedSchema proxy =
genericDeclareNamedSchema (unPrefixSwagger "_hc_") proxy
& mapped.schema.description ?~ "Corpus"
& mapped.schema.example ?~ toJSON hyperdataCorpus
-}
instance ToSchema HyperData where
declareNamedSchema proxy =
genericDeclareNamedSchema (unPrefixSwagger "_hd_") proxy
& mapped.schema.description ?~ "Hyperdata "
& mapped.schema.example ?~ toJSON hyperdataCorpus
instance ToSchema HyperdataAnnuaire where
declareNamedSchema proxy =
......@@ -369,10 +377,6 @@ instance ToSchema HyperdataAny where
instance FromField HyperdataAny where
fromField = fromField'
instance FromField HyperdataCorpus
where
fromField = fromField'
instance FromField HyperdataDocument
where
fromField = fromField'
......@@ -385,10 +389,6 @@ instance FromField HyperData
where
fromField = fromField'
instance FromField HyperdataListModel
where
fromField = fromField'
instance FromField HyperdataAnnuaire
where
fromField = fromField'
......@@ -419,13 +419,6 @@ instance QueryRunnerColumnDefault PGJsonb HyperdataDocumentV3
where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault PGJsonb HyperdataCorpus
where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault PGJsonb HyperdataListModel
where
queryRunnerColumnDefault = fieldQueryRunnerColumn
instance QueryRunnerColumnDefault PGJsonb HyperdataAnnuaire
where
......
src/Gargantext/Database/Query/Table/Node.hs
View file @ 35857fe1
......@@ -117,10 +117,10 @@ getDocumentsV3WithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocume
getDocumentsWithParentId :: NodeId -> Cmd err [Node HyperdataDocument]
getDocumentsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
getListsModelWithParentId :: NodeId -> Cmd err [Node HyperdataListModel]
getListsModelWithParentId :: NodeId -> Cmd err [Node HyperData]
getListsModelWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeListModel)
getCorporaWithParentId :: NodeId -> Cmd err [Node HyperdataCorpus]
getCorporaWithParentId :: NodeId -> Cmd err [Node HyperData]
getCorporaWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeCorpus)
------------------------------------------------------------------------
......@@ -164,18 +164,18 @@ nodeContactW maybeName maybeContact aId =
name = maybe "Contact" identity maybeName
contact = maybe arbitraryHyperdataContact identity maybeContact
------------------------------------------------------------------------
defaultFolder :: HyperdataCorpus
defaultFolder :: HyperData
defaultFolder = defaultCorpus
nodeFolderW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite
nodeFolderW :: Maybe Name -> Maybe HyperData -> ParentId -> UserId -> NodeWrite
nodeFolderW maybeName maybeFolder pid = node NodeFolder name folder (Just pid)
where
name = maybe "Folder" identity maybeName
folder = maybe defaultFolder identity maybeFolder
------------------------------------------------------------------------
nodeCorpusW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite
nodeCorpusW :: Maybe Name -> Maybe HyperData -> ParentId -> UserId -> NodeWrite
nodeCorpusW maybeName maybeCorpus pId = node NodeCorpus name corpus (Just pId)
where
name = maybe "Corpus" identity maybeName
......@@ -251,6 +251,7 @@ nodeDefault nt parent = node nt name hyper (Just parent)
hyper = (hasDefaultData nt)
------------------------------------------------------------------------
{-
arbitraryListModel :: HyperdataListModel
arbitraryListModel = HyperdataListModel (400,500) "data/models/test.model" (Just 0.83)
......@@ -262,7 +263,7 @@ nodeListModelW maybeName maybeListModel pId = node NodeListModel name list (Just
where
name = maybe "List Model" identity maybeName
list = maybe arbitraryListModel identity maybeListModel
-}
------------------------------------------------------------------------
arbitraryGraph :: HyperdataGraph
arbitraryGraph = HyperdataGraph Nothing
......@@ -403,7 +404,7 @@ class MkCorpus a
where
mk :: Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
instance MkCorpus HyperdataCorpus
instance MkCorpus HyperData
where
mk n h p u = insertNodesR [nodeCorpusW n h p u]
......
src/Gargantext/Viz/Phylo/API.hs
View file @ 35857fe1
......@@ -17,28 +17,27 @@ Portability : POSIX
module Gargantext.Viz.Phylo.API
where
import Data.String.Conversions
--import Control.Monad.Reader (ask)
import qualified Data.ByteString as DB
import qualified Data.ByteString.Lazy as DBL
import Control.Lens ((^?), _Just)
import Data.Proxy (Proxy(..))
import Data.String.Conversions
import Data.Swagger
import Network.HTTP.Media ((//), (/:))
import Servant
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
import Web.HttpApiData (parseUrlPiece, readTextData)
import Gargantext.API.Prelude
import Gargantext.Core.Types (TODO(..))
import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Admin.Types.Node -- (PhyloId, ListId, CorpusId, UserId, NodeId(..))
import Gargantext.Database.Query.Table.Node (insertNodes, node, getNodeWith)
import Gargantext.Database.Schema.Node (_node_hyperdata)
import Gargantext.Database.Schema.Node (node_hyperdata)
import Gargantext.Prelude
import Gargantext.Viz.Phylo
import Gargantext.Viz.Phylo.Main
import Gargantext.Viz.Phylo.Example
import Gargantext.Core.Types (TODO(..))
import Gargantext.Viz.Phylo.Main
import Network.HTTP.Media ((//), (/:))
import Servant
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
import Web.HttpApiData (parseUrlPiece, readTextData)
import qualified Data.ByteString as DB
import qualified Data.ByteString.Lazy as DBL
------------------------------------------------------------------------
type PhyloAPI = Summary "Phylo API"
......@@ -100,7 +99,7 @@ getPhylo phId _lId l msb = do
let
level = maybe 2 identity l
branc = maybe 2 identity msb
maybePhylo = hd_data $ _node_hyperdata phNode
maybePhylo = phNode ^? ( node_hyperdata . hd_data . _Just)
p <- liftBase $ viewPhylo2Svg
$ 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