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