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