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