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