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