src/Gargantext/Database/Node.hs

   1 {-|
   2 Module      : Gargantext.Database.Node
   3 Description : Main requests of Node to the database
   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 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
  12 {-# OPTIONS_GHC -fno-warn-orphans        #-}
  13
  14 {-# LANGUAGE Arrows                 #-}
  15 {-# LANGUAGE DeriveGeneric          #-}
  16 {-# LANGUAGE ConstraintKinds        #-}
  17 {-# LANGUAGE FlexibleContexts       #-}
  18 {-# LANGUAGE FlexibleInstances      #-}
  19 {-# LANGUAGE FunctionalDependencies #-}
  20 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  21 {-# LANGUAGE OverloadedStrings #-}
  22 {-# LANGUAGE MultiParamTypeClasses  #-}
  23 {-# LANGUAGE NoImplicitPrelude      #-}
  24 {-# LANGUAGE TemplateHaskell        #-}
  25
  26 module Gargantext.Database.Node where
  27
  28 import Data.Text (pack)
  29 import GHC.Int (Int64)
  30 import Control.Lens (set)
  31 import Data.Maybe
  32 import Data.Time (UTCTime)
  33 import Database.PostgreSQL.Simple.FromField ( Conversion
  34                                             , ResultError(ConversionFailed)
  35                                             , FromField
  36                                             , fromField
  37                                             , returnError
  38                                             )
  39 import Prelude hiding (null, id, map, sum)
  40
  41 import Gargantext.Core (Lang(..))
  42 import Gargantext.Core.Types
  43 import Gargantext.Database.Types.Node (NodeType, defaultCorpus)
  44 import Gargantext.Database.Queries
  45 import Gargantext.Database.Config (nodeTypeId)
  46 import Gargantext.Prelude hiding (sum)
  47
  48 import Database.PostgreSQL.Simple.Internal  (Field)
  49 import Control.Applicative (Applicative)
  50 import Control.Arrow (returnA)
  51 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
  52 import Control.Monad.IO.Class
  53 import Control.Monad.Reader
  54 import Data.Aeson
  55 import Data.Maybe (Maybe, fromMaybe)
  56 import Data.Text (Text)
  57 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
  58 import Data.Typeable (Typeable)
  59
  60 import qualified Data.ByteString      as DB
  61 import qualified Data.ByteString.Lazy as DBL
  62 import Data.ByteString (ByteString)
  63
  64 import Database.PostgreSQL.Simple (Connection)
  65 import Opaleye hiding (FromField)
  66 import Opaleye.Internal.QueryArr (Query)
  67 import qualified Data.Profunctor.Product as PP
  68
  69 ------------------------------------------------------------------------
  70 {- | Reader Monad reinvented here:
  71
  72 newtype Cmd a = Cmd { unCmd :: Connection -> IO a }
  73
  74 instance Monad Cmd where
  75   return a = Cmd $ \_ -> return a
  76
  77   m >>= f = Cmd $ \c -> do
  78     a <- unCmd m c
  79     unCmd (f a) c
  80 -}
  81 newtype Cmd a = Cmd (ReaderT Connection IO a)
  82   deriving (Functor, Applicative, Monad, MonadReader Connection, MonadIO)
  83
  84 runCmd :: Connection -> Cmd a -> IO a
  85 runCmd c (Cmd f) = runReaderT f c
  86
  87 mkCmd :: (Connection -> IO a) -> Cmd a
  88 mkCmd = Cmd . ReaderT
  89
  90 ------------------------------------------------------------------------
  91 type CorpusId = Int
  92 type AnnuaireId = Int
  93 type UserId = NodeId
  94 type TypeId = Int
  95 ------------------------------------------------------------------------
  96 instance FromField HyperdataCorpus where
  97     fromField = fromField'
  98
  99 instance FromField HyperdataDocument where
 100     fromField = fromField'
 101
 102 instance FromField HyperdataDocumentV3 where
 103     fromField = fromField'
 104
 105 instance FromField HyperdataUser where
 106     fromField = fromField'
 107 ------------------------------------------------------------------------
 108 instance QueryRunnerColumnDefault PGJsonb HyperdataDocument where
 109   queryRunnerColumnDefault = fieldQueryRunnerColumn
 110
 111 instance QueryRunnerColumnDefault PGJsonb HyperdataDocumentV3 where
 112   queryRunnerColumnDefault = fieldQueryRunnerColumn
 113
 114 instance QueryRunnerColumnDefault PGJsonb HyperdataCorpus   where
 115   queryRunnerColumnDefault = fieldQueryRunnerColumn
 116
 117 instance QueryRunnerColumnDefault PGJsonb HyperdataUser     where
 118   queryRunnerColumnDefault = fieldQueryRunnerColumn
 119 ------------------------------------------------------------------------
 120
 121 fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
 122 fromField' field mb = do
 123     v <- fromField field mb
 124     valueToHyperdata v
 125       where
 126           valueToHyperdata v = case fromJSON v of
 127              Success a  -> pure a
 128              Error _err -> returnError ConversionFailed field "cannot parse hyperdata"
 129
 130
 131 $(makeAdaptorAndInstance "pNode" ''NodePoly)
 132 $(makeLensesWith abbreviatedFields ''NodePoly)
 133
 134
 135 nodeTable :: Table NodeWrite NodeRead
 136 nodeTable = Table "nodes" (pNode Node { _node_id                = optional "id"
 137                                         , _node_typename        = required "typename"
 138                                         , _node_userId          = required "user_id"
 139                                         , _node_parentId        = required "parent_id"
 140                                         , _node_name            = required "name"
 141                                         , _node_date            = optional "date"
 142                                         , _node_hyperdata       = required "hyperdata"
 143                      --                   , node_titleAbstract   = optional "title_abstract"
 144                                         }
 145                             )
 146
 147
 148 nodeTable' :: Table (Maybe (Column PGInt4)
 149                     ,       Column PGInt4
 150                     ,       Column PGInt4
 151                     ,Maybe (Column PGInt4)
 152                     ,       Column PGText
 153                     ,Maybe (Column PGTimestamptz)
 154                     ,       Column PGJsonb
 155                     )
 156                     ((Column PGInt4)
 157                     ,       Column PGInt4
 158                     ,       Column PGInt4
 159                     ,       Column PGInt4
 160                     ,       Column PGText
 161                     ,(Column PGTimestamptz)
 162                     ,       Column PGJsonb
 163                     )
 164
 165 nodeTable' = Table "nodes" (PP.p7 ( optional "id"
 166                                , required "typename"
 167                                , required "user_id"
 168                                , optional "parent_id"
 169                                , required "name"
 170                                , optional "date"
 171                                , required "hyperdata"
 172                                )
 173                             )
 174
 175
 176 queryNodeTable :: Query NodeRead
 177 queryNodeTable = queryTable nodeTable
 178
 179 selectNode :: Column PGInt4 -> Query NodeRead
 180 selectNode id = proc () -> do
 181     row <- queryNodeTable -< ()
 182     restrict -< _node_id row .== id
 183     returnA -< row
 184
 185 runGetNodes :: Query NodeRead -> Cmd [Node Value]
 186 runGetNodes q = mkCmd $ \conn -> runQuery conn q
 187
 188 ------------------------------------------------------------------------
 189 selectRootUser :: UserId -> Query NodeRead
 190 selectRootUser userId = proc () -> do
 191     row <- queryNodeTable -< ()
 192     restrict -< _node_userId   row .== (pgInt4 userId)
 193     restrict -< _node_typename row .== (pgInt4 $ nodeTypeId NodeUser)
 194     returnA -< row
 195
 196 getRoot :: UserId -> Cmd [Node HyperdataUser]
 197 getRoot userId = mkCmd $ \conn -> runQuery conn (selectRootUser userId)
 198 ------------------------------------------------------------------------
 199
 200 -- | order by publication date
 201 -- Favorites (Bool), node_ngrams
 202 selectNodesWith :: ParentId     -> Maybe NodeType
 203                 -> Maybe Offset -> Maybe Limit   -> Query NodeRead
 204 selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
 205         --offset' maybeOffset $ limit' maybeLimit $ orderBy (asc (hyperdataDocument_Publication_date . node_hyperdata)) $ selectNodesWith' parentId typeId
 206         limit' maybeLimit $ offset' maybeOffset $ orderBy (asc _node_id) $ selectNodesWith' parentId maybeNodeType
 207
 208 selectNodesWith' :: ParentId -> Maybe NodeType -> Query NodeRead
 209 selectNodesWith' parentId maybeNodeType = proc () -> do
 210     node <- (proc () -> do
 211             row@(Node _ typeId _ parentId' _ _ _) <- queryNodeTable -< ()
 212             restrict -< parentId' .== (toNullable $ pgInt4 parentId)
 213
 214             let typeId' = maybe 0 nodeTypeId maybeNodeType
 215
 216             restrict -< if typeId' > 0
 217                            then typeId   .== (pgInt4 (typeId' :: Int))
 218                            else (pgBool True)
 219             returnA  -< row ) -< ()
 220     returnA -< node
 221
 222
 223 --type Cmd' a = forall m. (MonadReader env m, HasConnection env, MonadIO m) => m a
 224
 225
 226 -- deleteNode :: (MonadReader Connection m, MonadIO m) => Int -> m Int
 227 -- deleteNode :: Int -> Cmd' Int
 228
 229 deleteNode :: Int -> Cmd Int
 230 deleteNode n = mkCmd $ \conn ->
 231   fromIntegral <$> runDelete conn nodeTable
 232                  (\(Node n_id _ _ _ _ _ _) -> n_id .== pgInt4 n)
 233
 234 deleteNodes :: [Int] -> Cmd Int
 235 deleteNodes ns = mkCmd $ \conn ->
 236   fromIntegral <$> runDelete conn nodeTable
 237                    (\(Node n_id _ _ _ _ _ _) -> in_ ((map pgInt4 ns)) n_id)
 238
 239
 240 getNodesWith :: JSONB a => Connection -> Int -> proxy a -> Maybe NodeType
 241              -> Maybe Offset -> Maybe Limit -> IO [Node a]
 242 getNodesWith conn parentId _ nodeType maybeOffset maybeLimit =
 243     runQuery conn $ selectNodesWith
 244                   parentId nodeType maybeOffset maybeLimit
 245
 246
 247 -- NP check type
 248 getNodesWithParentId :: Int
 249                      -> Maybe Text -> Connection -> IO [Node Value]
 250 getNodesWithParentId n _ conn = runQuery conn $ selectNodesWithParentID n
 251
 252 getNodesWithParentId' :: Int
 253                      -> Maybe Text -> Connection -> IO [Node Value]
 254 getNodesWithParentId' n _ conn = runQuery conn $ selectNodesWithParentID n
 255
 256
 257 ------------------------------------------------------------------------
 258 getDocumentsV3WithParentId :: Connection -> Int -> IO [Node HyperdataDocumentV3]
 259 getDocumentsV3WithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeDocument)
 260
 261 getDocumentsWithParentId :: Connection -> Int -> IO [Node HyperdataDocument]
 262 getDocumentsWithParentId conn n = runQuery conn $ selectNodesWith' n (Just NodeDocument)
 263
 264 ------------------------------------------------------------------------
 265
 266
 267 selectNodesWithParentID :: Int -> Query NodeRead
 268 selectNodesWithParentID n = proc () -> do
 269     row@(Node _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
 270     restrict -< if n > 0
 271                    then
 272                         parent_id .== (toNullable $ pgInt4 n)
 273                    else
 274                         isNull parent_id
 275     returnA -< row
 276
 277
 278 selectNodesWithType :: Column PGInt4 -> Query NodeRead
 279 selectNodesWithType type_id = proc () -> do
 280     row@(Node _ tn _ _ _ _ _) <- queryNodeTable -< ()
 281     restrict -< tn .== type_id
 282     returnA -< row
 283
 284 type JSONB = QueryRunnerColumnDefault PGJsonb
 285
 286 getNode :: JSONB a => Connection -> Int -> proxy a -> IO (Node a)
 287 getNode conn id _ = do
 288     fromMaybe (error $ "Node does node exist: " <> show id) . headMay <$> runQuery conn (limit 1 $ selectNode (pgInt4 id))
 289
 290
 291 getNodesWithType :: Connection -> Column PGInt4 -> IO [Node HyperdataDocument]
 292 getNodesWithType conn type_id = do
 293     runQuery conn $ selectNodesWithType type_id
 294
 295
 296 ------------------------------------------------------------------------
 297 -- WIP
 298 -- TODO Classe HasDefault where
 299 -- default NodeType = Hyperdata
 300 ------------------------------------------------------------------------
 301 type NodeWrite' = NodePoly (Maybe Int) Int Int (Maybe ParentId) Text (Maybe UTCTime) ByteString
 302 ------------------------------------------------------------------------
 303 defaultUser :: HyperdataUser
 304 defaultUser = HyperdataUser (Just $ (pack . show) EN)
 305
 306 nodeUserW :: Maybe Name -> Maybe HyperdataUser -> UserId -> NodeWrite'
 307 nodeUserW maybeName maybeHyperdata = node NodeUser name (Hyperdata user) Nothing
 308   where
 309     name = maybe "User" identity maybeName
 310     user = maybe defaultUser identity maybeHyperdata
 311 ------------------------------------------------------------------------
 312 defaultFolder :: HyperdataFolder
 313 defaultFolder = HyperdataFolder (Just "Markdown Description")
 314
 315 nodeFolderW :: Maybe Name -> Maybe HyperdataFolder -> ParentId -> UserId -> NodeWrite'
 316 nodeFolderW maybeName maybeFolder pid = node NodeFolder name (Hyperdata folder) (Just pid)
 317   where
 318     name   = maybe "Folder" identity maybeName
 319     folder = maybe defaultFolder identity maybeFolder
 320 ------------------------------------------------------------------------
 321
 322 nodeCorpusW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite'
 323 nodeCorpusW maybeName maybeCorpus pId = node NodeCorpus name (Hyperdata corpus) (Just pId)
 324   where
 325     name   = maybe "Corpus" identity maybeName
 326     corpus = maybe defaultCorpus identity maybeCorpus
 327                    --------------------------
 328 defaultDocument :: HyperdataDocument
 329 defaultDocument = hyperdataDocument
 330
 331 nodeDocumentW :: Maybe Name -> Maybe HyperdataDocument -> CorpusId -> UserId -> NodeWrite'
 332 nodeDocumentW maybeName maybeDocument cId = node NodeDocument name (Hyperdata doc) (Just cId)
 333   where
 334     name = maybe "Document" identity maybeName
 335     doc  = maybe defaultDocument identity maybeDocument
 336 ------------------------------------------------------------------------
 337 defaultAnnuaire :: HyperdataAnnuaire
 338 defaultAnnuaire = HyperdataAnnuaire (Just "Title") (Just "Description")
 339
 340 nodeAnnuaireW :: Maybe Name -> Maybe HyperdataAnnuaire -> ParentId -> UserId -> NodeWrite'
 341 nodeAnnuaireW maybeName maybeAnnuaire pId = node NodeAnnuaire name (Hyperdata annuaire) (Just pId)
 342   where
 343     name     = maybe "Annuaire" identity maybeName
 344     annuaire = maybe defaultAnnuaire identity maybeAnnuaire
 345                    --------------------------
 346 defaultContact :: HyperdataContact
 347 defaultContact = HyperdataContact (Just "Name") (Just "email@here")
 348
 349 nodeContactW :: Maybe Name -> Maybe HyperdataContact -> AnnuaireId -> UserId -> NodeWrite'
 350 nodeContactW maybeName maybeContact aId = node NodeContact name (Hyperdata contact) (Just aId)
 351   where
 352     name    = maybe "Contact" identity maybeName
 353     contact = maybe defaultContact identity maybeContact
 354 ------------------------------------------------------------------------
 355 ------------------------------------------------------------------------
 356 node :: ToJSON a => NodeType -> Name -> Hyperdata a -> Maybe ParentId -> UserId -> NodeWrite'
 357 node nodeType name hyperData parentId userId = Node Nothing typeId userId parentId name Nothing byteData
 358   where
 359     typeId = nodeTypeId nodeType
 360     byteData = DB.pack $ DBL.unpack $ encode $ unHyperdata hyperData
 361
 362                   -------------------------------
 363 node2row :: (Functor maybe1, Functor maybe2, Functor maybe3) =>
 364               NodePoly (maybe2 Int)                      Int            Int  (maybe1           Int)
 365                                 Text        (maybe3 UTCTime)             ByteString
 366                     -> (maybe2 (Column PGInt4), Column PGInt4, Column PGInt4, maybe1 (Column PGInt4)
 367                      , Column PGText, maybe3 (Column PGTimestamptz), Column PGJsonb)
 368 node2row (Node id tn ud pid nm dt hp) = ((pgInt4    <$> id)
 369                                         ,(pgInt4        tn)
 370                                         ,(pgInt4        ud)
 371                                         ,(pgInt4   <$> pid)
 372                                         ,(pgStrictText  nm)
 373                                         ,(pgUTCTime <$> dt)
 374                                         ,(pgStrictJSONB hp)
 375                                         )
 376 ------------------------------------------------------------------------
 377 insertNodesR' :: [NodeWrite'] -> Cmd [Int]
 378 insertNodesR' ns = mkCmd $ \c -> insertNodesR ns c
 379
 380 insertNodes :: [NodeWrite'] -> Connection -> IO Int64
 381 insertNodes ns conn = runInsertMany conn nodeTable' (map node2row ns)
 382
 383 insertNodesR :: [NodeWrite'] -> Connection -> IO [Int]
 384 insertNodesR ns conn = runInsertManyReturning conn nodeTable' (map node2row ns) (\(i,_,_,_,_,_,_) -> i)
 385                        -------------------------
 386 insertNodesWithParent :: Maybe ParentId -> [NodeWrite'] -> Connection -> IO Int64
 387 insertNodesWithParent pid ns conn = insertNodes (map (set node_parentId pid) ns) conn
 388
 389 insertNodesWithParentR :: Maybe ParentId -> [NodeWrite'] -> Connection -> IO [Int]
 390 insertNodesWithParentR pid ns conn = insertNodesR (map (set node_parentId pid) ns) conn
 391 ------------------------------------------------------------------------
 392 -- TODO Hierachy of Nodes
 393 -- post and get same types Node' and update if changes
 394
 395 {- TODO semantic to achieve
 396 post c uid pid [ Node' NodeCorpus "name" "{}" []
 397                , Node' NodeFolder "name" "{}" [Node' NodeCorpus "test 2" "" [ Node' NodeDocument "title" "metaData" []
 398                                                                     , Node' NodeDocument "title" "jsonData" []
 399                                                                     ]
 400                                           ]
 401                ]
 402 -}
 403 ------------------------------------------------------------------------
 404
 405 -- TODO
 406 -- currently this function remove the child relation
 407 -- needs a Temporary type between Node' and NodeWriteT
 408 node2table :: UserId -> Maybe ParentId -> Node' -> NodeWriteT
 409 node2table uid pid (Node' nt txt v []) = ( Nothing, (pgInt4$ nodeTypeId nt), (pgInt4 uid), (fmap pgInt4 pid)
 410                                          , pgStrictText txt, Nothing, pgStrictJSONB $ DB.pack $ DBL.unpack $ encode v)
 411 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
 412
 413
 414 data Node' = Node' { _n_type :: NodeType
 415                    , _n_name :: Text
 416                    , _n_data :: Value
 417                    , _n_children :: [Node']
 418                    } deriving (Show)
 419
 420
 421 type NodeWriteT =  ( Maybe (Column PGInt4)
 422                    ,        Column PGInt4
 423                    ,        Column PGInt4
 424                    , Maybe (Column PGInt4)
 425                    ,        Column PGText
 426                    , Maybe (Column PGTimestamptz)
 427                    ,        Column PGJsonb
 428                    )
 429
 430
 431 mkNode' :: [NodeWriteT] -> Cmd Int64
 432 mkNode' ns = mkCmd $ \conn -> runInsertMany conn nodeTable' ns
 433
 434 mkNodeR' :: [NodeWriteT] -> Cmd [Int]
 435 mkNodeR' ns = mkCmd $ \conn -> runInsertManyReturning conn nodeTable' ns (\(i,_,_,_,_,_,_) -> i)
 436
 437
 438 ------------------------------------------------------------------------
 439
 440 data NewNode = NewNode { _newNodeId :: Int
 441                        , _newNodeChildren :: [Int] }
 442
 443 -- | postNode
 444 postNode :: UserId -> Maybe ParentId -> Node' -> Cmd NewNode
 445 postNode uid pid (Node' nt txt v []) = do
 446   pids <- mkNodeR' [node2table uid pid (Node' nt txt v [])]
 447   case pids of
 448     [pid] -> pure $ NewNode pid []
 449     _ -> panic "postNode: only one pid expected"
 450
 451 postNode uid pid (Node' NodeCorpus txt v ns) = do
 452   NewNode pid' _ <- postNode uid pid (Node' NodeCorpus txt v [])
 453   pids  <- mkNodeR' (concat $ map (\n -> [childWith uid pid' n]) ns)
 454   pure $ NewNode pid' pids
 455
 456 postNode uid pid (Node' NodeAnnuaire txt v ns) = do
 457   NewNode pid' _ <- postNode uid pid (Node' NodeAnnuaire txt v [])
 458   pids  <- mkNodeR' (concat $ map (\n -> [childWith uid pid' n]) ns)
 459   pure $ NewNode pid' pids
 460 postNode _ _ (Node' _ _ _ _) = panic "TODO: postNode for this type not implemented yet"
 461
 462
 463 childWith :: UserId -> ParentId -> Node' -> NodeWriteT
 464 childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
 465 childWith uId pId (Node' NodeContact  txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
 466 childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a child"
 467
 468
 469 -- TODO: remove hardcoded userId (with Reader)
 470 -- TODO: user Reader in the API and adapt this function
 471 userId :: Int
 472 userId = 1
 473
 474 mk :: Connection -> NodeType -> Maybe ParentId -> Text -> IO [Int]
 475 mk c nt pId name  = mk' c nt userId pId name
 476
 477 mk' :: Connection -> NodeType -> UserId -> Maybe ParentId -> Text -> IO [Int]
 478 mk' c nt uId pId name  = map fromIntegral <$> insertNodesWithParentR pId [node nt name hd pId uId] c
 479   where
 480     hd = Hyperdata (HyperdataUser (Just $ (pack . show) EN))
 481
 482 type Name = Text
 483
 484 mk'' :: NodeType -> Maybe ParentId -> UserId -> Name -> Cmd [Int]
 485 mk'' NodeUser Nothing uId name  = mkCmd $ \c -> mk' c NodeUser uId Nothing name
 486 mk'' NodeUser _       _   _     = panic "NodeUser can not has a parent"
 487 mk'' _        Nothing _   _     = panic "NodeType needs a parent"
 488 mk'' nt       pId     uId name  = mkCmd $ \c -> mk' c nt uId pId name
 489
 490 mkRoot :: UserId -> Cmd [Int]
 491 mkRoot uId = case uId > 0 of
 492                False -> panic "UserId <= 0"
 493                True  -> mk'' NodeUser Nothing uId ("User Node : " <> (pack . show) uId)
 494
 495 mkCorpus :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> Cmd [Int]
 496 mkCorpus n h p u = insertNodesR' [nodeCorpusW n h p u]
 497
 498