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     -}
  97               :> Get '[SVG] SVG
  98
  99 -- | TODO
 100 -- Add real text processing
 101 -- Fix Filter parameters
 102 getPhylo :: PhyloId -> GargServer GetPhylo
 103 --getPhylo phId _lId l msb _f _b _l' _ms _x _y _z _ts _s _o _e _d _b' = do
 104 getPhylo phId _lId l msb  = do
 105   phNode     <- getNodePhylo phId
 106   let
 107     level = maybe 2 identity l
 108     branc = maybe 2 identity msb
 109     maybePhylo = hyperdataPhylo_data $ _node_hyperdata phNode
 110
 111   p <- liftIO $ viewPhylo2Svg $ viewPhylo level branc  $ maybe phyloFromQuery identity maybePhylo
 112   pure (SVG p)
 113 ------------------------------------------------------------------------
 114 type PostPhylo =  QueryParam "listId" ListId
 115                -- :> ReqBody '[JSON] PhyloQueryBuild
 116                :> (Post '[JSON] NodeId)
 117
 118 postPhylo :: CorpusId -> UserId -> GargServer PostPhylo
 119 postPhylo n userId _lId = do
 120   -- TODO get Reader settings
 121   -- s <- ask
 122   let
 123     -- _vrs = Just ("1" :: Text)
 124     -- _sft = Just (Software "Gargantext" "4")
 125     -- _prm = initPhyloParam vrs sft (Just q)
 126   phy  <- flowPhylo n
 127   pId <- insertNodes [nodePhyloW (Just "Phylo") (Just $ HyperdataPhylo Nothing (Just phy)) n userId]
 128   pure $ NodeId (fromIntegral pId)
 129
 130 ------------------------------------------------------------------------
 131 -- | DELETE Phylo == delete a node
 132 ------------------------------------------------------------------------
 133 ------------------------------------------------------------------------
 134 {-
 135 type PutPhylo = (Put '[JSON] Phylo  )
 136 --putPhylo :: PhyloId -> Maybe ListId -> PhyloQueryBuild -> Phylo
 137 putPhylo :: PhyloId -> GargServer PutPhylo
 138 putPhylo = undefined
 139 -}
 140
 141
 142 -- | Instances
 143 instance Arbitrary PhyloView
 144   where
 145     arbitrary = elements [phyloView]
 146
 147 -- | TODO add phyloGroup ex
 148 instance Arbitrary PhyloGroup
 149   where
 150     arbitrary = elements []
 151
 152 instance Arbitrary Phylo
 153   where
 154     arbitrary = elements [phylo]
 155
 156 instance ToSchema Cluster
 157 instance ToSchema EdgeType
 158 instance ToSchema Filiation
 159 instance ToSchema Filter
 160 instance ToSchema FisParams
 161 instance ToSchema HammingParams
 162 instance ToSchema LouvainParams
 163 instance ToSchema Metric
 164 instance ToSchema Order
 165 instance ToSchema Phylo
 166 instance ToSchema PhyloFis
 167 instance ToSchema PhyloBranch
 168 instance ToSchema PhyloEdge
 169 instance ToSchema PhyloGroup
 170 instance ToSchema PhyloLevel
 171 instance ToSchema PhyloNode
 172 instance ToSchema PhyloParam
 173 instance ToSchema PhyloFoundations
 174 instance ToSchema PhyloPeriod
 175 instance ToSchema PhyloQueryBuild
 176 instance ToSchema PhyloView
 177 instance ToSchema RCParams
 178 instance ToSchema LBParams
 179 instance ToSchema SBParams
 180 instance ToSchema Software
 181 instance ToSchema WLJParams
 182
 183
 184 instance ToParamSchema Order
 185 instance FromHttpApiData Order
 186   where
 187     parseUrlPiece = readTextData
 188
 189
 190 instance ToParamSchema Metric
 191 instance FromHttpApiData [Metric]
 192   where
 193     parseUrlPiece = readTextData
 194 instance FromHttpApiData Metric
 195   where
 196     parseUrlPiece = readTextData
 197
 198
 199 instance ToParamSchema   DisplayMode
 200 instance FromHttpApiData DisplayMode
 201   where
 202     parseUrlPiece = readTextData
 203
 204
 205 instance ToParamSchema   ExportMode
 206 instance FromHttpApiData ExportMode
 207   where
 208     parseUrlPiece = readTextData
 209
 210
 211 instance FromHttpApiData Sort
 212   where
 213     parseUrlPiece = readTextData
 214 instance ToParamSchema Sort
 215
 216
 217 instance ToSchema Proximity
 218   where
 219     declareNamedSchema = genericDeclareNamedSchemaUnrestricted
 220                        $ swaggerOptions ""
 221
 222
 223 instance FromHttpApiData [Tagger]
 224   where
 225     parseUrlPiece = readTextData
 226 instance FromHttpApiData Tagger
 227   where
 228     parseUrlPiece = readTextData
 229 instance ToParamSchema   Tagger
 230
 231 instance FromHttpApiData Filiation
 232   where
 233     parseUrlPiece = readTextData
 234 instance ToParamSchema   Filiation
 235
 236