[Community] Query search contact with text query on documents
[gargantext.git] / src / Gargantext / Viz / Phylo / API.hs
index 600bba0b936dce9cf72803aecf2ead17dd8e0a62..8f56cd2cab6a6821593f14357eb1ca9b3555cb62 100644 (file)
@@ -9,39 +9,38 @@ Portability : POSIX
 
 -}
 
-
 {-# 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
@@ -49,15 +48,35 @@ type PhyloAPI = Summary "Phylo API"
             :<|> 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]
@@ -70,49 +89,51 @@ type GetPhylo =  QueryParam "listId"      ListId
               :> 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
@@ -129,34 +150,7 @@ instance Arbitrary Phylo
   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
@@ -190,13 +184,6 @@ instance FromHttpApiData Sort
     parseUrlPiece = readTextData
 instance ToParamSchema Sort
 
-
-instance ToSchema Proximity
-  where
-    declareNamedSchema = genericDeclareNamedSchemaUnrestricted
-                       $ swaggerOptions ""
-
-
 instance FromHttpApiData [Tagger]
   where
     parseUrlPiece = readTextData