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 RankNTypes         #-}
  15 {-# LANGUAGE DataKinds          #-}
  16 {-# LANGUAGE NoImplicitPrelude  #-}
  17 {-# LANGUAGE OverloadedStrings  #-}   -- allows to write Text literals
  18 {-# LANGUAGE OverloadedLists    #-}   -- allows to write Map and HashMap as lists
  19 {-# LANGUAGE TypeOperators      #-}
  20 {-# LANGUAGE FlexibleInstances  #-}
  21 {-# LANGUAGE MultiParamTypeClasses #-}
  22
  23 module Gargantext.Viz.Phylo.API
  24   where
  25
  26 import Data.String.Conversions
  27 --import Control.Monad.Reader (ask)
  28 import qualified Data.ByteString as DB
  29 import qualified Data.ByteString.Lazy as DBL
  30 import Data.Swagger
  31 import Gargantext.API.Types
  32 import Gargantext.Database.Types.Node (PhyloId, ListId, CorpusId)
  33 import Gargantext.Database.Schema.Node (insertNodes, nodePhyloW, getNodePhylo)
  34 import Gargantext.Database.Types.Node -- (NodePhylo(..))
  35 import Gargantext.Prelude
  36 import Gargantext.Viz.Phylo
  37 import Gargantext.Viz.Phylo.Main
  38 import Gargantext.Viz.Phylo.Example
  39 import Gargantext.API.Ngrams (TODO(..))
  40 import Servant
  41 import Servant.Job.Utils (swaggerOptions)
  42 import Test.QuickCheck (elements)
  43 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  44 import Web.HttpApiData (parseUrlPiece, readTextData)
  45 import Control.Monad.IO.Class (liftIO)
  46 import Network.HTTP.Media ((//), (/:))
  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
  63 instance ToSchema SVG
  64   where
  65     declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy TODO)
  66
  67 instance Show SVG where
  68   show (SVG a) = show a
  69
  70 instance Accept SVG where
  71    contentType _ = "SVG" // "image/svg+xml" /: ("charset", "utf-8")
  72
  73 instance Show a => MimeRender PlainText a where
  74    mimeRender _ val = cs ("" <> show val)
  75
  76 instance MimeRender SVG SVG where
  77    mimeRender _ (SVG s) = DBL.fromStrict s
  78
  79 ------------------------------------------------------------------------
  80 type GetPhylo =  QueryParam "listId"      ListId
  81               :> QueryParam "level"       Level
  82               :> QueryParam "minSizeBranch" MinSizeBranch
  83               :> QueryParam "filiation"   Filiation
  84               :> QueryParam "childs"      Bool
  85               :> QueryParam "depth"       Level
  86               :> QueryParam "metrics"    [Metric]
  87               :> QueryParam "periodsInf" Int
  88               :> QueryParam "periodsSup" Int
  89               :> QueryParam "minNodes"   Int
  90               :> QueryParam "taggers"    [Tagger]
  91               :> QueryParam "sort"       Sort
  92               :> QueryParam "order"      Order
  93               :> QueryParam "export"    ExportMode
  94               :> QueryParam "display"    DisplayMode
  95               :> QueryParam "verbose"     Bool
  96               :> Get '[SVG] SVG
  97
  98 -- | TODO
  99 -- Add real text processing
 100 -- Fix Filter parameters
 101 getPhylo :: PhyloId -> GargServer GetPhylo
 102 getPhylo phId _lId l msb _f _b _l' _ms _x _y _z _ts _s _o _e _d _b' = do
 103   phNode     <- getNodePhylo phId
 104
 105   let
 106     level = maybe 1 identity l
 107     branc = maybe 2 identity msb
 108     maybePhylo = hyperdataPhylo_data $ _node_hyperdata phNode
 109
 110   p <- liftIO $ viewPhylo2Svg $ viewPhylo level branc  $ maybe phyloFromQuery identity maybePhylo
 111   pure (SVG p)
 112 ------------------------------------------------------------------------
 113 type PostPhylo =  QueryParam "listId" ListId
 114                :> ReqBody '[JSON] PhyloQueryBuild
 115                :> (Post '[JSON] NodeId)
 116
 117 postPhylo :: CorpusId -> UserId -> GargServer PostPhylo
 118 postPhylo n userId _lId _q = do
 119   -- TODO get Reader settings
 120   -- s <- ask
 121   let
 122     -- _vrs = Just ("1" :: Text)
 123     -- _sft = Just (Software "Gargantext" "4")
 124     -- _prm = initPhyloParam vrs sft (Just q)
 125   ph <- flowPhylo n
 126   pId <- insertNodes [nodePhyloW (Just "Phylo") (Just $ HyperdataPhylo Nothing (Just ph)) n userId]
 127   pure $ NodeId (fromIntegral pId)
 128
 129 ------------------------------------------------------------------------
 130 -- | DELETE Phylo == delete a node
 131 ------------------------------------------------------------------------
 132 ------------------------------------------------------------------------
 133 {-
 134 type PutPhylo = (Put '[JSON] Phylo  )
 135 --putPhylo :: PhyloId -> Maybe ListId -> PhyloQueryBuild -> Phylo
 136 putPhylo :: PhyloId -> GargServer PutPhylo
 137 putPhylo = undefined
 138 -}
 139
 140
 141 -- | Instances
 142 instance Arbitrary PhyloView
 143   where
 144     arbitrary = elements [phyloView]
 145
 146 -- | TODO add phyloGroup ex
 147 instance Arbitrary PhyloGroup
 148   where
 149     arbitrary = elements []
 150
 151 instance Arbitrary Phylo
 152   where
 153     arbitrary = elements [phylo]
 154
 155 instance ToSchema Cluster
 156 instance ToSchema EdgeType
 157 instance ToSchema Filiation
 158 instance ToSchema Filter
 159 instance ToSchema FisParams
 160 instance ToSchema HammingParams
 161 instance ToSchema LouvainParams
 162 instance ToSchema Metric
 163 instance ToSchema Order
 164 instance ToSchema Phylo
 165 instance ToSchema PhyloFis
 166 instance ToSchema PhyloBranch
 167 instance ToSchema PhyloEdge
 168 instance ToSchema PhyloGroup
 169 instance ToSchema PhyloLevel
 170 instance ToSchema PhyloNode
 171 instance ToSchema PhyloParam
 172 instance ToSchema PhyloFoundations
 173 instance ToSchema PhyloPeriod
 174 instance ToSchema PhyloQueryBuild
 175 instance ToSchema PhyloView
 176 instance ToSchema RCParams
 177 instance ToSchema LBParams
 178 instance ToSchema SBParams
 179 instance ToSchema Software
 180 instance ToSchema WLJParams
 181
 182
 183 instance ToParamSchema Order
 184 instance FromHttpApiData Order
 185   where
 186     parseUrlPiece = readTextData
 187
 188
 189 instance ToParamSchema Metric
 190 instance FromHttpApiData [Metric]
 191   where
 192     parseUrlPiece = readTextData
 193 instance FromHttpApiData Metric
 194   where
 195     parseUrlPiece = readTextData
 196
 197
 198 instance ToParamSchema   DisplayMode
 199 instance FromHttpApiData DisplayMode
 200   where
 201     parseUrlPiece = readTextData
 202
 203
 204 instance ToParamSchema   ExportMode
 205 instance FromHttpApiData ExportMode
 206   where
 207     parseUrlPiece = readTextData
 208
 209
 210 instance FromHttpApiData Sort
 211   where
 212     parseUrlPiece = readTextData
 213 instance ToParamSchema Sort
 214
 215
 216 instance ToSchema Proximity
 217   where
 218     declareNamedSchema = genericDeclareNamedSchemaUnrestricted
 219                        $ swaggerOptions ""
 220
 221
 222 instance FromHttpApiData [Tagger]
 223   where
 224     parseUrlPiece = readTextData
 225 instance FromHttpApiData Tagger
 226   where
 227     parseUrlPiece = readTextData
 228 instance ToParamSchema   Tagger
 229
 230 instance FromHttpApiData Filiation
 231   where
 232     parseUrlPiece = readTextData
 233 instance ToParamSchema   Filiation
 234
 235