src/Gargantext/Viz/Phylo/API.hs

   1 {-|
   2 Module      : Gargantext.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.Viz.Phylo.API
  18   where
  19
  20 import Control.Lens ((^.))
  21 import Data.String.Conversions
  22 --import Control.Monad.Reader (ask)
  23 import qualified Data.ByteString as DB
  24 import qualified Data.ByteString.Lazy as DBL
  25 import Data.Proxy (Proxy(..))
  26 import Data.Swagger
  27 import Network.HTTP.Media ((//), (/:))
  28 import Servant
  29 import Test.QuickCheck (elements)
  30 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  31 import Web.HttpApiData (parseUrlPiece, readTextData)
  32
  33 import Gargantext.API.Prelude
  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 (insertNodes, node, getNodeWith)
  37 import Gargantext.Database.Schema.Node (node_hyperdata)
  38 import Gargantext.Prelude
  39 import Gargantext.Viz.Phylo
  40 import Gargantext.Viz.Phylo.Main
  41 import Gargantext.Viz.Phylo.Example
  42 import Gargantext.Core.Types (TODO(..))
  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
  59 instance ToSchema SVG
  60   where
  61     declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy TODO)
  62
  63 instance Show SVG where
  64   show (SVG a) = show a
  65
  66 instance Accept SVG where
  67    contentType _ = "SVG" // "image/svg+xml" /: ("charset", "utf-8")
  68
  69 instance Show a => MimeRender PlainText a where
  70    mimeRender _ val = cs ("" <> show val)
  71
  72 instance MimeRender SVG SVG where
  73    mimeRender _ (SVG s) = DBL.fromStrict s
  74
  75 ------------------------------------------------------------------------
  76 type GetPhylo =  QueryParam "listId"      ListId
  77               :> QueryParam "level"       Level
  78               :> QueryParam "minSizeBranch" MinSizeBranch
  79    {-           :> QueryParam "filiation"   Filiation
  80               :> QueryParam "childs"      Bool
  81               :> QueryParam "depth"       Level
  82               :> QueryParam "metrics"    [Metric]
  83               :> QueryParam "periodsInf" Int
  84               :> QueryParam "periodsSup" Int
  85               :> QueryParam "minNodes"   Int
  86               :> QueryParam "taggers"    [Tagger]
  87               :> QueryParam "sort"       Sort
  88               :> QueryParam "order"      Order
  89               :> QueryParam "export"    ExportMode
  90               :> QueryParam "display"    DisplayMode
  91               :> QueryParam "verbose"     Bool
  92     -}
  93               :> Get '[SVG] SVG
  94
  95 -- | TODO
  96 -- Add real text processing
  97 -- Fix Filter parameters
  98 getPhylo :: PhyloId -> GargServer GetPhylo
  99 getPhylo phId _lId l msb  = do
 100   phNode     <- getNodeWith phId (Proxy :: Proxy HyperdataPhylo)
 101   let
 102     level = maybe 2 identity l
 103     branc = maybe 2 identity msb
 104     maybePhylo = phNode ^. (node_hyperdata . hp_data)
 105
 106   p <- liftBase $ viewPhylo2Svg
 107                 $ viewPhylo level branc
 108                 $ maybe phyloFromQuery identity maybePhylo
 109   pure (SVG p)
 110 ------------------------------------------------------------------------
 111 type PostPhylo =  QueryParam "listId" ListId
 112                -- :> ReqBody '[JSON] PhyloQueryBuild
 113                :> (Post '[JSON] NodeId)
 114
 115 postPhylo :: CorpusId -> UserId -> GargServer PostPhylo
 116 postPhylo n userId _lId = do
 117   -- TODO get Reader settings
 118   -- s <- ask
 119   let
 120     -- _vrs = Just ("1" :: Text)
 121     -- _sft = Just (Software "Gargantext" "4")
 122     -- _prm = initPhyloParam vrs sft (Just q)
 123   phy  <- flowPhylo n
 124   pId <- insertNodes [node NodePhylo "Phylo" (HyperdataPhylo Nothing (Just phy)) (Just n) userId]
 125   pure $ NodeId (fromIntegral pId)
 126
 127 ------------------------------------------------------------------------
 128 -- | DELETE Phylo == delete a node
 129 ------------------------------------------------------------------------
 130 ------------------------------------------------------------------------
 131 {-
 132 type PutPhylo = (Put '[JSON] Phylo  )
 133 --putPhylo :: PhyloId -> Maybe ListId -> PhyloQueryBuild -> Phylo
 134 putPhylo :: PhyloId -> GargServer PutPhylo
 135 putPhylo = undefined
 136 -}
 137
 138
 139 -- | Instances
 140 instance Arbitrary PhyloView
 141   where
 142     arbitrary = elements [phyloView]
 143
 144 -- | TODO add phyloGroup ex
 145 instance Arbitrary PhyloGroup
 146   where
 147     arbitrary = elements []
 148
 149 instance Arbitrary Phylo
 150   where
 151     arbitrary = elements [phylo]
 152
 153 instance ToSchema Order
 154
 155 instance ToParamSchema Order
 156 instance FromHttpApiData Order
 157   where
 158     parseUrlPiece = readTextData
 159
 160
 161 instance ToParamSchema Metric
 162 instance FromHttpApiData [Metric]
 163   where
 164     parseUrlPiece = readTextData
 165 instance FromHttpApiData Metric
 166   where
 167     parseUrlPiece = readTextData
 168
 169
 170 instance ToParamSchema   DisplayMode
 171 instance FromHttpApiData DisplayMode
 172   where
 173     parseUrlPiece = readTextData
 174
 175
 176 instance ToParamSchema   ExportMode
 177 instance FromHttpApiData ExportMode
 178   where
 179     parseUrlPiece = readTextData
 180
 181
 182 instance FromHttpApiData Sort
 183   where
 184     parseUrlPiece = readTextData
 185 instance ToParamSchema Sort
 186
 187 instance FromHttpApiData [Tagger]
 188   where
 189     parseUrlPiece = readTextData
 190 instance FromHttpApiData Tagger
 191   where
 192     parseUrlPiece = readTextData
 193 instance ToParamSchema   Tagger
 194
 195 instance FromHttpApiData Filiation
 196   where
 197     parseUrlPiece = readTextData
 198 instance ToParamSchema   Filiation
 199
 200