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