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