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 Control.Monad.Reader (ask)
  27 import qualified Data.ByteString as DB
  28 import Data.Text (Text)
  29 import Data.Map  (empty)
  30 import Data.Swagger
  31 import Gargantext.API.Types
  32 import Gargantext.Database.Types.Node (PhyloId, ListId, CorpusId)
  33 import Gargantext.Prelude
  34 import Gargantext.Viz.Phylo
  35 import Gargantext.Viz.Phylo.Main
  36 import Gargantext.Viz.Phylo.Aggregates
  37 import Gargantext.Viz.Phylo.Example
  38 import Gargantext.Viz.Phylo.Tools
  39 --import Gargantext.Viz.Phylo.View.ViewMaker
  40 import Gargantext.Viz.Phylo.LevelMaker
  41 import Servant
  42 import Servant.Job.Utils (swaggerOptions)
  43 import Test.QuickCheck (elements)
  44 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  45 import Web.HttpApiData (parseUrlPiece, readTextData)
  46 import Control.Monad.IO.Class (liftIO)
  47 import Network.HTTP.Media ((//), (/:))
  48
  49 ------------------------------------------------------------------------
  50 type PhyloAPI = Summary "Phylo API"
  51               :> GetPhylo
  52         --    :<|> PutPhylo
  53             :<|> PostPhylo
  54
  55
  56 phyloAPI :: PhyloId -> GargServer PhyloAPI
  57 phyloAPI n = getPhylo'  n
  58         -- :<|> putPhylo  n
  59         :<|> postPhylo n
  60
  61 newtype SVG = SVG DB.ByteString
  62
  63 instance ToSchema SVG
  64   where
  65     declareNamedSchema = undefined
  66     --genericDeclareNamedSchemaUnrestricted (swaggerOptions "")
  67
  68 instance Show SVG where
  69   show (SVG a) = show a
  70
  71 instance Accept SVG where
  72    contentType _ = "SVG" // "image/svg+xml" /: ("charset", "utf-8")
  73
  74 instance Show a => MimeRender PlainText a where
  75    mimeRender _ val = cs ("" <> show val)
  76
  77 instance Show a => MimeRender SVG a where
  78    mimeRender _ val = cs ("" <> show val)
  79
  80 ------------------------------------------------------------------------
  81 type GetPhylo =  QueryParam "listId"      ListId
  82               :> QueryParam "level"       Level
  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 {-
 102 getPhylo :: PhyloId -> GargServer GetPhylo
 103 getPhylo _phyloId _lId l f b l' ms x y z ts s o e d b' = do
 104   let
 105     fs' = maybe (Just []) (\p -> Just [p]) $ LonelyBranch <$> (LBParams <$> x <*> y <*> z)
 106     so  = (,) <$> s <*> o
 107     q = initPhyloQueryView l f b l' ms fs' ts so e d b'
 108   -- | TODO remove phylo for real data here
 109   pure (toPhyloView  q phylo)
 110   -- TODO remove phylo for real data here
 111 -}
 112
 113 getPhylo' :: PhyloId -> GargServer GetPhylo
 114 getPhylo' _phyloId _lId _l _f _b _l' _ms _x _y _z _ts _s _o _e _d _b' = do
 115   p <- liftIO $ viewPhylo2Svg phyloView
 116   pure (SVG p)
 117 ------------------------------------------------------------------------
 118 {-
 119 type PutPhylo = (Put '[JSON] Phylo  )
 120 --putPhylo :: PhyloId -> Maybe ListId -> PhyloQueryBuild -> Phylo
 121 putPhylo :: PhyloId -> GargServer PutPhylo
 122 putPhylo = undefined
 123 -}
 124 ------------------------------------------------------------------------
 125 type PostPhylo =  QueryParam "listId" ListId
 126                :> ReqBody '[JSON] PhyloQueryBuild
 127                :> (Post '[JSON] Phylo)
 128
 129 postPhylo :: CorpusId -> GargServer PostPhylo
 130 postPhylo _n _lId q = do
 131   -- TODO get Reader settings
 132   -- s <- ask
 133   let
 134     vrs = Just ("1" :: Text)
 135     sft = Just (Software "Gargantext" "4")
 136     prm = initPhyloParam vrs sft (Just q)
 137   pure (toPhyloBase q prm (parseDocs (initFoundationsRoots actants) corpus) termList empty)
 138
 139
 140 ------------------------------------------------------------------------
 141 -- | DELETE Phylo == delete a node
 142 ------------------------------------------------------------------------
 143
 144
 145
 146
 147 -- | Instances
 148 instance Arbitrary PhyloView
 149   where
 150     arbitrary = elements [phyloView]
 151
 152 -- | TODO add phyloGroup ex
 153 instance Arbitrary PhyloGroup
 154   where
 155     arbitrary = elements []
 156
 157 instance Arbitrary Phylo
 158   where
 159     arbitrary = elements [phylo]
 160
 161
 162 instance ToSchema Cluster
 163 instance ToSchema EdgeType
 164 instance ToSchema Filiation
 165 instance ToSchema Filter
 166 instance ToSchema FisParams
 167 instance ToSchema HammingParams
 168 instance ToSchema LouvainParams
 169 instance ToSchema Metric
 170 instance ToSchema Order
 171 instance ToSchema Phylo
 172 instance ToSchema PhyloFis
 173 instance ToSchema PhyloBranch
 174 instance ToSchema PhyloEdge
 175 instance ToSchema PhyloGroup
 176 instance ToSchema PhyloLevel
 177 instance ToSchema PhyloNode
 178 instance ToSchema PhyloParam
 179 instance ToSchema PhyloFoundations
 180 instance ToSchema PhyloPeriod
 181 instance ToSchema PhyloQueryBuild
 182 instance ToSchema PhyloView
 183 instance ToSchema RCParams
 184 instance ToSchema LBParams
 185 instance ToSchema SBParams
 186 instance ToSchema Software
 187 instance ToSchema WLJParams
 188
 189
 190 instance ToParamSchema Order
 191 instance FromHttpApiData Order
 192   where
 193     parseUrlPiece = readTextData
 194
 195
 196 instance ToParamSchema Metric
 197 instance FromHttpApiData [Metric]
 198   where
 199     parseUrlPiece = readTextData
 200 instance FromHttpApiData Metric
 201   where
 202     parseUrlPiece = readTextData
 203
 204
 205 instance ToParamSchema   DisplayMode
 206 instance FromHttpApiData DisplayMode
 207   where
 208     parseUrlPiece = readTextData
 209
 210
 211 instance ToParamSchema   ExportMode
 212 instance FromHttpApiData ExportMode
 213   where
 214     parseUrlPiece = readTextData
 215
 216
 217 instance FromHttpApiData Sort
 218   where
 219     parseUrlPiece = readTextData
 220 instance ToParamSchema Sort
 221
 222
 223 instance ToSchema Proximity
 224   where
 225     declareNamedSchema = genericDeclareNamedSchemaUnrestricted
 226                        $ swaggerOptions ""
 227
 228
 229 instance FromHttpApiData [Tagger]
 230   where
 231     parseUrlPiece = readTextData
 232 instance FromHttpApiData Tagger
 233   where
 234     parseUrlPiece = readTextData
 235 instance ToParamSchema   Tagger
 236
 237 instance FromHttpApiData Filiation
 238   where
 239     parseUrlPiece = readTextData
 240 instance ToParamSchema   Filiation
 241
 242