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 (phyloCleopatre)
  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   maybePhyloData <- getPhyloData phyloId
 122   let phyloData = fromMaybe phyloCleopatre maybePhyloData
 123   phyloJson <- liftBase $ phylo2dot2json phyloData
 124   pure phyloJson
 125
 126
 127 -- getPhyloDataSVG phId _lId l msb  = do
 128   -- let
 129   --   level = fromMaybe 2 l
 130   --   branc = fromMaybe 2 msb
 131   --   maybePhylo = phNode ^. (node_hyperdata . hp_data)
 132
 133   -- p <- liftBase $ viewPhylo2Svg
 134   --               $ viewPhylo level branc
 135   --               $ fromMaybe phyloFromQuery maybePhylo
 136   -- pure (SVG p)
 137
 138
 139 ------------------------------------------------------------------------
 140 type PostPhylo =  QueryParam "listId" ListId
 141                -- :> ReqBody '[JSON] PhyloQueryBuild
 142                :> (Post '[JSON] NodeId)
 143
 144 postPhylo :: PhyloId -> UserId -> GargServer PostPhylo
 145 postPhylo phyloId _userId _lId = do
 146   -- TODO get Reader settings
 147   -- s <- ask
 148   -- let
 149     -- _vrs = Just ("1" :: Text)
 150     -- _sft = Just (Software "Gargantext" "4")
 151     -- _prm = initPhyloParam vrs sft (Just q)
 152   corpusId <- getClosestParentIdByType phyloId NodeCorpus
 153   phy <- flowPhyloAPI defaultConfig (fromMaybe (panic "[G.C.V.P.API] no corpus ID found") corpusId) -- params
 154   -- phyloId <- insertNodes [node NodePhylo "Phylo" (HyperdataPhylo Nothing (Just phy)) (Just corpusId) userId]
 155   _ <- updateHyperdata phyloId (HyperdataPhylo Nothing (Just phy))
 156   pure phyloId
 157
 158 ------------------------------------------------------------------------
 159 -- | DELETE Phylo == delete a node
 160 ------------------------------------------------------------------------
 161 ------------------------------------------------------------------------
 162 {-
 163 type PutPhylo = (Put '[JSON] Phylo  )
 164 --putPhylo :: PhyloId -> Maybe ListId -> PhyloQueryBuild -> Phylo
 165 putPhylo :: PhyloId -> GargServer PutPhylo
 166 putPhylo = undefined
 167 -}
 168
 169
 170 -- | Instances
 171 -- instance Arbitrary Phylo             where arbitrary     = elements [phylo]
 172 instance Arbitrary PhyloGroup        where arbitrary     = elements []
 173 -- instance Arbitrary PhyloView         where arbitrary     = elements [phyloView]
 174 instance FromHttpApiData DisplayMode where parseUrlPiece = readTextData
 175 instance FromHttpApiData ExportMode  where parseUrlPiece = readTextData
 176 instance FromHttpApiData Filiation   where parseUrlPiece = readTextData
 177 instance FromHttpApiData Metric      where parseUrlPiece = readTextData
 178 instance FromHttpApiData Order       where parseUrlPiece = readTextData
 179 instance FromHttpApiData Sort        where parseUrlPiece = readTextData
 180 instance FromHttpApiData Tagger      where parseUrlPiece = readTextData
 181 instance FromHttpApiData [Metric]    where parseUrlPiece = readTextData
 182 instance FromHttpApiData [Tagger]    where parseUrlPiece = readTextData
 183 instance ToParamSchema   DisplayMode
 184 instance ToParamSchema   ExportMode
 185 instance ToParamSchema   Filiation
 186 instance ToParamSchema   Tagger
 187 instance ToParamSchema Metric
 188 instance ToParamSchema Order
 189 instance ToParamSchema Sort
 190 instance ToSchema Order
 191