{-|
import Gargantext.Database.Prelude (Cmd, runPGSQuery)
Module      : Gargantext.Database.Query.Table.Node
Description : Main Tools of Node to the database
Copyright   : (c) CNRS, 2017-Present
License     : AGPL + CECILL v3
Maintainer  : team@gargantext.org
Stability   : experimental
Portability : POSIX
-}


{-# OPTIONS_GHC -fno-warn-orphans        #-}

{-# LANGUAGE Arrows                 #-}
{-# LANGUAGE ConstraintKinds        #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE TemplateHaskell        #-}
{-# LANGUAGE TypeFamilies           #-}

module Gargantext.Database.Query.Table.Node
  where

import Control.Arrow (returnA)
import Control.Lens (set, view)
import Data.Aeson
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Database.PostgreSQL.Simple as DPS
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Opaleye hiding (FromField)
import Prelude hiding (null, id, map, sum)

import Gargantext.Core
import Gargantext.Core.Types
import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Admin.Types.Hyperdata.Default
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Filter (limit', offset')
import Gargantext.Database.Query.Table.Node.Error
import Gargantext.Database.Schema.Node
import Gargantext.Prelude hiding (sum, head)


queryNodeSearchTable :: Query NodeSearchRead
queryNodeSearchTable :: Query NodeSearchRead
queryNodeSearchTable = Table NodeSearchWrite NodeSearchRead -> Query NodeSearchRead
forall fields a.
Default Unpackspec fields fields =>
Table a fields -> Select fields
selectTable Table NodeSearchWrite NodeSearchRead
nodeTableSearch

selectNode :: Column PGInt4 -> Query NodeRead
selectNode :: Column PGInt4 -> Query NodeRead
selectNode Column PGInt4
id' = proc () -> do
    NodeRead
row      <- Query NodeRead
queryNodeTable -< ()
    SelectArr (Field SqlBool) ()
SelectArr (Column SqlBool) ()
restrict -< NodeRead -> Column PGInt4
forall id hash_id typename user_id parent_id1 name date hyperdata.
NodePoly id hash_id typename user_id parent_id1 name date hyperdata
-> id
_node_id NodeRead
row Column PGInt4 -> Column PGInt4 -> Field SqlBool
forall a. Column a -> Column a -> Field SqlBool
.== Column PGInt4
id'
    SelectArr NodeRead NodeRead
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA  -< NodeRead
row

runGetNodes :: Query NodeRead -> Cmd err [Node HyperdataAny]
runGetNodes :: Query NodeRead -> Cmd err [Node HyperdataAny]
runGetNodes = Query NodeRead -> m [Node HyperdataAny]
forall fields haskells err.
Default FromFields fields haskells =>
Select fields -> Cmd err [haskells]
runOpaQuery

------------------------------------------------------------------------
------------------------------------------------------------------------
-- | order by publication date
-- Favorites (Bool), node_ngrams
selectNodesWith :: HasDBid NodeType
                => ParentId     -> Maybe NodeType
                -> Maybe Offset -> Maybe Limit   -> Query NodeRead
selectNodesWith :: ParentId
-> Maybe NodeType -> Maybe Offset -> Maybe Offset -> Query NodeRead
selectNodesWith ParentId
parentId Maybe NodeType
maybeNodeType Maybe Offset
maybeOffset Maybe Offset
maybeLimit =
        --offset' maybeOffset $ limit' maybeLimit $ orderBy (asc (hyperdataDocument_Publication_date . node_hyperdata)) $ selectNodesWith' parentId typeId
  Maybe Offset -> Query NodeRead -> Query NodeRead
forall a. Maybe Offset -> Query a -> Query a
limit' Maybe Offset
maybeLimit (Query NodeRead -> Query NodeRead)
-> Query NodeRead -> Query NodeRead
forall a b. (a -> b) -> a -> b
$ Maybe Offset -> Query NodeRead -> Query NodeRead
forall a. Maybe Offset -> Query a -> Query a
offset' Maybe Offset
maybeOffset
                    (Query NodeRead -> Query NodeRead)
-> Query NodeRead -> Query NodeRead
forall a b. (a -> b) -> a -> b
$ Order NodeRead -> Query NodeRead -> Query NodeRead
forall a. Order a -> Select a -> Select a
orderBy ((NodeRead -> Column PGInt4) -> Order NodeRead
forall b a. SqlOrd b => (a -> Column b) -> Order a
asc NodeRead -> Column PGInt4
forall id hash_id typename user_id parent_id1 name date hyperdata.
NodePoly id hash_id typename user_id parent_id1 name date hyperdata
-> id
_node_id)
                    (Query NodeRead -> Query NodeRead)
-> Query NodeRead -> Query NodeRead
forall a b. (a -> b) -> a -> b
$ HasDBid NodeType => ParentId -> Maybe NodeType -> Query NodeRead
ParentId -> Maybe NodeType -> Query NodeRead
selectNodesWith' ParentId
parentId Maybe NodeType
maybeNodeType

selectNodesWith' :: HasDBid NodeType
                 => ParentId -> Maybe NodeType -> Query NodeRead
selectNodesWith' :: ParentId -> Maybe NodeType -> Query NodeRead
selectNodesWith' ParentId
parentId Maybe NodeType
maybeNodeType = proc () -> do
    NodeRead
node' <- (proc () -> do
      row :: NodeRead
row@(Node Column PGInt4
_ Column PGText
_ Column PGInt4
typeId Column PGInt4
_ Column PGInt4
parentId' Column PGText
_ Column PGTimestamptz
_ Column PGJsonb
_) <- Query NodeRead
queryNodeTable -< ()
      SelectArr (Field SqlBool) ()
SelectArr (Column SqlBool) ()
restrict -< Column PGInt4
parentId' Column PGInt4 -> Column PGInt4 -> Field SqlBool
forall a. Column a -> Column a -> Field SqlBool
.== (ParentId -> Column PGInt4
pgNodeId ParentId
parentId)

      let typeId' :: Offset
typeId' = Offset -> (NodeType -> Offset) -> Maybe NodeType -> Offset
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Offset
0 NodeType -> Offset
forall a. HasDBid a => a -> Offset
toDBid Maybe NodeType
maybeNodeType

      SelectArr (Field SqlBool) ()
SelectArr (Column SqlBool) ()
restrict -< if Offset
typeId' Offset -> Offset -> Bool
forall a. Ord a => a -> a -> Bool
> Offset
0
                     then Column PGInt4
typeId   Column PGInt4 -> Column PGInt4 -> Field SqlBool
forall a. Column a -> Column a -> Field SqlBool
.== (Offset -> Field PGInt4
sqlInt4 (Offset
typeId' :: Int))
                     else (Bool -> Column SqlBool
pgBool Bool
True)
      SelectArr NodeRead NodeRead
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA  -< NodeRead
row ) -< ()
    SelectArr NodeRead NodeRead
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< NodeRead
node'

deleteNode :: NodeId -> Cmd err Int
deleteNode :: ParentId -> Cmd err Offset
deleteNode ParentId
n = (Connection -> IO Offset) -> Cmd err Offset
forall a err. (Connection -> IO a) -> Cmd err a
mkCmd ((Connection -> IO Offset) -> Cmd err Offset)
-> (Connection -> IO Offset) -> Cmd err Offset
forall a b. (a -> b) -> a -> b
$ \Connection
conn ->
  Int64 -> Offset
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Offset) -> IO Int64 -> IO Offset
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> Delete Int64 -> IO Int64
forall haskells. Connection -> Delete haskells -> IO haskells
runDelete_ Connection
conn
                 (Table NodeWrite NodeRead
-> (NodeRead -> Field SqlBool)
-> Returning NodeRead Int64
-> Delete Int64
forall haskells fieldsW fieldsR.
Table fieldsW fieldsR
-> (fieldsR -> Field SqlBool)
-> Returning fieldsR haskells
-> Delete haskells
Delete Table NodeWrite NodeRead
nodeTable
                         (\(Node Column PGInt4
n_id Column PGText
_ Column PGInt4
_ Column PGInt4
_ Column PGInt4
_ Column PGText
_ Column PGTimestamptz
_ Column PGJsonb
_) -> Column PGInt4
n_id Column PGInt4 -> Column PGInt4 -> Field SqlBool
forall a. Column a -> Column a -> Field SqlBool
.== ParentId -> Column PGInt4
pgNodeId ParentId
n)
                         Returning NodeRead Int64
forall fieldsR. Returning fieldsR Int64
rCount
                 )

deleteNodes :: [NodeId] -> Cmd err Int
deleteNodes :: [ParentId] -> Cmd err Offset
deleteNodes [ParentId]
ns = (Connection -> IO Offset) -> Cmd err Offset
forall a err. (Connection -> IO a) -> Cmd err a
mkCmd ((Connection -> IO Offset) -> Cmd err Offset)
-> (Connection -> IO Offset) -> Cmd err Offset
forall a b. (a -> b) -> a -> b
$ \Connection
conn ->
  Int64 -> Offset
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Offset) -> IO Int64 -> IO Offset
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> Delete Int64 -> IO Int64
forall haskells. Connection -> Delete haskells -> IO haskells
runDelete_ Connection
conn
                   (Table NodeWrite NodeRead
-> (NodeRead -> Field SqlBool)
-> Returning NodeRead Int64
-> Delete Int64
forall haskells fieldsW fieldsR.
Table fieldsW fieldsR
-> (fieldsR -> Field SqlBool)
-> Returning fieldsR haskells
-> Delete haskells
Delete Table NodeWrite NodeRead
nodeTable
                           (\(Node Column PGInt4
n_id Column PGText
_ Column PGInt4
_ Column PGInt4
_ Column PGInt4
_ Column PGText
_ Column PGTimestamptz
_ Column PGJsonb
_) -> [Column PGInt4] -> Column PGInt4 -> Field SqlBool
forall (f :: * -> *) a.
(Functor f, Foldable f) =>
f (Column a) -> Column a -> Field SqlBool
in_ (((ParentId -> Column PGInt4) -> [ParentId] -> [Column PGInt4]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map ParentId -> Column PGInt4
pgNodeId [ParentId]
ns)) Column PGInt4
n_id)
                           Returning NodeRead Int64
forall fieldsR. Returning fieldsR Int64
rCount
                   )

-- TODO: NodeType should match with `a'
getNodesWith :: (JSONB a, HasDBid NodeType) => NodeId -> proxy a -> Maybe NodeType
             -> Maybe Offset -> Maybe Limit -> Cmd err [Node a]
getNodesWith :: ParentId
-> proxy a
-> Maybe NodeType
-> Maybe Offset
-> Maybe Offset
-> Cmd err [Node a]
getNodesWith ParentId
parentId proxy a
_ Maybe NodeType
nodeType Maybe Offset
maybeOffset Maybe Offset
maybeLimit =
    Query NodeRead -> Cmd err [Node a]
forall fields haskells err.
Default FromFields fields haskells =>
Select fields -> Cmd err [haskells]
runOpaQuery (Query NodeRead -> Cmd err [Node a])
-> Query NodeRead -> Cmd err [Node a]
forall a b. (a -> b) -> a -> b
$ HasDBid NodeType =>
ParentId
-> Maybe NodeType -> Maybe Offset -> Maybe Offset -> Query NodeRead
ParentId
-> Maybe NodeType -> Maybe Offset -> Maybe Offset -> Query NodeRead
selectNodesWith ParentId
parentId Maybe NodeType
nodeType Maybe Offset
maybeOffset Maybe Offset
maybeLimit

-- TODO: Why is the second parameter ignored?
-- TODO: Why not use getNodesWith?
getNodesWithParentId :: (Hyperdata a, JSONB a)
                     => Maybe NodeId
                     -> Cmd err [Node a]
getNodesWithParentId :: Maybe ParentId -> Cmd err [Node a]
getNodesWithParentId Maybe ParentId
n = Query NodeRead -> Cmd err [Node a]
forall fields haskells err.
Default FromFields fields haskells =>
Select fields -> Cmd err [haskells]
runOpaQuery (Query NodeRead -> Cmd err [Node a])
-> Query NodeRead -> Cmd err [Node a]
forall a b. (a -> b) -> a -> b
$ ParentId -> Query NodeRead
selectNodesWithParentID ParentId
n'
  where
    n' :: ParentId
n' = case Maybe ParentId
n of
      Just ParentId
n'' -> ParentId
n''
      Maybe ParentId
Nothing  -> ParentId
0


-- | Given a node id, find it's closest parent of given type
-- NOTE: This isn't too optimal: can make successive queries depending on how
-- deeply nested the child is.
getClosestParentIdByType :: HasDBid NodeType
                         => NodeId
                         -> NodeType
                         -> Cmd err (Maybe NodeId)
getClosestParentIdByType :: ParentId -> NodeType -> Cmd err (Maybe ParentId)
getClosestParentIdByType ParentId
nId NodeType
nType = do
  [(ParentId, Offset)]
result <- Query -> (ParentId, Offset) -> m [(ParentId, Offset)]
forall env err (m :: * -> *) r q.
(CmdM env err m, FromRow r, ToRow q) =>
Query -> q -> m [r]
runPGSQuery Query
query (ParentId
nId, Offset
0 :: Int)
  case [(ParentId, Offset)]
result of
    [(NodeId Offset
parentId, Offset
pTypename)] -> do
      if NodeType -> Offset
forall a. HasDBid a => a -> Offset
toDBid NodeType
nType Offset -> Offset -> Bool
forall a. Eq a => a -> a -> Bool
== Offset
pTypename then
        Maybe ParentId -> m (Maybe ParentId)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ParentId -> m (Maybe ParentId))
-> Maybe ParentId -> m (Maybe ParentId)
forall a b. (a -> b) -> a -> b
$ ParentId -> Maybe ParentId
forall a. a -> Maybe a
Just (ParentId -> Maybe ParentId) -> ParentId -> Maybe ParentId
forall a b. (a -> b) -> a -> b
$ Offset -> ParentId
NodeId Offset
parentId
      else
        ParentId -> NodeType -> Cmd err (Maybe ParentId)
forall err.
HasDBid NodeType =>
ParentId -> NodeType -> Cmd err (Maybe ParentId)
getClosestParentIdByType (Offset -> ParentId
NodeId Offset
parentId) NodeType
nType
    [(ParentId, Offset)]
_ -> Maybe ParentId -> m (Maybe ParentId)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ParentId
forall a. Maybe a
Nothing
  where
    query :: DPS.Query
    query :: Query
query = [sql|
      SELECT n2.id, n2.typename
      FROM nodes n1
        JOIN nodes n2 ON n1.parent_id = n2.id
        WHERE n1.id = ? AND 0 = ?;
    |]

-- | Similar to `getClosestParentIdByType` but includes current node
-- in search too
getClosestParentIdByType' :: HasDBid NodeType
                          => NodeId
                          -> NodeType
                          -> Cmd err (Maybe NodeId)
getClosestParentIdByType' :: ParentId -> NodeType -> Cmd err (Maybe ParentId)
getClosestParentIdByType' ParentId
nId NodeType
nType = do
  [(ParentId, Offset)]
result <- Query -> (ParentId, Offset) -> m [(ParentId, Offset)]
forall env err (m :: * -> *) r q.
(CmdM env err m, FromRow r, ToRow q) =>
Query -> q -> m [r]
runPGSQuery Query
query (ParentId
nId, Offset
0 :: Int)
  case [(ParentId, Offset)]
result of
    [(NodeId Offset
id, Offset
pTypename)] -> do
      if NodeType -> Offset
forall a. HasDBid a => a -> Offset
toDBid NodeType
nType Offset -> Offset -> Bool
forall a. Eq a => a -> a -> Bool
== Offset
pTypename then
        Maybe ParentId -> m (Maybe ParentId)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ParentId -> m (Maybe ParentId))
-> Maybe ParentId -> m (Maybe ParentId)
forall a b. (a -> b) -> a -> b
$ ParentId -> Maybe ParentId
forall a. a -> Maybe a
Just (ParentId -> Maybe ParentId) -> ParentId -> Maybe ParentId
forall a b. (a -> b) -> a -> b
$ Offset -> ParentId
NodeId Offset
id
      else
        ParentId -> NodeType -> Cmd err (Maybe ParentId)
forall err.
HasDBid NodeType =>
ParentId -> NodeType -> Cmd err (Maybe ParentId)
getClosestParentIdByType ParentId
nId NodeType
nType
    [(ParentId, Offset)]
_ -> Maybe ParentId -> m (Maybe ParentId)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ParentId
forall a. Maybe a
Nothing
  where
    query :: DPS.Query
    query :: Query
query = [sql|
      SELECT n.id, n.typename
      FROM nodes n
      WHERE n.id = ? AND 0 = ?;
    |]

-- | Given a node id, find all it's children (no matter how deep) of
-- given node type.
getChildrenByType :: HasDBid NodeType
                  => NodeId
                  -> NodeType
                  -> Cmd err [NodeId]
getChildrenByType :: ParentId -> NodeType -> Cmd err [ParentId]
getChildrenByType ParentId
nId NodeType
nType = do
  [(ParentId, Offset)]
result <- Query -> (ParentId, Offset) -> m [(ParentId, Offset)]
forall env err (m :: * -> *) r q.
(CmdM env err m, FromRow r, ToRow q) =>
Query -> q -> m [r]
runPGSQuery Query
query (ParentId
nId, Offset
0 :: Int)
  [[ParentId]]
children_lst <- ((ParentId, Offset) -> m [ParentId])
-> [(ParentId, Offset)] -> m [[ParentId]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(ParentId
id, Offset
_) -> ParentId -> NodeType -> Cmd err [ParentId]
forall err.
HasDBid NodeType =>
ParentId -> NodeType -> Cmd err [ParentId]
getChildrenByType ParentId
id NodeType
nType) [(ParentId, Offset)]
result
  [ParentId] -> m [ParentId]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ParentId] -> m [ParentId]) -> [ParentId] -> m [ParentId]
forall a b. (a -> b) -> a -> b
$ [[ParentId]] -> [ParentId]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[ParentId]] -> [ParentId]) -> [[ParentId]] -> [ParentId]
forall a b. (a -> b) -> a -> b
$ [(ParentId, Offset) -> ParentId
forall a b. (a, b) -> a
fst ((ParentId, Offset) -> ParentId)
-> [(ParentId, Offset)] -> [ParentId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((ParentId, Offset) -> Bool)
-> [(ParentId, Offset)] -> [(ParentId, Offset)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(ParentId
_, Offset
pTypename) -> Offset
pTypename Offset -> Offset -> Bool
forall a. Eq a => a -> a -> Bool
== NodeType -> Offset
forall a. HasDBid a => a -> Offset
toDBid NodeType
nType) [(ParentId, Offset)]
result] [[ParentId]] -> [[ParentId]] -> [[ParentId]]
forall a. [a] -> [a] -> [a]
++ [[ParentId]]
children_lst
  where
    query :: DPS.Query
    query :: Query
query = [sql|
      SELECT n.id, n.typename
      FROM nodes n
        WHERE n.parent_id = ? AND 0 = ?;
    |]

------------------------------------------------------------------------
getDocumentsV3WithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataDocumentV3]
getDocumentsV3WithParentId :: ParentId -> Cmd err [Node HyperdataDocumentV3]
getDocumentsV3WithParentId ParentId
n = Query NodeRead -> Cmd err [Node HyperdataDocumentV3]
forall fields haskells err.
Default FromFields fields haskells =>
Select fields -> Cmd err [haskells]
runOpaQuery (Query NodeRead -> Cmd err [Node HyperdataDocumentV3])
-> Query NodeRead -> Cmd err [Node HyperdataDocumentV3]
forall a b. (a -> b) -> a -> b
$ HasDBid NodeType => ParentId -> Maybe NodeType -> Query NodeRead
ParentId -> Maybe NodeType -> Query NodeRead
selectNodesWith' ParentId
n (NodeType -> Maybe NodeType
forall a. a -> Maybe a
Just NodeType
NodeDocument)

-- TODO: merge with getDocumentsWithParentId by having a class IsHyperdataDocument
getDocumentsWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataDocument]
getDocumentsWithParentId :: ParentId -> Cmd err [Node HyperdataDocument]
getDocumentsWithParentId ParentId
n = Query NodeRead -> Cmd err [Node HyperdataDocument]
forall fields haskells err.
Default FromFields fields haskells =>
Select fields -> Cmd err [haskells]
runOpaQuery (Query NodeRead -> Cmd err [Node HyperdataDocument])
-> Query NodeRead -> Cmd err [Node HyperdataDocument]
forall a b. (a -> b) -> a -> b
$ HasDBid NodeType => ParentId -> Maybe NodeType -> Query NodeRead
ParentId -> Maybe NodeType -> Query NodeRead
selectNodesWith' ParentId
n (NodeType -> Maybe NodeType
forall a. a -> Maybe a
Just NodeType
NodeDocument)

getListsModelWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataModel]
getListsModelWithParentId :: ParentId -> Cmd err [Node HyperdataModel]
getListsModelWithParentId ParentId
n = Query NodeRead -> Cmd err [Node HyperdataModel]
forall fields haskells err.
Default FromFields fields haskells =>
Select fields -> Cmd err [haskells]
runOpaQuery (Query NodeRead -> Cmd err [Node HyperdataModel])
-> Query NodeRead -> Cmd err [Node HyperdataModel]
forall a b. (a -> b) -> a -> b
$ HasDBid NodeType => ParentId -> Maybe NodeType -> Query NodeRead
ParentId -> Maybe NodeType -> Query NodeRead
selectNodesWith' ParentId
n (NodeType -> Maybe NodeType
forall a. a -> Maybe a
Just NodeType
NodeModel)

getCorporaWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataCorpus]
getCorporaWithParentId :: ParentId -> Cmd err [Node HyperdataCorpus]
getCorporaWithParentId ParentId
n = Query NodeRead -> Cmd err [Node HyperdataCorpus]
forall fields haskells err.
Default FromFields fields haskells =>
Select fields -> Cmd err [haskells]
runOpaQuery (Query NodeRead -> Cmd err [Node HyperdataCorpus])
-> Query NodeRead -> Cmd err [Node HyperdataCorpus]
forall a b. (a -> b) -> a -> b
$ HasDBid NodeType => ParentId -> Maybe NodeType -> Query NodeRead
ParentId -> Maybe NodeType -> Query NodeRead
selectNodesWith' ParentId
n (NodeType -> Maybe NodeType
forall a. a -> Maybe a
Just NodeType
NodeCorpus)

------------------------------------------------------------------------
selectNodesWithParentID :: NodeId -> Query NodeRead
selectNodesWithParentID :: ParentId -> Query NodeRead
selectNodesWithParentID ParentId
n = proc () -> do
    row :: NodeRead
row@(Node Column PGInt4
_ Column PGText
_ Column PGInt4
_ Column PGInt4
_ Column PGInt4
parent_id Column PGText
_ Column PGTimestamptz
_ Column PGJsonb
_) <- Query NodeRead
queryNodeTable -< ()
    SelectArr (Field SqlBool) ()
SelectArr (Column SqlBool) ()
restrict -< Column PGInt4
parent_id Column PGInt4 -> Column PGInt4 -> Field SqlBool
forall a. Column a -> Column a -> Field SqlBool
.== (ParentId -> Column PGInt4
pgNodeId ParentId
n)
    SelectArr NodeRead NodeRead
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< NodeRead
row


------------------------------------------------------------------------
-- | Example of use:
-- runCmdReplEasy  (getNodesWithType NodeList (Proxy :: Proxy HyperdataList))
getNodesWithType :: (HasNodeError err, JSONB a, HasDBid NodeType) => NodeType -> proxy a -> Cmd err [Node a]
getNodesWithType :: NodeType -> proxy a -> Cmd err [Node a]
getNodesWithType NodeType
nt proxy a
_ = Query NodeRead -> Cmd err [Node a]
forall fields haskells err.
Default FromFields fields haskells =>
Select fields -> Cmd err [haskells]
runOpaQuery (Query NodeRead -> Cmd err [Node a])
-> Query NodeRead -> Cmd err [Node a]
forall a b. (a -> b) -> a -> b
$ HasDBid NodeType => NodeType -> Query NodeRead
NodeType -> Query NodeRead
selectNodesWithType NodeType
nt
  where
    selectNodesWithType ::  HasDBid NodeType
                         => NodeType -> Query NodeRead
    selectNodesWithType :: NodeType -> Query NodeRead
selectNodesWithType NodeType
nt' = proc () -> do
        row :: NodeRead
row@(Node Column PGInt4
_ Column PGText
_ Column PGInt4
tn Column PGInt4
_ Column PGInt4
_ Column PGText
_ Column PGTimestamptz
_ Column PGJsonb
_) <- Query NodeRead
queryNodeTable -< ()
        SelectArr (Field SqlBool) ()
SelectArr (Column SqlBool) ()
restrict -< Column PGInt4
tn Column PGInt4 -> Column PGInt4 -> Field SqlBool
forall a. Column a -> Column a -> Field SqlBool
.== (Offset -> Field PGInt4
sqlInt4 (Offset -> Field PGInt4) -> Offset -> Field PGInt4
forall a b. (a -> b) -> a -> b
$ NodeType -> Offset
forall a. HasDBid a => a -> Offset
toDBid NodeType
nt')
        SelectArr NodeRead NodeRead
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< NodeRead
row

getNodesIdWithType :: (HasNodeError err, HasDBid NodeType) => NodeType -> Cmd err [NodeId]
getNodesIdWithType :: NodeType -> Cmd err [ParentId]
getNodesIdWithType NodeType
nt = do
  [Offset]
ns <- Select (Column PGInt4) -> Cmd err [Offset]
forall fields haskells err.
Default FromFields fields haskells =>
Select fields -> Cmd err [haskells]
runOpaQuery (Select (Column PGInt4) -> Cmd err [Offset])
-> Select (Column PGInt4) -> Cmd err [Offset]
forall a b. (a -> b) -> a -> b
$ HasDBid NodeType => NodeType -> Select (Column PGInt4)
NodeType -> Select (Column PGInt4)
selectNodesIdWithType NodeType
nt
  [ParentId] -> m [ParentId]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Offset -> ParentId) -> [Offset] -> [ParentId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Offset -> ParentId
NodeId [Offset]
ns)

selectNodesIdWithType :: HasDBid NodeType
                      => NodeType -> Query (Column PGInt4)
selectNodesIdWithType :: NodeType -> Select (Column PGInt4)
selectNodesIdWithType NodeType
nt = proc () -> do
    row :: NodeRead
row@(Node Column PGInt4
_ Column PGText
_ Column PGInt4
tn Column PGInt4
_ Column PGInt4
_ Column PGText
_ Column PGTimestamptz
_ Column PGJsonb
_) <- Query NodeRead
queryNodeTable -< ()
    SelectArr (Field SqlBool) ()
SelectArr (Column SqlBool) ()
restrict -< Column PGInt4
tn Column PGInt4 -> Column PGInt4 -> Field SqlBool
forall a. Column a -> Column a -> Field SqlBool
.== (Offset -> Field PGInt4
sqlInt4 (Offset -> Field PGInt4) -> Offset -> Field PGInt4
forall a b. (a -> b) -> a -> b
$ NodeType -> Offset
forall a. HasDBid a => a -> Offset
toDBid NodeType
nt)
    SelectArr (Column PGInt4) (Column PGInt4)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< NodeRead -> Column PGInt4
forall id hash_id typename user_id parent_id1 name date hyperdata.
NodePoly id hash_id typename user_id parent_id1 name date hyperdata
-> id
_node_id NodeRead
row

------------------------------------------------------------------------


getNode :: HasNodeError err => NodeId -> Cmd err (Node Value)
getNode :: ParentId -> Cmd err (Node Value)
getNode ParentId
nId = do
  Maybe (Node Value)
maybeNode <- [Node Value] -> Maybe (Node Value)
forall a. [a] -> Maybe a
headMay ([Node Value] -> Maybe (Node Value))
-> m [Node Value] -> m (Maybe (Node Value))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Query NodeRead -> Cmd err [Node Value]
forall fields haskells err.
Default FromFields fields haskells =>
Select fields -> Cmd err [haskells]
runOpaQuery (Column PGInt4 -> Query NodeRead
selectNode (ParentId -> Column PGInt4
pgNodeId ParentId
nId))
  case Maybe (Node Value)
maybeNode of
    Maybe (Node Value)
Nothing -> NodeError -> m (Node Value)
forall e (m :: * -> *) a.
(MonadError e m, HasNodeError e) =>
NodeError -> m a
nodeError (ParentId -> NodeError
DoesNotExist ParentId
nId)
    Just  Node Value
r -> Node Value -> m (Node Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Node Value
r

getNodeWith :: (HasNodeError err, JSONB a)
            => NodeId -> proxy a -> Cmd err (Node a)
getNodeWith :: ParentId -> proxy a -> Cmd err (Node a)
getNodeWith ParentId
nId proxy a
_ = do
  Maybe (Node a)
maybeNode <- [Node a] -> Maybe (Node a)
forall a. [a] -> Maybe a
headMay ([Node a] -> Maybe (Node a)) -> m [Node a] -> m (Maybe (Node a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Query NodeRead -> Cmd err [Node a]
forall fields haskells err.
Default FromFields fields haskells =>
Select fields -> Cmd err [haskells]
runOpaQuery (Column PGInt4 -> Query NodeRead
selectNode (ParentId -> Column PGInt4
pgNodeId ParentId
nId))
  case Maybe (Node a)
maybeNode of
    Maybe (Node a)
Nothing -> NodeError -> m (Node a)
forall e (m :: * -> *) a.
(MonadError e m, HasNodeError e) =>
NodeError -> m a
nodeError (ParentId -> NodeError
DoesNotExist ParentId
nId)
    Just  Node a
r -> Node a -> m (Node a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Node a
r


------------------------------------------------------------------------
-- | Sugar to insert Node with NodeType in Database
insertDefaultNode :: HasDBid NodeType
                  => NodeType -> ParentId -> UserId -> Cmd err [NodeId]
insertDefaultNode :: NodeType -> ParentId -> Offset -> Cmd err [ParentId]
insertDefaultNode NodeType
nt ParentId
p Offset
u = NodeType
-> Maybe Name
-> Maybe DefaultHyperdata
-> ParentId
-> Offset
-> Cmd err [ParentId]
forall err.
HasDBid NodeType =>
NodeType
-> Maybe Name
-> Maybe DefaultHyperdata
-> ParentId
-> Offset
-> Cmd err [ParentId]
insertNode NodeType
nt Maybe Name
forall a. Maybe a
Nothing Maybe DefaultHyperdata
forall a. Maybe a
Nothing ParentId
p Offset
u

insertNode :: HasDBid NodeType
           => NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> Cmd err [NodeId]
insertNode :: NodeType
-> Maybe Name
-> Maybe DefaultHyperdata
-> ParentId
-> Offset
-> Cmd err [ParentId]
insertNode NodeType
nt Maybe Name
n Maybe DefaultHyperdata
h ParentId
p Offset
u = [NodeWrite] -> Cmd err [ParentId]
forall err. [NodeWrite] -> Cmd err [ParentId]
insertNodesR [HasDBid NodeType =>
NodeType
-> Maybe Name
-> Maybe DefaultHyperdata
-> ParentId
-> Offset
-> NodeWrite
NodeType
-> Maybe Name
-> Maybe DefaultHyperdata
-> ParentId
-> Offset
-> NodeWrite
nodeW NodeType
nt Maybe Name
n Maybe DefaultHyperdata
h ParentId
p Offset
u]

nodeW ::  HasDBid NodeType
       => NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> NodeWrite
nodeW :: NodeType
-> Maybe Name
-> Maybe DefaultHyperdata
-> ParentId
-> Offset
-> NodeWrite
nodeW NodeType
nt Maybe Name
n Maybe DefaultHyperdata
h ParentId
p Offset
u = NodeType
-> Name
-> DefaultHyperdata
-> Maybe ParentId
-> Offset
-> NodeWrite
forall a.
(ToJSON a, Hyperdata a, HasDBid NodeType) =>
NodeType -> Name -> a -> Maybe ParentId -> Offset -> NodeWrite
node NodeType
nt Name
n' DefaultHyperdata
h' (ParentId -> Maybe ParentId
forall a. a -> Maybe a
Just ParentId
p) Offset
u
  where
    n' :: Name
n' = Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe (NodeType -> Name
defaultName NodeType
nt) Maybe Name
n
    h' :: DefaultHyperdata
h' = DefaultHyperdata
-> (DefaultHyperdata -> DefaultHyperdata)
-> Maybe DefaultHyperdata
-> DefaultHyperdata
forall b a. b -> (a -> b) -> Maybe a -> b
maybe     (NodeType -> DefaultHyperdata
defaultHyperdata NodeType
nt) DefaultHyperdata -> DefaultHyperdata
forall a. a -> a
identity Maybe DefaultHyperdata
h

------------------------------------------------------------------------
node :: (ToJSON a, Hyperdata a, HasDBid NodeType)
     => NodeType
     -> Name
     -> a
     -> Maybe ParentId
     -> UserId
     -> NodeWrite
node :: NodeType -> Name -> a -> Maybe ParentId -> Offset -> NodeWrite
node NodeType
nodeType Name
name a
hyperData Maybe ParentId
parentId Offset
userId =
  Maybe (Column PGInt4)
-> Maybe (Column PGText)
-> Column PGInt4
-> Column PGInt4
-> Maybe (Column PGInt4)
-> Column PGText
-> Maybe (Column PGTimestamptz)
-> Column PGJsonb
-> NodeWrite
forall id hash_id typename user_id parent_id1 name date hyperdata.
id
-> hash_id
-> typename
-> user_id
-> parent_id1
-> name
-> date
-> hyperdata
-> NodePoly
     id hash_id typename user_id parent_id1 name date hyperdata
Node Maybe (Column PGInt4)
forall a. Maybe a
Nothing Maybe (Column PGText)
forall a. Maybe a
Nothing
       (Offset -> Field PGInt4
sqlInt4 Offset
typeId)
       (Offset -> Field PGInt4
sqlInt4 Offset
userId)
       (ParentId -> Column PGInt4
pgNodeId (ParentId -> Column PGInt4)
-> Maybe ParentId -> Maybe (Column PGInt4)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ParentId
parentId)
       (Name -> Field PGText
sqlStrictText Name
name)
       Maybe (Column PGTimestamptz)
forall a. Maybe a
Nothing
       (String -> Column PGJsonb
pgJSONB (String -> Column PGJsonb) -> String -> Column PGJsonb
forall a b. (a -> b) -> a -> b
$ ByteString -> String
forall a b. ConvertibleStrings a b => a -> b
cs (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. ToJSON a => a -> ByteString
encode a
hyperData)
    where
      typeId :: Offset
typeId = NodeType -> Offset
forall a. HasDBid a => a -> Offset
toDBid NodeType
nodeType

                  -------------------------------
insertNodes :: [NodeWrite] -> Cmd err Int64
insertNodes :: [NodeWrite] -> Cmd err Int64
insertNodes [NodeWrite]
ns = (Connection -> IO Int64) -> Cmd err Int64
forall a err. (Connection -> IO a) -> Cmd err a
mkCmd ((Connection -> IO Int64) -> Cmd err Int64)
-> (Connection -> IO Int64) -> Cmd err Int64
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> Connection -> Insert Int64 -> IO Int64
forall haskells. Connection -> Insert haskells -> IO haskells
runInsert_ Connection
conn (Insert Int64 -> IO Int64) -> Insert Int64 -> IO Int64
forall a b. (a -> b) -> a -> b
$ Table NodeWrite NodeRead
-> [NodeWrite]
-> Returning NodeRead Int64
-> Maybe OnConflict
-> Insert Int64
forall haskells fieldsW fieldsR.
Table fieldsW fieldsR
-> [fieldsW]
-> Returning fieldsR haskells
-> Maybe OnConflict
-> Insert haskells
Insert Table NodeWrite NodeRead
nodeTable [NodeWrite]
ns Returning NodeRead Int64
forall fieldsR. Returning fieldsR Int64
rCount Maybe OnConflict
forall a. Maybe a
Nothing

{-
insertNodes' :: [Node a] -> Cmd err Int64
insertNodes' ns = mkCmd $ \conn -> runInsert_ conn
                        $ Insert nodeTable ns' rCount Nothing
  where
    ns' :: [NodeWrite]
    ns' = map (\(Node i t u p n d h)
                -> Node (pgNodeId          <$> i)
                        (sqlInt4 $ toDBid      t)
                        (sqlInt4                u)
                        (pgNodeId          <$> p)
                        (sqlStrictText          n)
                        (pgUTCTime         <$> d)
                        (pgJSONB $ cs $ encode h)
              ) ns
-}

insertNodesR :: [NodeWrite] -> Cmd err [NodeId]
insertNodesR :: [NodeWrite] -> Cmd err [ParentId]
insertNodesR [NodeWrite]
ns = (Connection -> IO [ParentId]) -> Cmd err [ParentId]
forall a err. (Connection -> IO a) -> Cmd err a
mkCmd ((Connection -> IO [ParentId]) -> Cmd err [ParentId])
-> (Connection -> IO [ParentId]) -> Cmd err [ParentId]
forall a b. (a -> b) -> a -> b
$ \Connection
conn ->
  Connection -> Insert [ParentId] -> IO [ParentId]
forall haskells. Connection -> Insert haskells -> IO haskells
runInsert_ Connection
conn (Table NodeWrite NodeRead
-> [NodeWrite]
-> Returning NodeRead [ParentId]
-> Maybe OnConflict
-> Insert [ParentId]
forall haskells fieldsW fieldsR.
Table fieldsW fieldsR
-> [fieldsW]
-> Returning fieldsR haskells
-> Maybe OnConflict
-> Insert haskells
Insert Table NodeWrite NodeRead
nodeTable [NodeWrite]
ns ((NodeRead -> Column PGInt4) -> Returning NodeRead [ParentId]
forall fields haskells fieldsR.
Default FromFields fields haskells =>
(fieldsR -> fields) -> Returning fieldsR [haskells]
rReturning (\(Node Column PGInt4
i Column PGText
_ Column PGInt4
_ Column PGInt4
_ Column PGInt4
_ Column PGText
_ Column PGTimestamptz
_ Column PGJsonb
_) -> Column PGInt4
i)) Maybe OnConflict
forall a. Maybe a
Nothing)

insertNodesWithParent :: Maybe ParentId -> [NodeWrite] -> Cmd err Int64
insertNodesWithParent :: Maybe ParentId -> [NodeWrite] -> Cmd err Int64
insertNodesWithParent Maybe ParentId
pid [NodeWrite]
ns = [NodeWrite] -> Cmd err Int64
forall err. [NodeWrite] -> Cmd err Int64
insertNodes (ASetter
  NodeWrite NodeWrite (Maybe (Column PGInt4)) (Maybe (Column PGInt4))
-> Maybe (Column PGInt4) -> NodeWrite -> NodeWrite
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  NodeWrite NodeWrite (Maybe (Column PGInt4)) (Maybe (Column PGInt4))
forall id hash_id typename user_id parent_id1 name date hyperdata
       parent_id2.
Lens
  (NodePoly
     id hash_id typename user_id parent_id1 name date hyperdata)
  (NodePoly
     id hash_id typename user_id parent_id2 name date hyperdata)
  parent_id1
  parent_id2
node_parent_id (ParentId -> Column PGInt4
pgNodeId (ParentId -> Column PGInt4)
-> Maybe ParentId -> Maybe (Column PGInt4)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ParentId
pid) (NodeWrite -> NodeWrite) -> [NodeWrite] -> [NodeWrite]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NodeWrite]
ns)

insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [NodeId]
insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [ParentId]
insertNodesWithParentR Maybe ParentId
pid [NodeWrite]
ns = [NodeWrite] -> Cmd err [ParentId]
forall err. [NodeWrite] -> Cmd err [ParentId]
insertNodesR (ASetter
  NodeWrite NodeWrite (Maybe (Column PGInt4)) (Maybe (Column PGInt4))
-> Maybe (Column PGInt4) -> NodeWrite -> NodeWrite
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  NodeWrite NodeWrite (Maybe (Column PGInt4)) (Maybe (Column PGInt4))
forall id hash_id typename user_id parent_id1 name date hyperdata
       parent_id2.
Lens
  (NodePoly
     id hash_id typename user_id parent_id1 name date hyperdata)
  (NodePoly
     id hash_id typename user_id parent_id2 name date hyperdata)
  parent_id1
  parent_id2
node_parent_id (ParentId -> Column PGInt4
pgNodeId (ParentId -> Column PGInt4)
-> Maybe ParentId -> Maybe (Column PGInt4)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ParentId
pid) (NodeWrite -> NodeWrite) -> [NodeWrite] -> [NodeWrite]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NodeWrite]
ns)
------------------------------------------------------------------------
-- TODO
-- currently this function removes the child relation
-- needs a Temporary type between Node' and NodeWriteT

node2table :: HasDBid NodeType
           => UserId -> Maybe ParentId -> Node' -> NodeWrite
node2table :: Offset -> Maybe ParentId -> Node' -> NodeWrite
node2table Offset
uid Maybe ParentId
pid (Node' NodeType
nt Name
txt Value
v []) = Maybe (Column PGInt4)
-> Maybe (Column PGText)
-> Column PGInt4
-> Column PGInt4
-> Maybe (Column PGInt4)
-> Column PGText
-> Maybe (Column PGTimestamptz)
-> Column PGJsonb
-> NodeWrite
forall id hash_id typename user_id parent_id1 name date hyperdata.
id
-> hash_id
-> typename
-> user_id
-> parent_id1
-> name
-> date
-> hyperdata
-> NodePoly
     id hash_id typename user_id parent_id1 name date hyperdata
Node Maybe (Column PGInt4)
forall a. Maybe a
Nothing Maybe (Column PGText)
forall a. Maybe a
Nothing (Offset -> Field PGInt4
sqlInt4 (Offset -> Field PGInt4) -> Offset -> Field PGInt4
forall a b. (a -> b) -> a -> b
$ NodeType -> Offset
forall a. HasDBid a => a -> Offset
toDBid NodeType
nt) (Offset -> Field PGInt4
sqlInt4 Offset
uid) ((ParentId -> Column PGInt4)
-> Maybe ParentId -> Maybe (Column PGInt4)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ParentId -> Column PGInt4
pgNodeId Maybe ParentId
pid) (Name -> Field PGText
sqlStrictText Name
txt) Maybe (Column PGTimestamptz)
forall a. Maybe a
Nothing (ByteString -> Column PGJsonb
pgStrictJSONB (ByteString -> Column PGJsonb) -> ByteString -> Column PGJsonb
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode Value
v)
node2table Offset
_ Maybe ParentId
_ (Node' NodeType
_ Name
_ Value
_ [Node']
_) = Name -> NodeWrite
forall a. HasCallStack => Name -> a
panic Name
"node2table: should not happen, Tree insert not implemented yet"


data Node' = Node' { Node' -> NodeType
_n_type :: NodeType
                   , Node' -> Name
_n_name :: Text
                   , Node' -> Value
_n_data :: Value
                   , Node' -> [Node']
_n_children :: [Node']
                   } deriving (Offset -> Node' -> ShowS
[Node'] -> ShowS
Node' -> String
(Offset -> Node' -> ShowS)
-> (Node' -> String) -> ([Node'] -> ShowS) -> Show Node'
forall a.
(Offset -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Node'] -> ShowS
$cshowList :: [Node'] -> ShowS
show :: Node' -> String
$cshow :: Node' -> String
showsPrec :: Offset -> Node' -> ShowS
$cshowsPrec :: Offset -> Node' -> ShowS
Show)

mkNodes :: [NodeWrite] -> Cmd err Int64
mkNodes :: [NodeWrite] -> Cmd err Int64
mkNodes [NodeWrite]
ns = (Connection -> IO Int64) -> Cmd err Int64
forall a err. (Connection -> IO a) -> Cmd err a
mkCmd ((Connection -> IO Int64) -> Cmd err Int64)
-> (Connection -> IO Int64) -> Cmd err Int64
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> Connection -> Insert Int64 -> IO Int64
forall haskells. Connection -> Insert haskells -> IO haskells
runInsert_ Connection
conn
                   (Insert Int64 -> IO Int64) -> Insert Int64 -> IO Int64
forall a b. (a -> b) -> a -> b
$ Table NodeWrite NodeRead
-> [NodeWrite]
-> Returning NodeRead Int64
-> Maybe OnConflict
-> Insert Int64
forall haskells fieldsW fieldsR.
Table fieldsW fieldsR
-> [fieldsW]
-> Returning fieldsR haskells
-> Maybe OnConflict
-> Insert haskells
Insert Table NodeWrite NodeRead
nodeTable [NodeWrite]
ns Returning NodeRead Int64
forall fieldsR. Returning fieldsR Int64
rCount Maybe OnConflict
forall a. Maybe a
Nothing

mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
mkNodeR :: [NodeWrite] -> Cmd err [ParentId]
mkNodeR [NodeWrite]
ns = (Connection -> IO [ParentId]) -> Cmd err [ParentId]
forall a err. (Connection -> IO a) -> Cmd err a
mkCmd ((Connection -> IO [ParentId]) -> Cmd err [ParentId])
-> (Connection -> IO [ParentId]) -> Cmd err [ParentId]
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> Connection -> Insert [ParentId] -> IO [ParentId]
forall haskells. Connection -> Insert haskells -> IO haskells
runInsert_ Connection
conn (Insert [ParentId] -> IO [ParentId])
-> Insert [ParentId] -> IO [ParentId]
forall a b. (a -> b) -> a -> b
$ Table NodeWrite NodeRead
-> [NodeWrite]
-> Returning NodeRead [ParentId]
-> Maybe OnConflict
-> Insert [ParentId]
forall haskells fieldsW fieldsR.
Table fieldsW fieldsR
-> [fieldsW]
-> Returning fieldsR haskells
-> Maybe OnConflict
-> Insert haskells
Insert Table NodeWrite NodeRead
nodeTable [NodeWrite]
ns ((NodeRead -> Column PGInt4) -> Returning NodeRead [ParentId]
forall fields haskells fieldsR.
Default FromFields fields haskells =>
(fieldsR -> fields) -> Returning fieldsR [haskells]
rReturning NodeRead -> Column PGInt4
forall id hash_id typename user_id parent_id1 name date hyperdata.
NodePoly id hash_id typename user_id parent_id1 name date hyperdata
-> id
_node_id) Maybe OnConflict
forall a. Maybe a
Nothing

------------------------------------------------------------------------
childWith ::  HasDBid NodeType
           => UserId -> ParentId -> Node' -> NodeWrite
childWith :: Offset -> ParentId -> Node' -> NodeWrite
childWith Offset
uId ParentId
pId (Node' NodeType
NodeDocument Name
txt Value
v []) = Offset -> Maybe ParentId -> Node' -> NodeWrite
HasDBid NodeType => Offset -> Maybe ParentId -> Node' -> NodeWrite
node2table Offset
uId (ParentId -> Maybe ParentId
forall a. a -> Maybe a
Just ParentId
pId) (NodeType -> Name -> Value -> [Node'] -> Node'
Node' NodeType
NodeDocument Name
txt Value
v [])
childWith Offset
uId ParentId
pId (Node' NodeType
NodeContact  Name
txt Value
v []) = Offset -> Maybe ParentId -> Node' -> NodeWrite
HasDBid NodeType => Offset -> Maybe ParentId -> Node' -> NodeWrite
node2table Offset
uId (ParentId -> Maybe ParentId
forall a. a -> Maybe a
Just ParentId
pId) (NodeType -> Name -> Value -> [Node'] -> Node'
Node' NodeType
NodeContact Name
txt Value
v [])
childWith Offset
_   ParentId
_   (Node' NodeType
_        Name
_   Value
_ [Node']
_) = Name -> NodeWrite
forall a. HasCallStack => Name -> a
panic Name
"This NodeType can not be a child"


-- =================================================================== --
-- |
-- CorpusDocument is a corpus made from a set of documents
-- CorpusContact  is a corpus made from a set of contacts (syn of Annuaire)
data CorpusType = CorpusDocument | CorpusContact

class MkCorpus a
  where
    mk :: HasDBid NodeType => Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]

instance MkCorpus HyperdataCorpus
  where
    mk :: Maybe Name
-> Maybe HyperdataCorpus
-> ParentId
-> Offset
-> Cmd err [ParentId]
mk Maybe Name
n Maybe HyperdataCorpus
Nothing  ParentId
p Offset
u = NodeType
-> Maybe Name
-> Maybe DefaultHyperdata
-> ParentId
-> Offset
-> Cmd err [ParentId]
forall err.
HasDBid NodeType =>
NodeType
-> Maybe Name
-> Maybe DefaultHyperdata
-> ParentId
-> Offset
-> Cmd err [ParentId]
insertNode NodeType
NodeCorpus Maybe Name
n Maybe DefaultHyperdata
forall a. Maybe a
Nothing ParentId
p Offset
u
    mk Maybe Name
n (Just HyperdataCorpus
h) ParentId
p Offset
u = NodeType
-> Maybe Name
-> Maybe DefaultHyperdata
-> ParentId
-> Offset
-> Cmd err [ParentId]
forall err.
HasDBid NodeType =>
NodeType
-> Maybe Name
-> Maybe DefaultHyperdata
-> ParentId
-> Offset
-> Cmd err [ParentId]
insertNode NodeType
NodeCorpus Maybe Name
n (DefaultHyperdata -> Maybe DefaultHyperdata
forall a. a -> Maybe a
Just (DefaultHyperdata -> Maybe DefaultHyperdata)
-> DefaultHyperdata -> Maybe DefaultHyperdata
forall a b. (a -> b) -> a -> b
$ HyperdataCorpus -> DefaultHyperdata
DefaultCorpus HyperdataCorpus
h) ParentId
p Offset
u


instance MkCorpus HyperdataAnnuaire
  where
    mk :: Maybe Name
-> Maybe HyperdataAnnuaire
-> ParentId
-> Offset
-> Cmd err [ParentId]
mk Maybe Name
n Maybe HyperdataAnnuaire
Nothing  ParentId
p Offset
u = NodeType
-> Maybe Name
-> Maybe DefaultHyperdata
-> ParentId
-> Offset
-> Cmd err [ParentId]
forall err.
HasDBid NodeType =>
NodeType
-> Maybe Name
-> Maybe DefaultHyperdata
-> ParentId
-> Offset
-> Cmd err [ParentId]
insertNode NodeType
NodeCorpus   Maybe Name
n Maybe DefaultHyperdata
forall a. Maybe a
Nothing ParentId
p Offset
u
    mk Maybe Name
n (Just HyperdataAnnuaire
h) ParentId
p Offset
u = NodeType
-> Maybe Name
-> Maybe DefaultHyperdata
-> ParentId
-> Offset
-> Cmd err [ParentId]
forall err.
HasDBid NodeType =>
NodeType
-> Maybe Name
-> Maybe DefaultHyperdata
-> ParentId
-> Offset
-> Cmd err [ParentId]
insertNode NodeType
NodeAnnuaire Maybe Name
n (DefaultHyperdata -> Maybe DefaultHyperdata
forall a. a -> Maybe a
Just (DefaultHyperdata -> Maybe DefaultHyperdata)
-> DefaultHyperdata -> Maybe DefaultHyperdata
forall a b. (a -> b) -> a -> b
$ HyperdataAnnuaire -> DefaultHyperdata
DefaultAnnuaire HyperdataAnnuaire
h) ParentId
p Offset
u


getOrMkList :: (HasNodeError err, HasDBid NodeType)
            => ParentId
            -> UserId
            -> Cmd err ListId
getOrMkList :: ParentId -> Offset -> Cmd err ParentId
getOrMkList ParentId
pId Offset
uId =
  m ParentId
-> (Node HyperdataList -> m ParentId)
-> Maybe (Node HyperdataList)
-> m ParentId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ParentId -> Offset -> m ParentId
forall err (m :: * -> *) env.
(MonadError err m, MonadReader env m, HasNodeError err,
 MonadBaseControl IO m, HasConnectionPool env, HasConfig env,
 HasMail env) =>
ParentId -> Offset -> m ParentId
mkList' ParentId
pId Offset
uId) (ParentId -> m ParentId
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParentId -> m ParentId)
-> (Node HyperdataList -> ParentId)
-> Node HyperdataList
-> m ParentId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting ParentId (Node HyperdataList) ParentId
-> Node HyperdataList -> ParentId
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ParentId (Node HyperdataList) ParentId
forall id hash_id typename user_id parent_id1 name date hyperdata
       id2.
Lens
  (NodePoly
     id hash_id typename user_id parent_id1 name date hyperdata)
  (NodePoly
     id2 hash_id typename user_id parent_id1 name date hyperdata)
  id
  id2
node_id) (Maybe (Node HyperdataList) -> m ParentId)
-> ([Node HyperdataList] -> Maybe (Node HyperdataList))
-> [Node HyperdataList]
-> m ParentId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node HyperdataList] -> Maybe (Node HyperdataList)
forall a. [a] -> Maybe a
headMay ([Node HyperdataList] -> m ParentId)
-> m [Node HyperdataList] -> m ParentId
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ParentId -> Cmd err [Node HyperdataList]
forall err.
HasDBid NodeType =>
ParentId -> Cmd err [Node HyperdataList]
getListsWithParentId ParentId
pId
    where
      mkList' :: ParentId -> Offset -> m ParentId
mkList' ParentId
pId' Offset
uId' = m ParentId
-> (ParentId -> m ParentId) -> Maybe ParentId -> m ParentId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (NodeError -> m ParentId
forall e (m :: * -> *) a.
(MonadError e m, HasNodeError e) =>
NodeError -> m a
nodeError NodeError
MkNode) ParentId -> m ParentId
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ParentId -> m ParentId)
-> ([ParentId] -> Maybe ParentId) -> [ParentId] -> m ParentId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ParentId] -> Maybe ParentId
forall a. [a] -> Maybe a
headMay ([ParentId] -> m ParentId) -> m [ParentId] -> m ParentId
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< NodeType -> ParentId -> Offset -> Cmd err [ParentId]
forall err.
HasDBid NodeType =>
NodeType -> ParentId -> Offset -> Cmd err [ParentId]
insertDefaultNode NodeType
NodeList ParentId
pId' Offset
uId'

-- | TODO remove defaultList
defaultList :: (HasNodeError err, HasDBid NodeType) => CorpusId -> Cmd err ListId
defaultList :: ParentId -> Cmd err ParentId
defaultList ParentId
cId =
  m ParentId
-> (Node HyperdataList -> m ParentId)
-> Maybe (Node HyperdataList)
-> m ParentId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (NodeError -> m ParentId
forall e (m :: * -> *) a.
(MonadError e m, HasNodeError e) =>
NodeError -> m a
nodeError NodeError
NoListFound) (ParentId -> m ParentId
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParentId -> m ParentId)
-> (Node HyperdataList -> ParentId)
-> Node HyperdataList
-> m ParentId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting ParentId (Node HyperdataList) ParentId
-> Node HyperdataList -> ParentId
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ParentId (Node HyperdataList) ParentId
forall id hash_id typename user_id parent_id1 name date hyperdata
       id2.
Lens
  (NodePoly
     id hash_id typename user_id parent_id1 name date hyperdata)
  (NodePoly
     id2 hash_id typename user_id parent_id1 name date hyperdata)
  id
  id2
node_id) (Maybe (Node HyperdataList) -> m ParentId)
-> ([Node HyperdataList] -> Maybe (Node HyperdataList))
-> [Node HyperdataList]
-> m ParentId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node HyperdataList] -> Maybe (Node HyperdataList)
forall a. [a] -> Maybe a
headMay ([Node HyperdataList] -> m ParentId)
-> m [Node HyperdataList] -> m ParentId
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ParentId -> Cmd err [Node HyperdataList]
forall err.
HasDBid NodeType =>
ParentId -> Cmd err [Node HyperdataList]
getListsWithParentId ParentId
cId

defaultListMaybe :: (HasNodeError err, HasDBid NodeType) => CorpusId -> Cmd err (Maybe NodeId)
defaultListMaybe :: ParentId -> Cmd err (Maybe ParentId)
defaultListMaybe ParentId
cId = [ParentId] -> Maybe ParentId
forall a. [a] -> Maybe a
headMay ([ParentId] -> Maybe ParentId)
-> ([Node HyperdataList] -> [ParentId])
-> [Node HyperdataList]
-> Maybe ParentId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Node HyperdataList -> ParentId)
-> [Node HyperdataList] -> [ParentId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Getting ParentId (Node HyperdataList) ParentId
-> Node HyperdataList -> ParentId
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ParentId (Node HyperdataList) ParentId
forall id hash_id typename user_id parent_id1 name date hyperdata
       id2.
Lens
  (NodePoly
     id hash_id typename user_id parent_id1 name date hyperdata)
  (NodePoly
     id2 hash_id typename user_id parent_id1 name date hyperdata)
  id
  id2
node_id ) ([Node HyperdataList] -> Maybe ParentId)
-> m [Node HyperdataList] -> m (Maybe ParentId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParentId -> Cmd err [Node HyperdataList]
forall err.
HasDBid NodeType =>
ParentId -> Cmd err [Node HyperdataList]
getListsWithParentId ParentId
cId

getListsWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataList]
getListsWithParentId :: ParentId -> Cmd err [Node HyperdataList]
getListsWithParentId ParentId
n = Query NodeRead -> Cmd err [Node HyperdataList]
forall fields haskells err.
Default FromFields fields haskells =>
Select fields -> Cmd err [haskells]
runOpaQuery (Query NodeRead -> Cmd err [Node HyperdataList])
-> Query NodeRead -> Cmd err [Node HyperdataList]
forall a b. (a -> b) -> a -> b
$ HasDBid NodeType => ParentId -> Maybe NodeType -> Query NodeRead
ParentId -> Maybe NodeType -> Query NodeRead
selectNodesWith' ParentId
n (NodeType -> Maybe NodeType
forall a. a -> Maybe a
Just NodeType
NodeList)