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