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.Admin.Orchestrator.Types
  37 import Gargantext.API.Admin.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 = get l :<|> postAsync l
  58
  59 data HTML
  60 instance Accept HTML where
  61   contentType _ = "text" // "html" /: ("charset", "utf-8")
  62 instance ToJSON a => MimeRender HTML a where
  63   mimeRender _ = encode
  64
  65 ------------------------------------------------------------------------
  66
  67 get :: RepoCmdM env err m
  68         => ListId -> m (Headers '[Header "Content-Disposition" Text] NgramsList)
  69 get lId = do
  70   lst <- get' lId
  71   let (NodeId id) = lId
  72   return $ addHeader (concat [ "attachment; filename=GarganText_NgramsList-"
  73                              , pack $ show id
  74                              , ".json"
  75                              ]
  76                      ) lst
  77
  78 get' :: RepoCmdM env err m
  79     => ListId -> m NgramsList
  80 get' lId = fromList
  81        <$> zip ngramsTypes
  82        <$> mapM (getNgramsTableMap lId) ngramsTypes
  83
  84 ------------------------------------------------------------------------
  85
  86 -- TODO : purge list
  87 post :: FlowCmdM env err m
  88     => ListId
  89     -> NgramsList
  90     -> m Bool
  91 post l m  = do
  92   -- TODO check with Version for optim
  93   _ <- mapM (\(nt, Versioned _v ns) -> setListNgrams l nt ns) $ toList m
  94   -- TODO reindex
  95   pure True
  96
  97 ------------------------------------------------------------------------
  98 ------------------------------------------------------------------------
  99
 100 type PostAPI = Summary "Update List"
 101         :> "add"
 102         :> "form"
 103         :> "async"
 104         :> AsyncJobs ScraperStatus '[FormUrlEncoded] WithFile ScraperStatus
 105
 106 postAsync :: ListId -> GargServer PostAPI
 107 postAsync lId =
 108   serveJobsAPI $
 109     JobFunction (\f  log' -> postAsync' lId f (liftBase . log'))
 110
 111 postAsync' :: FlowCmdM env err m
 112           => ListId
 113           -> WithFile
 114           -> (ScraperStatus -> m ())
 115           -> m ScraperStatus
 116 postAsync' l (WithFile _ m _) logStatus = do
 117
 118   logStatus ScraperStatus { _scst_succeeded = Just 0
 119                           , _scst_failed    = Just 0
 120                           , _scst_remaining = Just 1
 121                           , _scst_events    = Just []
 122                           }
 123   _r <- post l m
 124
 125   pure ScraperStatus { _scst_succeeded = Just 1
 126                      , _scst_failed    = Just 0
 127                      , _scst_remaining = Just 0
 128                      , _scst_events    = Just []
 129                      }
 130
 131 data WithFile = WithFile
 132   { _wf_filetype :: !FileType
 133   , _wf_data     :: !NgramsList
 134   , _wf_name     :: !Text
 135   } deriving (Eq, Show, Generic)
 136
 137 makeLenses ''WithFile
 138 instance FromForm WithFile
 139 instance FromJSON WithFile where
 140   parseJSON = genericParseJSON $ jsonOptions "_wf_"
 141 instance ToSchema WithFile where
 142   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_wf_")
 143