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
  13 {-# OPTIONS_GHC -fno-warn-orphans #-}
  14
  15
  16 {-# LANGUAGE RankNTypes         #-}
  17 {-# LANGUAGE DataKinds          #-}
  18 {-# LANGUAGE NoImplicitPrelude  #-}
  19 {-# LANGUAGE OverloadedStrings  #-}   -- allows to write Text literals
  20 {-# LANGUAGE OverloadedLists    #-}   -- allows to write Map and HashMap as lists
  21 {-# LANGUAGE TypeOperators      #-}
  22 {-# LANGUAGE FlexibleInstances  #-}
  23
  24 module Gargantext.Viz.Phylo.API
  25   where
  26
  27 --import Control.Monad.Reader (ask)
  28 import Data.Text (Text)
  29 import Data.Swagger
  30 import Gargantext.API.Types
  31 import Gargantext.Database.Types.Node (PhyloId, ListId, CorpusId)
  32 import Gargantext.Prelude
  33 import Gargantext.Viz.Phylo
  34 import Gargantext.Viz.Phylo.Example
  35 import Gargantext.Viz.Phylo.Tools
  36 import Gargantext.Viz.Phylo.View.ViewMaker
  37 import Gargantext.Viz.Phylo.LevelMaker
  38 import Servant
  39 import Servant.Job.Utils (swaggerOptions)
  40 import Test.QuickCheck (elements)
  41 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  42 import Web.HttpApiData (parseUrlPiece, readTextData)
  43
  44 ------------------------------------------------------------------------
  45 type PhyloAPI = Summary "Phylo API"
  46               :> GetPhylo
  47         --    :<|> PutPhylo
  48             :<|> PostPhylo
  49
  50
  51 phyloAPI :: PhyloId -> GargServer PhyloAPI
  52 phyloAPI n = getPhylo  n
  53         -- :<|> putPhylo  n
  54         :<|> postPhylo n
  55
  56 ------------------------------------------------------------------------
  57 type GetPhylo =  QueryParam "listId"      ListId
  58               :> QueryParam "level"       Level
  59               :> QueryParam "filiation"   Filiation
  60               :> QueryParam "childs"      Bool
  61               :> QueryParam "depth"       Level
  62               :> QueryParam "metrics"    [Metric]
  63               :> QueryParam "periodsInf" Int
  64               :> QueryParam "periodsSup" Int
  65               :> QueryParam "minNodes"   Int
  66               :> QueryParam "taggers"    [Tagger]
  67               :> QueryParam "sort"       Sort
  68               :> QueryParam "order"      Order
  69               :> QueryParam "display"    DisplayMode
  70               :> QueryParam "verbose"     Bool
  71               :> Get '[JSON] PhyloView
  72
  73 -- | TODO
  74 -- Add real text processing
  75 -- Fix Filter parameters
  76 getPhylo :: PhyloId -> GargServer GetPhylo
  77 getPhylo _phyloId _lId l f b l' ms x y z ts s o d b' = do
  78   let
  79     fs' = maybe (Just []) (\p -> Just [p]) $ SmallBranch <$> (SBParams <$> x <*> y <*> z)
  80     so  = (,) <$> s <*> o
  81     q = initPhyloQueryView l f b l' ms fs' ts so d b'
  82   pure (toPhyloView  q phylo)
  83   -- TODO remove phylo for real data here
  84
  85 ------------------------------------------------------------------------
  86 {-
  87 type PutPhylo = (Put '[JSON] Phylo  )
  88 --putPhylo :: PhyloId -> Maybe ListId -> PhyloQueryBuild -> Phylo
  89 putPhylo :: PhyloId -> GargServer PutPhylo
  90 putPhylo = undefined
  91 -}
  92 ------------------------------------------------------------------------
  93 type PostPhylo =  QueryParam "listId" ListId
  94                :> ReqBody '[JSON] PhyloQueryBuild
  95                :> (Post '[JSON] Phylo)
  96
  97 postPhylo :: CorpusId -> GargServer PostPhylo
  98 postPhylo _n _lId q = do
  99   -- TODO get Reader settings
 100   -- s <- ask
 101   let
 102     vrs = Just ("1" :: Text)
 103     sft = Just (Software "Gargantext" "4")
 104     prm = initPhyloParam vrs sft (Just q)
 105   pure (toPhyloBase q prm corpus actants actantsTrees)
 106
 107
 108 ------------------------------------------------------------------------
 109 -- | DELETE Phylo == delete a node
 110 ------------------------------------------------------------------------
 111
 112
 113
 114
 115 -- | Instances
 116 instance Arbitrary PhyloView
 117   where
 118     arbitrary = elements [phyloView]
 119
 120 -- | TODO add phyloGroup ex
 121 instance Arbitrary PhyloGroup
 122   where
 123     arbitrary = elements []
 124
 125 instance Arbitrary Phylo
 126   where
 127     arbitrary = elements [phylo]
 128
 129
 130 instance ToSchema Cluster
 131 instance ToSchema EdgeType
 132 instance ToSchema Filiation
 133 instance ToSchema Filter
 134 instance ToSchema FisParams
 135 instance ToSchema HammingParams
 136 instance ToSchema LouvainParams
 137 instance ToSchema Metric
 138 instance ToSchema Order
 139 instance ToSchema Phylo
 140 instance ToSchema PhyloBranch
 141 instance ToSchema PhyloEdge
 142 instance ToSchema PhyloGroup
 143 instance ToSchema PhyloLevel
 144 instance ToSchema PhyloNode
 145 instance ToSchema PhyloParam
 146 instance ToSchema PhyloPeaks
 147 instance ToSchema PhyloPeriod
 148 instance ToSchema PhyloQueryBuild
 149 instance ToSchema PhyloView
 150 instance ToSchema RCParams
 151 instance ToSchema SBParams
 152 instance ToSchema Software
 153 instance ToSchema WLJParams
 154
 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 FromHttpApiData Sort
 178   where
 179     parseUrlPiece = readTextData
 180 instance ToParamSchema Sort
 181
 182 instance (ToSchema a) => ToSchema (Tree a)
 183   where
 184     declareNamedSchema = genericDeclareNamedSchemaUnrestricted
 185                        $ swaggerOptions ""
 186
 187 instance ToSchema Proximity
 188   where
 189     declareNamedSchema = genericDeclareNamedSchemaUnrestricted
 190                        $ swaggerOptions ""
 191
 192
 193 instance FromHttpApiData [Tagger]
 194   where
 195     parseUrlPiece = readTextData
 196 instance FromHttpApiData Tagger
 197   where
 198     parseUrlPiece = readTextData
 199 instance ToParamSchema   Tagger
 200
 201 instance FromHttpApiData Filiation
 202   where
 203     parseUrlPiece = readTextData
 204 instance ToParamSchema   Filiation
 205
 206