-}
-
{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-} -- allows to write Text literals
{-# LANGUAGE OverloadedLists #-} -- allows to write Map and HashMap as lists
{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE FlexibleInstances #-}
module Gargantext.Viz.Phylo.API
where
+import Control.Lens ((^.))
+import Data.String.Conversions
--import Control.Monad.Reader (ask)
-import Data.Text (Text)
-import Data.Map (empty)
+import qualified Data.ByteString as DB
+import qualified Data.ByteString.Lazy as DBL
+import Data.Proxy (Proxy(..))
import Data.Swagger
-import Gargantext.API.Types
-import Gargantext.Database.Types.Node (PhyloId, ListId, CorpusId)
-import Gargantext.Prelude
-import Gargantext.Viz.Phylo
-import Gargantext.Viz.Phylo.Example
-import Gargantext.Viz.Phylo.Tools
-import Gargantext.Viz.Phylo.View.ViewMaker
-import Gargantext.Viz.Phylo.LevelMaker
+import Network.HTTP.Media ((//), (/:))
import Servant
-import Servant.Job.Utils (swaggerOptions)
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
import Web.HttpApiData (parseUrlPiece, readTextData)
+import Gargantext.API.Prelude
+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.Prelude
+import Gargantext.Viz.Phylo
+import Gargantext.Viz.Phylo.Main
+import Gargantext.Viz.Phylo.Example
+import Gargantext.Core.Types (TODO(..))
+
------------------------------------------------------------------------
type PhyloAPI = Summary "Phylo API"
:> GetPhylo
:<|> PostPhylo
-phyloAPI :: PhyloId -> GargServer PhyloAPI
-phyloAPI n = getPhylo n
+phyloAPI :: PhyloId -> UserId -> GargServer PhyloAPI
+phyloAPI n u = getPhylo n
+ :<|> postPhylo n u
-- :<|> putPhylo n
- :<|> postPhylo n
+ -- :<|> deletePhylo n
+
+newtype SVG = SVG DB.ByteString
+
+instance ToSchema SVG
+ where
+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy TODO)
+
+instance Show SVG where
+ show (SVG a) = show a
+
+instance Accept SVG where
+ contentType _ = "SVG" // "image/svg+xml" /: ("charset", "utf-8")
+
+instance Show a => MimeRender PlainText a where
+ mimeRender _ val = cs ("" <> show val)
+
+instance MimeRender SVG SVG where
+ mimeRender _ (SVG s) = DBL.fromStrict s
------------------------------------------------------------------------
type GetPhylo = QueryParam "listId" ListId
:> QueryParam "level" Level
- :> QueryParam "filiation" Filiation
+ :> QueryParam "minSizeBranch" MinSizeBranch
+ {- :> QueryParam "filiation" Filiation
:> QueryParam "childs" Bool
:> QueryParam "depth" Level
:> QueryParam "metrics" [Metric]
:> QueryParam "export" ExportMode
:> QueryParam "display" DisplayMode
:> QueryParam "verbose" Bool
- :> Get '[JSON] PhyloView
+ -}
+ :> Get '[SVG] SVG
-- | TODO
-- Add real text processing
-- Fix Filter parameters
getPhylo :: PhyloId -> GargServer GetPhylo
-getPhylo _phyloId _lId l f b l' ms x y z ts s o e d b' = do
+getPhylo phId _lId l msb = do
+ phNode <- getNodeWith phId (Proxy :: Proxy HyperdataPhylo)
let
- fs' = maybe (Just []) (\p -> Just [p]) $ LonelyBranch <$> (LBParams <$> x <*> y <*> z)
- so = (,) <$> s <*> o
- q = initPhyloQueryView l f b l' ms fs' ts so e d b'
- -- | TODO remove phylo for real data here
- pure (toPhyloView q phylo)
- -- TODO remove phylo for real data here
-
-------------------------------------------------------------------------
-{-
-type PutPhylo = (Put '[JSON] Phylo )
---putPhylo :: PhyloId -> Maybe ListId -> PhyloQueryBuild -> Phylo
-putPhylo :: PhyloId -> GargServer PutPhylo
-putPhylo = undefined
--}
+ level = maybe 2 identity l
+ branc = maybe 2 identity msb
+ maybePhylo = phNode ^. (node_hyperdata . hp_data)
+
+ p <- liftBase $ viewPhylo2Svg
+ $ viewPhylo level branc
+ $ maybe phyloFromQuery identity maybePhylo
+ pure (SVG p)
------------------------------------------------------------------------
type PostPhylo = QueryParam "listId" ListId
- :> ReqBody '[JSON] PhyloQueryBuild
- :> (Post '[JSON] Phylo)
+ -- :> ReqBody '[JSON] PhyloQueryBuild
+ :> (Post '[JSON] NodeId)
-postPhylo :: CorpusId -> GargServer PostPhylo
-postPhylo _n _lId q = do
+postPhylo :: CorpusId -> UserId -> GargServer PostPhylo
+postPhylo n userId _lId = do
-- TODO get Reader settings
-- s <- ask
let
- vrs = Just ("1" :: Text)
- sft = Just (Software "Gargantext" "4")
- prm = initPhyloParam vrs sft (Just q)
- pure (toPhyloBase q prm corpus actants termList empty)
-
+ -- _vrs = Just ("1" :: Text)
+ -- _sft = Just (Software "Gargantext" "4")
+ -- _prm = initPhyloParam vrs sft (Just q)
+ phy <- flowPhylo n
+ pId <- insertNodes [node NodePhylo "Phylo" (HyperdataPhylo Nothing (Just phy)) (Just n) userId]
+ pure $ NodeId (fromIntegral pId)
------------------------------------------------------------------------
-- | DELETE Phylo == delete a node
------------------------------------------------------------------------
-
-
+------------------------------------------------------------------------
+{-
+type PutPhylo = (Put '[JSON] Phylo )
+--putPhylo :: PhyloId -> Maybe ListId -> PhyloQueryBuild -> Phylo
+putPhylo :: PhyloId -> GargServer PutPhylo
+putPhylo = undefined
+-}
-- | Instances
where
arbitrary = elements [phylo]
-
-instance ToSchema Cluster
-instance ToSchema EdgeType
-instance ToSchema Filiation
-instance ToSchema Filter
-instance ToSchema FisParams
-instance ToSchema HammingParams
-instance ToSchema LouvainParams
-instance ToSchema Metric
instance ToSchema Order
-instance ToSchema Phylo
-instance ToSchema PhyloFis
-instance ToSchema PhyloBranch
-instance ToSchema PhyloEdge
-instance ToSchema PhyloGroup
-instance ToSchema PhyloLevel
-instance ToSchema PhyloNode
-instance ToSchema PhyloParam
-instance ToSchema PhyloFoundations
-instance ToSchema PhyloPeriod
-instance ToSchema PhyloQueryBuild
-instance ToSchema PhyloView
-instance ToSchema RCParams
-instance ToSchema LBParams
-instance ToSchema SBParams
-instance ToSchema Software
-instance ToSchema WLJParams
-
instance ToParamSchema Order
instance FromHttpApiData Order
parseUrlPiece = readTextData
instance ToParamSchema Sort
-
-instance ToSchema Proximity
- where
- declareNamedSchema = genericDeclareNamedSchemaUnrestricted
- $ swaggerOptions ""
-
-
instance FromHttpApiData [Tagger]
where
parseUrlPiece = readTextData