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