Stub out transactional DB API

gargantext.cabal

@@ -301,15 +301,18 @@ library
       Gargantext.Database.Query.Table.NgramsPostag
       Gargantext.Database.Query.Table.Node
       Gargantext.Database.Query.Table.Node.Error
-      Gargantext.Database.Query.Table.NodeNode
       Gargantext.Database.Query.Table.Node.UpdateOpaleye
       Gargantext.Database.Query.Table.Node.User
+      Gargantext.Database.Query.Table.NodeNode
       Gargantext.Database.Query.Table.User
       Gargantext.Database.Query.Tree.Root
       Gargantext.Database.Schema.Context
       Gargantext.Database.Schema.Ngrams
       Gargantext.Database.Schema.Node
       Gargantext.Database.Schema.User
+      Gargantext.Database.Transactional
+      Gargantext.Database.Transactional.Prelude
+      Gargantext.Database.Transactional.Example
       Gargantext.Defaults
       Gargantext.MicroServices.ReverseProxy
       Gargantext.Orphans
@@ -561,8 +564,8 @@ library
     , http-client-tls >= 0.3.6.1 && < 0.4
     , http-conduit >= 2.3.8 && < 2.3.9
     , http-media ^>= 0.8.0.0
-    , http-types ^>= 0.12.3
     , http-reverse-proxy >= 0.6.1.0
+    , http-types ^>= 0.12.3
     , ini ^>= 0.4.1
     , insert-ordered-containers ^>= 0.2.5.1
     , iso639 ^>= 0.1.0.3
@@ -615,8 +618,8 @@ library
     , servant-client-core >= 0.20 && < 0.21
     , servant-conduit >= 0.15 && < 0.17
     , servant-ekg ^>= 0.3.1
-    , servant-routes < 0.2
     , servant-openapi3 >= 2.0.1.6
+    , servant-routes < 0.2
     , servant-server >= 0.18.3 && < 0.21
     , servant-swagger ^>= 1.2
     , servant-swagger-ui ^>= 0.3.5.3.5.0
@@ -640,13 +643,13 @@ library
     , text ^>= 2.0.2
     , text-metrics ^>= 0.3.2
     , time ^>= 1.12.2
+    , toml-parser >= 2.0.1.0 && < 3
     , transformers
     , transformers-base ^>= 0.4.6
     , tree-diff
-    , toml-parser >= 2.0.1.0 && < 3
     , tuple ^>= 0.3.0.2
-    , unordered-containers ^>= 0.2.16.0
     , unicode-collation >= 0.1.3.5
+    , unordered-containers ^>= 0.2.16.0
     -- needed for Worker / System.Posix.Signals
     , unix >= 2.7.3 && < 2.9
     , uri-encode ^>= 1.5.0.7

src/Gargantext/Database/Query/Table/Node.hs

@@ -50,6 +50,7 @@ module Gargantext.Database.Query.Table.Node
   , getNodesWith
   , getNodesWithParentId
   , getNodesWithType
+  , selectNodesWith
 
   -- * Creating one or more nodes
   , insertDefaultNode

src/Gargantext/Database/Query/Table/NodeNode.hs

@@ -45,6 +45,9 @@ module Gargantext.Database.Query.Table.NodeNode
   , unpublishNode
   , queryNodeNodeTable
   , shareNode
+
+  -- * Internals (use with caution)
+  , insertNodeNode
   )
   where
 

src/Gargantext/Database/Transactional.hs

