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.Map (Map, toList, fromList)
  21 import Data.Swagger (ToSchema, declareNamedSchema, genericDeclareNamedSchema)
  22 import Data.Text (Text, concat, pack)
  23 import GHC.Generics (Generic)
  24 import Network.HTTP.Media ((//), (/:))
  25 import Servant
  26 import Servant.Job.Async
  27 import Servant.Job.Utils (jsonOptions)
  28 import Web.FormUrlEncoded (FromForm)
  29
  30 import Gargantext.Prelude
  31 import Gargantext.API.Node.Corpus.New.File (FileType(..))
  32 import Gargantext.API.Ngrams
  33 import Gargantext.API.Admin.Orchestrator.Types
  34 import Gargantext.API.Prelude (GargServer)
  35 import Gargantext.Core.Utils.Prefix (unPrefixSwagger)
  36 import Gargantext.Database.Action.Flow (FlowCmdM)
  37 import Gargantext.Database.Admin.Types.Node
  38 import Gargantext.Database.Schema.Ngrams (NgramsType(..), ngramsTypes)
  39
  40 ------------------------------------------------------------------------
  41 type NgramsList = (Map NgramsType (Versioned NgramsTableMap))
  42 ------------------------------------------------------------------------
  43 type API =  Get '[JSON, HTML] (Headers '[Header "Content-Disposition" Text] NgramsList)
  44        -- :<|> ReqBody '[JSON] NgramsList :> Post '[JSON] Bool
  45        :<|> PostAPI
  46
  47 api :: ListId -> GargServer API
  48 api l = get l :<|> postAsync l
  49
  50 data HTML
  51 instance Accept HTML where
  52   contentType _ = "text" // "html" /: ("charset", "utf-8")
  53 instance ToJSON a => MimeRender HTML a where
  54   mimeRender _ = encode
  55
  56 ------------------------------------------------------------------------
  57 get :: RepoCmdM env err m =>
  58        ListId -> m (Headers '[Header "Content-Disposition" Text] NgramsList)
  59 get lId = do
  60   lst <- get' lId
  61   let (NodeId id) = lId
  62   return $ addHeader (concat [ "attachment; filename=GarganText_NgramsList-"
  63                              , pack $ show id
  64                              , ".json"
  65                              ]
  66                      ) lst
  67
  68 get' :: RepoCmdM env err m
  69     => ListId -> m NgramsList
  70 get' lId = fromList
  71        <$> zip ngramsTypes
  72        <$> mapM (getNgramsTableMap lId) ngramsTypes
  73
  74 ------------------------------------------------------------------------
  75 -- TODO : purge list
  76 -- TODO talk
  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