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 -- TODO talk
  78 post :: FlowCmdM env err m
  79     => ListId
  80     -> NgramsList
  81     -> m Bool
  82 post l m  = do
  83   -- TODO check with Version for optim
  84   _ <- mapM (\(nt, Versioned _v ns) -> setListNgrams l nt ns) $ toList m
  85   -- TODO reindex
  86   pure True
  87
  88 ------------------------------------------------------------------------
  89 ------------------------------------------------------------------------
  90 type PostAPI = Summary "Update List"
  91         :> "add"
  92         :> "form"
  93         :> "async"
  94         :> AsyncJobs JobLog '[FormUrlEncoded] WithFile JobLog
  95
  96 postAsync :: ListId -> GargServer PostAPI
  97 postAsync lId =
  98   serveJobsAPI $
  99     JobFunction (\f  log' -> postAsync' lId f (liftBase . log'))
 100
 101 postAsync' :: FlowCmdM env err m
 102           => ListId
 103           -> WithFile
 104           -> (JobLog -> m ())
 105           -> m JobLog
 106 postAsync' l (WithFile _ m _) logStatus = do
 107
 108   logStatus JobLog { _scst_succeeded = Just 0
 109                    , _scst_failed    = Just 0
 110                    , _scst_remaining = Just 1
 111                    , _scst_events    = Just []
 112                    }
 113   _r <- post l m
 114
 115   pure JobLog { _scst_succeeded = Just 1
 116               , _scst_failed    = Just 0
 117               , _scst_remaining = Just 0
 118               , _scst_events    = Just []
 119               }
 120
 121 data WithFile = WithFile
 122   { _wf_filetype :: !FileType
 123   , _wf_data     :: !NgramsList
 124   , _wf_name     :: !Text
 125   } deriving (Eq, Show, Generic)
 126
 127 makeLenses ''WithFile
 128 instance FromForm WithFile
 129 instance FromJSON WithFile where
 130   parseJSON = genericParseJSON $ jsonOptions "_wf_"
 131 instance ToSchema WithFile where
 132   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_wf_")
 133