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 FlexibleContexts   #-}
  21 {-# LANGUAGE FlexibleInstances  #-}
  22 {-# LANGUAGE MultiParamTypeClasses #-}
  23
  24 module Gargantext.Viz.Phylo.API
  25   where
  26
  27 import Data.String.Conversions
  28 --import Control.Monad.Reader (ask)
  29 import qualified Data.ByteString as DB
  30 import qualified Data.ByteString.Lazy as DBL
  31 import Data.Swagger
  32 import Gargantext.API.Types
  33 import Gargantext.Database.Types.Node (PhyloId, ListId, CorpusId)
  34 import Gargantext.Database.Schema.Node (insertNodes, nodePhyloW, getNodePhylo)
  35 import Gargantext.Database.Types.Node -- (NodePhylo(..))
  36 import Gargantext.Prelude
  37 import Gargantext.Viz.Phylo
  38 import Gargantext.Viz.Phylo.Main
  39 import Gargantext.Viz.Phylo.Example
  40 import Gargantext.Core.Types (TODO(..))
  41 import Servant
  42 import Test.QuickCheck (elements)
  43 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  44 import Web.HttpApiData (parseUrlPiece, readTextData)
  45 import Network.HTTP.Media ((//), (/:))
  46
  47 ------------------------------------------------------------------------
  48 type PhyloAPI = Summary "Phylo API"
  49               :> GetPhylo
  50         --    :<|> PutPhylo
  51             :<|> PostPhylo
  52
  53
  54 phyloAPI :: PhyloId -> UserId -> GargServer PhyloAPI
  55 phyloAPI n u = getPhylo  n
  56         :<|> postPhylo n u
  57         -- :<|> putPhylo  n
  58         -- :<|> deletePhylo  n
  59
  60 newtype SVG = SVG DB.ByteString
  61
  62 instance ToSchema SVG
  63   where
  64     declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy TODO)
  65
  66 instance Show SVG where
  67   show (SVG a) = show a
  68
  69 instance Accept SVG where
  70    contentType _ = "SVG" // "image/svg+xml" /: ("charset", "utf-8")
  71
  72 instance Show a => MimeRender PlainText a where
  73    mimeRender _ val = cs ("" <> show val)
  74
  75 instance MimeRender SVG SVG where
  76    mimeRender _ (SVG s) = DBL.fromStrict s
  77
  78 ------------------------------------------------------------------------
  79 type GetPhylo =  QueryParam "listId"      ListId
  80               :> QueryParam "level"       Level
  81               :> QueryParam "minSizeBranch" MinSizeBranch
  82    {-           :> QueryParam "filiation"   Filiation
  83               :> QueryParam "childs"      Bool
  84               :> QueryParam "depth"       Level
  85               :> QueryParam "metrics"    [Metric]
  86               :> QueryParam "periodsInf" Int
  87               :> QueryParam "periodsSup" Int
  88               :> QueryParam "minNodes"   Int
  89               :> QueryParam "taggers"    [Tagger]
  90               :> QueryParam "sort"       Sort
  91               :> QueryParam "order"      Order
  92               :> QueryParam "export"    ExportMode
  93               :> QueryParam "display"    DisplayMode
  94               :> QueryParam "verbose"     Bool
  95     -}
  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 getPhylo phId _lId l msb  = do
 104   phNode     <- getNodePhylo phId
 105   let
 106     level = maybe 2 identity l
 107     branc = maybe 2 identity msb
 108     maybePhylo = hyperdataPhylo_data $ _node_hyperdata phNode
 109
 110   p <- liftBase $ 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 = 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   phy  <- flowPhylo n
 126   pId <- insertNodes [nodePhyloW (Just "Phylo") (Just $ HyperdataPhylo Nothing (Just phy)) 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 Order
 156
 157 instance ToParamSchema Order
 158 instance FromHttpApiData Order
 159   where
 160     parseUrlPiece = readTextData
 161
 162
 163 instance ToParamSchema Metric
 164 instance FromHttpApiData [Metric]
 165   where
 166     parseUrlPiece = readTextData
 167 instance FromHttpApiData Metric
 168   where
 169     parseUrlPiece = readTextData
 170
 171
 172 instance ToParamSchema   DisplayMode
 173 instance FromHttpApiData DisplayMode
 174   where
 175     parseUrlPiece = readTextData
 176
 177
 178 instance ToParamSchema   ExportMode
 179 instance FromHttpApiData ExportMode
 180   where
 181     parseUrlPiece = readTextData
 182
 183
 184 instance FromHttpApiData Sort
 185   where
 186     parseUrlPiece = readTextData
 187 instance ToParamSchema Sort
 188
 189 instance FromHttpApiData [Tagger]
 190   where
 191     parseUrlPiece = readTextData
 192 instance FromHttpApiData Tagger
 193   where
 194     parseUrlPiece = readTextData
 195 instance ToParamSchema   Tagger
 196
 197 instance FromHttpApiData Filiation
 198   where
 199     parseUrlPiece = readTextData
 200 instance ToParamSchema   Filiation
 201
 202