src/Gargantext/Core/Viz/Phylo/API.hs

   1 {-|
   2 Module      : Gargantext.Core.Viz.Phylo.API
   3 Description : Phylo API
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 -}
  11
  12 {-# OPTIONS_GHC -fno-warn-orphans #-}
  13
  14 {-# LANGUAGE OverloadedLists    #-}   -- allows to write Map and HashMap as lists
  15 {-# LANGUAGE TypeOperators      #-}
  16
  17 module Gargantext.Core.Viz.Phylo.API
  18   where
  19
  20 -- import Control.Lens ((^.))
  21 -- import Gargantext.Core.Viz.Phylo.Example
  22 -- import Gargantext.Database.Schema.Node (node_hyperdata)
  23 --import Control.Monad.Reader (ask)
  24 import Data.Aeson
  25 import Data.Either
  26 import Data.Maybe (fromMaybe)
  27 import Data.Swagger
  28 import Gargantext.API.Prelude
  29 import Gargantext.Core.Types (TODO(..))
  30 import Gargantext.Core.Viz.LegacyPhylo
  31 import Gargantext.Core.Viz.Phylo (defaultConfig)
  32 import Gargantext.Core.Viz.Phylo.API.Tools
  33 import Gargantext.Core.Viz.Phylo.Example (phyloExample)
  34 import Gargantext.Core.Viz.Phylo.Legacy.LegacyMain
  35 import Gargantext.Database.Admin.Types.Hyperdata
  36 import Gargantext.Database.Admin.Types.Node -- (PhyloId, ListId, CorpusId, UserId, NodeId(..))
  37 import Gargantext.Database.Query.Table.Node (insertNodes, node)
  38 import Gargantext.Prelude
  39 import Network.HTTP.Media ((//), (/:))
  40 import Servant
  41 import Test.QuickCheck (elements)
  42 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  43 import Web.HttpApiData (readTextData)
  44 import qualified Data.ByteString as DB
  45 import qualified Data.ByteString.Lazy as DBL
  46
  47 ------------------------------------------------------------------------
  48 type PhyloAPI = Summary "Phylo API"
  49               :> GetPhylo
  50         --    :<|> PutPhylo
  51             :<|> PostPhylo
  52
  53
  54 phyloAPI :: PhyloId -> UserId -> GargServer PhyloAPI
  55 phyloAPI n u = getPhylo  n
  56         :<|> postPhylo n u
  57         -- :<|> putPhylo  n
  58         -- :<|> deletePhylo  n
  59
  60 newtype SVG = SVG DB.ByteString
  61 --instance Show a => MimeRender PlainText a where mimeRender _ val = cs ("" <> show val)
  62 instance Accept SVG where contentType _ = "SVG" // "image/svg+xml" /: ("charset", "utf-8")
  63 instance MimeRender SVG SVG where mimeRender _ (SVG s) = DBL.fromStrict s
  64 instance MimeUnrender SVG SVG where mimeUnrender _ lbs = Right $ SVG (DBL.toStrict lbs)
  65 instance Show SVG where show (SVG a) = show a
  66 instance ToSchema SVG where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy TODO)
  67
  68 ------------------------------------------------------------------------
  69 instance ToSchema Value where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy TODO)
  70
  71 ------------------------------------------------------------------------
  72 type GetPhylo =  QueryParam "listId"      ListId
  73               :> QueryParam "level"       Level
  74               :> QueryParam "minSizeBranch" MinSizeBranch
  75    {-           :> QueryParam "filiation"   Filiation
  76               :> QueryParam "childs"      Bool
  77               :> QueryParam "depth"       Level
  78               :> QueryParam "metrics"    [Metric]
  79               :> QueryParam "periodsInf" Int
  80               :> QueryParam "periodsSup" Int
  81               :> QueryParam "minNodes"   Int
  82               :> QueryParam "taggers"    [Tagger]
  83               :> QueryParam "sort"       Sort
  84               :> QueryParam "order"      Order
  85               :> QueryParam "export"    ExportMode
  86               :> QueryParam "display"    DisplayMode
  87               :> QueryParam "verbose"     Bool
  88     -}
  89               -- :> Get '[SVG] SVG
  90               :> Get '[JSON] Value
  91
  92 -- | TODO
  93 -- Add real text processing
  94 -- Fix Filter parameters
  95 -- TODO fix parameters to default config that should be in Node
  96 getPhylo :: PhyloId -> GargServer GetPhylo
  97 getPhylo phyloId _lId _level _minSizeBranch = do
  98   maybePhyloData <- getPhyloData phyloId
  99   let phyloData = fromMaybe phyloExample maybePhyloData
 100   phyloJson <- liftBase $ phylo2dot2json phyloData
 101   pure phyloJson
 102
 103 -- getPhylo phId _lId l msb  = do
 104   -- let
 105   --   level = fromMaybe 2 l
 106   --   branc = fromMaybe 2 msb
 107   --   maybePhylo = phNode ^. (node_hyperdata . hp_data)
 108
 109   -- p <- liftBase $ viewPhylo2Svg
 110   --               $ viewPhylo level branc
 111   --               $ fromMaybe phyloFromQuery maybePhylo
 112   -- pure (SVG p)
 113
 114
 115 ------------------------------------------------------------------------
 116 type PostPhylo =  QueryParam "listId" ListId
 117                -- :> ReqBody '[JSON] PhyloQueryBuild
 118                :> (Post '[JSON] NodeId)
 119
 120 postPhylo :: CorpusId -> UserId -> GargServer PostPhylo
 121 postPhylo corpusId userId _lId = do
 122   -- TODO get Reader settings
 123   -- s <- ask
 124   -- let
 125     -- _vrs = Just ("1" :: Text)
 126     -- _sft = Just (Software "Gargantext" "4")
 127     -- _prm = initPhyloParam vrs sft (Just q)
 128   phy <- flowPhyloAPI defaultConfig corpusId -- params
 129   phyloId <- insertNodes [node NodePhylo "Phylo" (HyperdataPhylo Nothing (Just phy)) (Just corpusId) userId]
 130   pure $ NodeId (fromIntegral phyloId)
 131
 132 ------------------------------------------------------------------------
 133 -- | DELETE Phylo == delete a node
 134 ------------------------------------------------------------------------
 135 ------------------------------------------------------------------------
 136 {-
 137 type PutPhylo = (Put '[JSON] Phylo  )
 138 --putPhylo :: PhyloId -> Maybe ListId -> PhyloQueryBuild -> Phylo
 139 putPhylo :: PhyloId -> GargServer PutPhylo
 140 putPhylo = undefined
 141 -}
 142
 143
 144 -- | Instances
 145 -- instance Arbitrary Phylo             where arbitrary     = elements [phylo]
 146 instance Arbitrary PhyloGroup        where arbitrary     = elements []
 147 -- instance Arbitrary PhyloView         where arbitrary     = elements [phyloView]
 148 instance FromHttpApiData DisplayMode where parseUrlPiece = readTextData
 149 instance FromHttpApiData ExportMode  where parseUrlPiece = readTextData
 150 instance FromHttpApiData Filiation   where parseUrlPiece = readTextData
 151 instance FromHttpApiData Metric      where parseUrlPiece = readTextData
 152 instance FromHttpApiData Order       where parseUrlPiece = readTextData
 153 instance FromHttpApiData Sort        where parseUrlPiece = readTextData
 154 instance FromHttpApiData Tagger      where parseUrlPiece = readTextData
 155 instance FromHttpApiData [Metric]    where parseUrlPiece = readTextData
 156 instance FromHttpApiData [Tagger]    where parseUrlPiece = readTextData
 157 instance ToParamSchema   DisplayMode
 158 instance ToParamSchema   ExportMode
 159 instance ToParamSchema   Filiation
 160 instance ToParamSchema   Tagger
 161 instance ToParamSchema Metric
 162 instance ToParamSchema Order
 163 instance ToParamSchema Sort
 164 instance ToSchema Order
 165