src/Gargantext/Database/Node/Document/Insert.hs

   1 {-|
   2 Module      : Gargantext.Database.Node.Document.Insert
   3 Description : Importing context of texts (documents)
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 * Purpose of this module
  11
  12 Enabling "common goods" of text data and respecting privacy.
  13
  14 Gargantext shares as "common good" the links between context of texts
  15 and terms / words / ngrams.
  16
  17 Basically a context of text can be defined as a document (see 'Gargantext.Text').
  18
  19 Issue to tackle in that module: each global document of Gargantext has
  20 to be unique, then shared, but how to respect privacy if needed ?
  21
  22
  23 * Methodology to get uniqueness and privacy by design
  24
  25 As a consequence, when importing/inserting a new document in Gargantext,
  26 a policy for the uniqueness of the inserted docuemnts has to be defined.
  27
  28 That is the purpose of this module which defines its main concepts.
  29
  30 Unique identifier in database is of a 3-tuple of 3 policies that
  31 together define uniqueness:
  32
  33 - Design policy: type of node is needed as TypenameId, that is a
  34 Document or Individual or something else;
  35
  36 - Privacy policy: with ParentId, parent becomes unique, then it enables
  37 users to get their own copy without sharing it with all the users of the
  38 database (in others words parent_id is necessary to preserve privacy for
  39 instance).
  40
  41 - Hash policy: this UniqId is a sha256 uniq id which is the result of
  42 the concatenation of the parameters defined by @shaParameters@.
  43
  44 > -- * Example
  45 > insertTest :: FromRow r => CorpusId -> [Node HyperdataDocument] -> IO [r]
  46 > insertTest :: IO [ReturnId]
  47 > insertTest = runCmdDev $ insertDocuments 1 452162 hyperdataDocuments
  48
  49 -}
  50 ------------------------------------------------------------------------
  51 {-# LANGUAGE DeriveGeneric        #-}
  52 {-# LANGUAGE FlexibleInstances    #-}
  53 {-# LANGUAGE NoImplicitPrelude    #-}
  54 {-# LANGUAGE OverloadedStrings    #-}
  55 {-# LANGUAGE QuasiQuotes          #-}
  56 {-# LANGUAGE RankNTypes           #-}
  57 {-# LANGUAGE TypeSynonymInstances #-}
  58 ------------------------------------------------------------------------
  59 module Gargantext.Database.Node.Document.Insert where
  60
  61 import Control.Lens (set, view)
  62 import Control.Lens.Prism
  63 import Control.Lens.Cons
  64 import Data.Aeson (toJSON)
  65 import Data.Maybe (maybe)
  66 import Data.Time.Segment (jour)
  67 import Data.Text (Text)
  68 import Database.PostgreSQL.Simple (FromRow, Query, Only(..))
  69 import Database.PostgreSQL.Simple.FromRow (fromRow, field)
  70 import Database.PostgreSQL.Simple.SqlQQ
  71 import Database.PostgreSQL.Simple.ToField (toField, Action)
  72 import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
  73 import GHC.Generics (Generic)
  74 import Gargantext.Database.Config (nodeTypeId)
  75 import Gargantext.Database.Utils (Cmd, runPGSQuery)
  76 import Gargantext.Database.Node.Contact -- (HyperdataContact(..), ContactWho(..))
  77 import Gargantext.Database.Types.Node
  78 import Gargantext.Prelude
  79 import qualified Data.ByteString.Lazy.Char8  as DC (pack)
  80 import qualified Data.Digest.Pure.SHA        as SHA (sha256, showDigest)
  81 import qualified Data.Text                   as DT (pack, unpack, concat, take)
  82 import Gargantext.Prelude.Utils (sha)
  83 -- TODO : the import of Document constructor below does not work
  84 -- import Gargantext.Database.Types.Node (Document)
  85 --import Gargantext.Database.Types.Node (docExample, hyperdataDocument, HyperdataDocument(..)
  86 --                                  , hyperdataDocument_uniqId
  87 --                                  , hyperdataDocument_title
  88 --                                  , hyperdataDocument_abstract
  89 --                                  , hyperdataDocument_source
  90 --                                  , Node(..), node_typename
  91 --                                            , node_userId
  92 --                                            , node_parentId, node_name, node_hyperdata, hyperdataDocuments
  93 --                                  , NodeTypeId
  94 --                                  )
  95 {-| To Print result query
  96 import Data.ByteString.Internal (ByteString)
  97 import Database.PostgreSQL.Simple (formatQuery)
  98 -}
  99
 100 ---------------------------------------------------------------------------
 101 -- * Main Insert functions
 102
 103 -- | Insert Document main function
 104 -- UserId : user who is inserting the documents
 105 -- ParentId : folder ID which is parent of the inserted documents
 106 -- Administrator of the database has to create a uniq index as following SQL command:
 107 -- `create unique index on nodes (typename, parent_id, (hyperdata ->> 'uniqId'));`
 108 insertDb :: InsertDb a => UserId -> ParentId -> [a] -> Cmd err [ReturnId]
 109 insertDb u p = runPGSQuery queryInsert . Only . Values fields . map (insertDb' u p)
 110       where
 111         fields    = map (\t-> QualifiedIdentifier Nothing t) inputSqlTypes
 112
 113 class InsertDb a
 114   where
 115     insertDb' :: UserId -> ParentId -> a -> [Action]
 116
 117
 118 instance InsertDb HyperdataDocument
 119   where
 120     insertDb' u p h = [ toField $ nodeTypeId NodeDocument
 121                       , toField u
 122                       , toField p
 123                       , toField $ maybe "No Title" (DT.take 255)  (_hyperdataDocument_title h)
 124                       , toField $ _hyperdataDocument_publication_date h -- TODO USE UTCTime
 125                       , (toField . toJSON) h
 126                       ]
 127
 128 instance InsertDb HyperdataContact
 129   where
 130     insertDb' u p h = [ toField $ nodeTypeId NodeContact
 131                       , toField u
 132                       , toField p
 133                       , toField $ maybe "Contact" (DT.take 255) (Just "Name") -- (_hc_name h)
 134                       , toField $ jour 2010 1 1 -- TODO put default date
 135                       , (toField . toJSON) h
 136                       ]
 137
 138
 139 -- | Debug SQL function
 140 --
 141 -- to print rendered query (Debug purpose) use @formatQuery@ function.
 142 {-
 143 insertDocuments_Debug :: (Hyperdata a, ToJSON a, ToRow a) => UserId -> ParentId -> [a] -> Cmd ByteString
 144 insertDocuments_Debug uId pId hs = formatPGSQuery queryInsert (Only $ Values fields inputData)
 145   where
 146     fields    = map (\t-> QualifiedIdentifier Nothing t) inputSqlTypes
 147     inputData = prepare uId pId hs
 148 -}
 149
 150
 151 -- | Input Tables: types of the tables
 152 inputSqlTypes :: [Text]
 153 inputSqlTypes = map DT.pack ["int4","int4","int4","text","date","jsonb"]
 154
 155 -- | SQL query to insert documents inside the database
 156 queryInsert :: Query
 157 queryInsert = [sql|
 158     WITH input_rows(typename,user_id,parent_id,name,date,hyperdata) AS (?)
 159     , ins AS (
 160        INSERT INTO nodes (typename,user_id,parent_id,name,date,hyperdata)
 161        SELECT * FROM input_rows
 162        ON CONFLICT ((hyperdata ->> 'uniqIdBdd')) DO NOTHING -- on unique index
 163        -- ON CONFLICT (typename, parent_id, (hyperdata ->> 'uniqId')) DO NOTHING -- on unique index
 164        RETURNING id,hyperdata
 165        )
 166
 167     SELECT true AS source                     -- true for 'newly inserted'
 168          , id
 169          , hyperdata ->> 'uniqId'  as doi
 170     FROM   ins
 171     UNION  ALL
 172     SELECT false AS source                    -- false for 'not inserted'
 173          , c.id
 174          , hyperdata ->> 'uniqId' as doi
 175     FROM   input_rows
 176     JOIN   nodes c USING (hyperdata);         -- columns of unique index
 177            |]
 178
 179 ------------------------------------------------------------------------
 180 -- * Main Types used
 181
 182 -- ** Return Types
 183
 184 -- | When documents are inserted
 185 -- ReturnType after insertion
 186 data ReturnId = ReturnId { reInserted :: Bool -- if the document is inserted (True: is new, False: is not new)
 187                          , reId       :: NodeId  -- always return the id of the document (even new or not new)
 188                                          --   this is the uniq id in the database
 189                          , reUniqId   :: Text -- Hash Id with concatenation of sha parameters
 190                          } deriving (Show, Generic)
 191
 192 instance FromRow ReturnId where
 193   fromRow = ReturnId <$> field <*> field <*> field
 194
 195 ---------------------------------------------------------------------------
 196 -- * Uniqueness of document definition
 197
 198 class AddUniqId a
 199   where
 200     addUniqId :: a -> a
 201
 202 instance AddUniqId HyperdataDocument
 203   where
 204     addUniqId = addUniqIdsDoc
 205       where
 206         addUniqIdsDoc :: HyperdataDocument -> HyperdataDocument
 207         addUniqIdsDoc doc = set hyperdataDocument_uniqIdBdd (Just shaBdd)
 208                           $ set hyperdataDocument_uniqId    (Just shaUni) doc
 209           where
 210             shaUni = sha $ DT.concat $ map ($ doc) shaParametersDoc
 211             shaBdd = sha $ DT.concat $ map ($ doc) ([(\d -> maybeText (_hyperdataDocument_bdd d))] <> shaParametersDoc)
 212
 213         shaParametersDoc :: [(HyperdataDocument -> Text)]
 214         shaParametersDoc = [ \d -> maybeText (_hyperdataDocument_title    d)
 215                             , \d -> maybeText (_hyperdataDocument_abstract d)
 216                             , \d -> maybeText (_hyperdataDocument_source   d)
 217                             , \d -> maybeText (_hyperdataDocument_publication_date   d)
 218                             ]
 219
 220     ---------------------------------------------------------------------------
 221 -- * Uniqueness of document definition
 222 -- TODO factorize with above (use the function below for tests)
 223
 224 instance AddUniqId HyperdataContact
 225   where
 226     addUniqId = addUniqIdsContact
 227
 228 addUniqIdsContact :: HyperdataContact -> HyperdataContact
 229 addUniqIdsContact hc = set (hc_uniqIdBdd) (Just shaBdd)
 230                      $ set (hc_uniqId   ) (Just shaUni) hc
 231   where
 232     shaUni = uniqId $ DT.concat $ map ($ hc) shaParametersContact
 233     shaBdd = uniqId $ DT.concat $ map ($ hc) ([\d -> maybeText (view hc_bdd d)] <> shaParametersContact)
 234
 235     uniqId :: Text -> Text
 236     uniqId = DT.pack . SHA.showDigest . SHA.sha256 . DC.pack . DT.unpack
 237
 238     -- | TODO add more shaparameters
 239     shaParametersContact :: [(HyperdataContact -> Text)]
 240     shaParametersContact = [ \d -> maybeText $ view (hc_who . _Just . cw_firstName) d
 241                             , \d -> maybeText $ view (hc_who . _Just . cw_lastName ) d
 242                             , \d -> maybeText $ view (hc_where . _head . cw_touch . _Just . ct_mail) d
 243                             ]
 244
 245
 246
 247 maybeText :: Maybe Text -> Text
 248 maybeText = maybe (DT.pack "") identity
 249
 250 ---------------------------------------------------------------------------