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 Network.HTTP.Media ((//), (/:))
  26 import Servant
  27 import Servant.Job.Async
  28 import Servant.Job.Utils (jsonOptions)
  29 import Web.FormUrlEncoded (FromForm)
  30
  31 import Gargantext.Prelude
  32 import Gargantext.API.Node.Corpus.New.File (FileType(..))
  33 import Gargantext.API.Ngrams
  34 import Gargantext.API.Admin.Orchestrator.Types
  35 import Gargantext.API.Prelude (GargServer)
  36 import Gargantext.Core.Utils.Prefix (unPrefixSwagger)
  37 import Gargantext.Database.Action.Flow (FlowCmdM)
  38 import Gargantext.Database.Admin.Types.Node
  39 import Gargantext.Database.Schema.Ngrams (NgramsType(..), ngramsTypes)
  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 get :: RepoCmdM env err m =>
  59        ListId -> m (Headers '[Header "Content-Disposition" Text] NgramsList)
  60 get lId = do
  61   lst <- get' lId
  62   let (NodeId id) = lId
  63   return $ addHeader (concat [ "attachment; filename=GarganText_NgramsList-"
  64                              , pack $ show id
  65                              , ".json"
  66                              ]
  67                      ) lst
  68
  69 get' :: RepoCmdM env err m
  70     => ListId -> m NgramsList
  71 get' lId = fromList
  72        <$> zip ngramsTypes
  73        <$> mapM (getNgramsTableMap lId) ngramsTypes
  74
  75 ------------------------------------------------------------------------
  76 -- TODO : purge list
  77 post :: FlowCmdM env err m
  78     => ListId
  79     -> NgramsList
  80     -> m Bool
  81 post l m  = do
  82   -- TODO check with Version for optim
  83   _ <- mapM (\(nt, Versioned _v ns) -> setListNgrams l nt ns) $ toList m
  84   -- TODO reindex
  85   pure True
  86
  87 ------------------------------------------------------------------------
  88 ------------------------------------------------------------------------
  89 type PostAPI = Summary "Update List"
  90         :> "add"
  91         :> "form"
  92         :> "async"
  93         :> AsyncJobs JobLog '[FormUrlEncoded] WithFile JobLog
  94
  95 postAsync :: ListId -> GargServer PostAPI
  96 postAsync lId =
  97   serveJobsAPI $
  98     JobFunction (\f  log' -> postAsync' lId f (liftBase . log'))
  99
 100 postAsync' :: FlowCmdM env err m
 101           => ListId
 102           -> WithFile
 103           -> (JobLog -> m ())
 104           -> m JobLog
 105 postAsync' l (WithFile _ m _) logStatus = do
 106
 107   logStatus JobLog { _scst_succeeded = Just 0
 108                    , _scst_failed    = Just 0
 109                    , _scst_remaining = Just 1
 110                    , _scst_events    = Just []
 111                    }
 112   _r <- post l m
 113
 114   pure JobLog { _scst_succeeded = Just 1
 115               , _scst_failed    = Just 0
 116               , _scst_remaining = Just 0
 117               , _scst_events    = Just []
 118               }
 119
 120 data WithFile = WithFile
 121   { _wf_filetype :: !FileType
 122   , _wf_data     :: !NgramsList
 123   , _wf_name     :: !Text
 124   } deriving (Eq, Show, Generic)
 125
 126 makeLenses ''WithFile
 127 instance FromForm WithFile
 128 instance FromJSON WithFile where
 129   parseJSON = genericParseJSON $ jsonOptions "_wf_"
 130 instance ToSchema WithFile where
 131   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_wf_")
 132