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