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