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