src/Gargantext/API/Ngrams/List.hs

   1 {-|
   2 Module      : Gargantext.API.Ngrams.List
   3 Description : Get Ngrams (lists)
   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 {-# LANGUAGE DataKinds         #-}
  13 {-# LANGUAGE DeriveGeneric     #-}
  14 {-# LANGUAGE FlexibleContexts  #-}
  15 {-# LANGUAGE FlexibleInstances #-}
  16 {-# LANGUAGE MultiParamTypeClasses #-}
  17 {-# LANGUAGE NoImplicitPrelude #-}
  18 {-# LANGUAGE OverloadedStrings #-}
  19 {-# LANGUAGE RankNTypes        #-}
  20 {-# LANGUAGE TemplateHaskell   #-}
  21 {-# LANGUAGE TypeOperators     #-}
  22
  23 module Gargantext.API.Ngrams.List
  24   where
  25
  26 import Control.Lens hiding (elements)
  27 import Control.Monad.IO.Class (liftIO)
  28 import Data.Aeson
  29 import Data.List (zip)
  30 import Data.Map (Map, toList, fromList)
  31 import Data.Swagger (ToSchema, declareNamedSchema, genericDeclareNamedSchema)
  32 import Data.Text (Text, concat, pack)
  33 import GHC.Generics (Generic)
  34 import Gargantext.API.Corpus.New
  35 import Gargantext.API.Corpus.New.File (FileType(..))
  36 import Gargantext.API.Ngrams
  37 import Gargantext.API.Orchestrator.Types
  38 import Gargantext.API.Types (GargServer)
  39 import Gargantext.Database.Flow (FlowCmdM)
  40 import Gargantext.Database.Schema.Ngrams (NgramsType(..), ngramsTypes)
  41 import Gargantext.Database.Types.Node
  42 import Gargantext.Core.Utils.Prefix (unPrefixSwagger)
  43 import Gargantext.Prelude
  44 import Network.HTTP.Media ((//), (/:))
  45 import Servant
  46 import Servant.Job.Async
  47 import Web.FormUrlEncoded          (FromForm)
  48 import Servant.Job.Utils (jsonOptions)
  49
  50 ------------------------------------------------------------------------
  51 type NgramsList = (Map NgramsType (Versioned NgramsTableMap))
  52 ------------------------------------------------------------------------
  53 type API =  Get '[JSON, HTML] (Headers '[Header "Content-Disposition" Text] NgramsList)
  54        -- :<|> ReqBody '[JSON] NgramsList :> Post '[JSON] Bool
  55        :<|> PostAPI
  56
  57 api :: ListId -> GargServer API
  58 api l =
  59         get l
  60     :<|>
  61         -- post l
  62         postAsync l
  63
  64 data HTML
  65 instance Accept HTML where
  66   contentType _ = "text" // "html" /: ("charset", "utf-8")
  67 instance ToJSON a => MimeRender HTML a where
  68   mimeRender _ = encode
  69
  70 ------------------------------------------------------------------------
  71
  72 get :: RepoCmdM env err m
  73         => ListId -> m (Headers '[Header "Content-Disposition" Text] NgramsList)
  74 get lId = do
  75   lst <- get' lId
  76   let (NodeId id) = lId
  77   return $ addHeader (concat [ "attachment; filename=GarganText_NgramsList-"
  78                              , pack $ show id
  79                              , ".json"
  80                              ]
  81                      ) lst
  82
  83 get' :: RepoCmdM env err m
  84     => ListId -> m NgramsList
  85 get' lId = fromList
  86        <$> zip ngramsTypes
  87        <$> mapM (getNgramsTableMap lId) ngramsTypes
  88
  89 ------------------------------------------------------------------------
  90
  91 -- TODO : purge list
  92 post :: FlowCmdM env err m
  93     => ListId
  94     -> NgramsList
  95     -> m Bool
  96 post l m  = do
  97   -- TODO check with Version for optim
  98   _ <- mapM (\(nt, Versioned _v ns) -> setListNgrams l nt ns) $ toList m
  99   -- TODO reindex
 100   pure True
 101
 102 ------------------------------------------------------------------------
 103 ------------------------------------------------------------------------
 104
 105 type PostAPI = Summary "Update List"
 106         :> "add"
 107         :> "form"
 108         :> "async"
 109         :> AsyncJobs ScraperStatus '[FormUrlEncoded] WithFile ScraperStatus
 110
 111 postAsync :: ListId -> GargServer PostAPI
 112 postAsync lId =
 113   serveJobsAPI $
 114     JobFunction (\f  log' -> postAsync' lId f (liftIO . log'))
 115
 116 postAsync' :: FlowCmdM env err m
 117           => ListId
 118           -> WithFile
 119           -> (ScraperStatus -> m ())
 120           -> m ScraperStatus
 121 postAsync' l (WithFile _ m _) logStatus = do
 122
 123   logStatus ScraperStatus { _scst_succeeded = Just 0
 124                           , _scst_failed    = Just 0
 125                           , _scst_remaining = Just 1
 126                           , _scst_events    = Just []
 127                           }
 128   _r <- post l m
 129
 130   pure ScraperStatus { _scst_succeeded = Just 1
 131                      , _scst_failed    = Just 0
 132                      , _scst_remaining = Just 0
 133                      , _scst_events    = Just []
 134                      }
 135
 136 data WithFile = WithFile
 137   { _wf_filetype :: !FileType
 138   , _wf_data     :: !NgramsList
 139   , _wf_name     :: !Text
 140   } deriving (Eq, Show, Generic)
 141
 142 makeLenses ''WithFile
 143 instance FromForm WithFile
 144 instance FromJSON WithFile where
 145   parseJSON = genericParseJSON $ jsonOptions "_wf_"
 146 instance ToSchema WithFile where
 147   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_wf_")
 148