+{-# LANGUAGE KindSignatures      #-}
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE TypeOperators       #-}
+{-# LANGUAGE ConstraintKinds #-}
+module Gargantext.Database.Transactional where
+
+import Control.Exception
+import Control.Lens
+import Control.Monad.Base
+import Control.Monad.Trans.Control (MonadBaseControl, control)
+import Data.Pool (withResource, Pool)
+import Data.Profunctor.Product.Default
+import Data.Text qualified as T
+import Database.PostgreSQL.Simple qualified as PG
+import Gargantext.Database.Prelude
+import Gargantext.Database.Query.Table.Node.Error
+import Opaleye
+import Prelude
+
+data DBOperation = DBRead | DBWrite
+
+type DBQuery err r a = DBTransactionOp err r a
+type DBUpdate err a = DBTransactionOp err DBWrite a
+
+data DBTransactionOp err (r :: DBOperation) a where
+  PGQuery   :: (PG.ToRow q, PG.FromRow a) => PG.Query -> q -> DBTransactionOp err r [a]
+  PGUpdate  :: PG.ToRow a => PG.Query -> a -> DBTransactionOp err DBWrite Int
+  OpaQuery  :: Default FromFields fields a => Select fields -> DBTransactionOp err r [a]
+  OpaUpdate :: Insert a -> DBTransactionOp err DBWrite a
+  PureOp    :: a -> DBTransactionOp err r a
+  BindOp    :: DBTransactionOp err r a -> (a -> DBTransactionOp err r b) -> DBTransactionOp err r b
+  DBFail    :: err -> DBTransactionOp err r b
+
+dbFail :: HasNodeError err => err -> DBTransactionOp err r b
+dbFail = DBFail
+
+dbFailWith :: HasNodeError err => T.Text -> DBTransactionOp err r b
+dbFailWith x = dbFail $ _NodeError # (NodeError $ toException $ userError $ T.unpack x)
+
+instance Functor (DBTransactionOp err r) where
+  fmap _ _ = undefined
+
+instance Applicative (DBTransactionOp err r) where
+  pure _ = undefined
+  _ <*> _ = undefined
+
+instance Monad (DBTransactionOp err r) where
+  _ >>= _  = undefined
+
+-- | Generalised version of 'withResource' to work over any unlifted monad.
+-- For some reason 'resource-pool' removed this from version 0.3.0.0 onwards.
+withResourceM :: MonadBaseControl IO m => Pool a -> (a -> m b) -> m b
+withResourceM pool func = control $ \run -> withResource pool (run . func)
+
+withTransactionM :: forall m a. MonadBaseControl IO m => m a -> m a
+withTransactionM _act = undefined
+
+runDBTx :: HasNodeError err => DBUpdate err a -> DBCmd err a
+runDBTx m = do
+  pool <- view connPool
+  withResourceM pool $ \conn -> evalOp conn m
+
+runDBQuery :: HasNodeError err => DBQuery err r a -> DBCmd err a
+runDBQuery m = do
+  pool <- view connPool
+  withResourceM pool $ \conn -> evalOp conn m
+
+evalOp :: HasNodeError err => PG.Connection -> DBTransactionOp err r a -> DBCmd err a
+evalOp conn = \case
+  PGQuery   qr q -> liftBase (PG.query conn qr q)
+  PGUpdate  qr a -> liftBase (fromIntegral <$> PG.execute conn qr a)
+  OpaQuery  sel  -> liftBase (runSelect conn sel)
+  OpaUpdate ins  -> liftBase (runInsert conn ins)
+  _ -> error "todo"
+
+mkPGQuery :: (PG.ToRow q, PG.FromRow a)
+           => PG.Query
+           -> q
+           -> DBQuery err r [a]
+mkPGQuery q s = PGQuery q s
+
+mkPGUpdate :: PG.ToRow a => PG.Query -> a -> DBUpdate err Int
+mkPGUpdate q s = PGUpdate q s
+
+mkOpaQuery :: Default FromFields fields a
+           => Select fields
+           -> DBQuery err x [a]
+mkOpaQuery = OpaQuery
+
+mkOpaUpdate :: Insert a -> DBUpdate err a
+mkOpaUpdate = OpaUpdate

src/Gargantext/Database/Transactional/Example.hs

+{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Gargantext.Database.Transactional.Example where
+
+import Control.Lens
+import Data.Aeson qualified as JSON
+import Gargantext.Core (toDBid)
+import Gargantext.Core.Types
+import Gargantext.Core.Types.Individu
+import Gargantext.Database.Action.Share hiding (getFolderId)
+import Gargantext.Database.Admin.Config
+import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser, HyperdataFolder)
+import Gargantext.Database.Prelude
+import Gargantext.Database.Query.Table.Node (selectNode, selectNodesWith)
+import Gargantext.Database.Query.Table.Node.Error
+import Gargantext.Database.Query.Table.NodeNode (TargetId(..), SourceId (..), NodeNodePoly (..), nodeNodeTable)
+import Gargantext.Database.Query.Table.NodeNode qualified as GGTX hiding (insertNodeNode)
+import Gargantext.Database.Query.Tree.Root (selectRoot)
+import Gargantext.Database.Schema.Node (_node_id)
+import Gargantext.Database.Schema.Node (node_user_id)
+import Gargantext.Database.Transactional
+import Gargantext.Prelude (panicTrace, headMay)
+import Opaleye
+import Prelude
+
+-- | In this example we can compose two QUERY operations
+-- and the result it's still a pure query.
+pureQueryExample :: HasNodeError err
+                => NodeId
+                -> User
+                -> DBCmd err (Node JSON.Value, UserId)
+pureQueryExample n u = runDBQuery $ do
+  nodeToCheck <- getNode n
+  userIdCheck <- getUserId u
+  pure (nodeToCheck, userIdCheck)
+
+-- | In this example we can compose a QUERY operation
+-- with an UPDATE operation, and the overall \"flavor\"
+-- of the DbTx is an UPDATE, so we have to use 'runDBTx'.
+simpleTxExample :: HasNodeError err
+                => NodeId
+                -> DBCmd err Int
+simpleTxExample n = runDBTx $ do
+  nodeToCheck <- getNode n
+  shareNode (SourceId $ _node_id nodeToCheck) (TargetId $ _node_id nodeToCheck)
+
+shareNodeWithTx :: HasNodeError err
+                => ShareNodeWith
+                -> NodeId
+                -- ^ The target node we would like to share, it has
+                -- to be a 'NodeFolderShared'.
+                -> DBCmd err Int
+shareNodeWithTx (ShareNodeWith_User NodeFolderShared u) n = runDBTx $ do
+  nodeToCheck <- getNode   n
+  userIdCheck <- getUserId u
+  if Prelude.not (hasNodeType nodeToCheck NodeTeam)
+    then dbFailWith "[G.D.A.S.shareNodeWith] Can share node Team only"
+    else
+      if (view node_user_id nodeToCheck == userIdCheck)
+        then dbFailWith "[G.D.A.S.shareNodeWith] Can share to others only"
+        else do
+          folderSharedId  <- getFolderId u NodeFolderShared
+          shareNode (SourceId folderSharedId) (TargetId n)
+shareNodeWithTx _ _ = panicTrace "unimplemented (just testing)"
+
+shareNode :: SourceId -> TargetId -> DBUpdate err Int
+shareNode (SourceId sourceId) (TargetId targetId) =
+  insertNodeNode [ NodeNode sourceId targetId Nothing Nothing ]
+
+--
+-- Mock functions for testing
+--
+
+getNode :: forall err x. HasNodeError err => NodeId -> DBQuery err x (Node JSON.Value)
+getNode nId = do
+  xs <- mkOpaQuery (selectNode (pgNodeId nId))
+  case headMay xs of
+    Nothing -> dbFail $ _NodeError # (DoesNotExist nId)
+    Just  r -> pure r
+
+getUserId :: User -> DBQuery err x UserId
+getUserId = undefined
+
+getFolderId :: HasNodeError err => User -> NodeType -> DBQuery err x NodeId
+getFolderId u nt = do
+  rootId <- getRootId u
+  (s :: [ Node HyperdataFolder]) <- mkOpaQuery (selectNodesWith rootId (Just nt) Nothing Nothing)
+  case headMay s of
+    Nothing -> dbFailWith "[G.D.A.S.getFolderId] No folder shared found"
+    Just  f -> pure (_node_id f)
+
+getRootId :: HasNodeError err => User -> DBQuery err x NodeId
+getRootId u = do
+  (xs :: [ Node HyperdataUser]) <- mkOpaQuery (selectRoot u)
+  case headMay xs of
+    Nothing -> dbFailWith "[G.D.Q.T.R.getRootId] No root id"
+    Just  r -> pure (_node_id r)
+
+insertNodeNode :: [GGTX.NodeNode] -> DBUpdate err Int
+insertNodeNode ns = fromIntegral <$> mkOpaUpdate (Insert nodeNodeTable ns' rCount (Just doNothing))
+  where
+    ns' :: [GGTX.NodeNodeWrite]
+    ns' = map (\(NodeNode n1 n2 x y)
+                -> NodeNode (pgNodeId n1)
+                            (pgNodeId n2)
+                            (sqlDouble <$> x)
+                            (sqlInt4 . toDBid <$> y)
+              ) ns

src/Gargantext/Database/Transactional/Prelude.hs

+
+module Gargantext.Database.Transactional.Prelude where
+