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