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