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