[REFACT] SocialList (WIP)
[gargantext.git] / src / Gargantext / Database / Query / Table / Node.hs
index be92c6e82471886d75766c134163becdc5bd6084..9648ef8685041d18ad52f81abb961967a67426d1 100644 (file)
@@ -15,6 +15,7 @@ Portability : POSIX
 {-# LANGUAGE Arrows                 #-}
 {-# LANGUAGE ConstraintKinds        #-}
 {-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE TemplateHaskell        #-}
 {-# LANGUAGE TypeFamilies           #-}
 
@@ -24,22 +25,22 @@ module Gargantext.Database.Query.Table.Node
 import Control.Arrow (returnA)
 import Control.Lens (set, view)
 import Data.Aeson
-import Data.Maybe (Maybe(..))
+import Data.Maybe (fromMaybe)
 import Data.Text (Text)
-import GHC.Int (Int64)
+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.Types
-import Gargantext.Database.Query.Filter (limit', offset')
 import Gargantext.Database.Admin.Config (nodeTypeId)
-import Gargantext.Database.Query.Table.Node.Error
-import Gargantext.Database.Admin.Types.Node (NodeType(..), defaultCorpus, Hyperdata, HyperData(..))
+import Gargantext.Database.Admin.Types.Hyperdata
+import Gargantext.Database.Admin.Types.Hyperdata.Default
 import Gargantext.Database.Prelude
-import Gargantext.Database.Query.Table.Node.Contact (HyperdataContact(..), arbitraryHyperdataContact)
+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)
-import Gargantext.Viz.Graph (HyperdataGraph(..))
-import Opaleye hiding (FromField)
-import Opaleye.Internal.QueryArr (Query)
-import Prelude hiding (null, id, map, sum)
 
 
 queryNodeSearchTable :: Query NodeSearchRead
@@ -69,7 +70,7 @@ selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
 selectNodesWith' :: ParentId -> Maybe NodeType -> Query NodeRead
 selectNodesWith' parentId maybeNodeType = proc () -> do
     node <- (proc () -> do
-      row@(Node _ typeId _ parentId' _ _ _) <- queryNodeTable -< ()
+      row@(Node _ typeId _ parentId' _ _ _) <- queryNodeTable -< ()
       restrict -< parentId' .== (pgNodeId parentId)
 
       let typeId' = maybe 0 nodeTypeId maybeNodeType
@@ -83,12 +84,12 @@ selectNodesWith' parentId maybeNodeType = proc () -> do
 deleteNode :: NodeId -> Cmd err Int
 deleteNode n = mkCmd $ \conn ->
   fromIntegral <$> runDelete conn nodeTable
-                 (\(Node n_id _ _ _ _ _ _) -> n_id .== pgNodeId n)
+                 (\(Node n_id _ _ _ _ _ _ _) -> n_id .== pgNodeId n)
 
 deleteNodes :: [NodeId] -> Cmd err Int
 deleteNodes ns = mkCmd $ \conn ->
   fromIntegral <$> runDelete conn nodeTable
-                   (\(Node n_id _ _ _ _ _ _) -> in_ ((map pgNodeId ns)) n_id)
+                   (\(Node n_id _ _ _ _ _ _ _) -> in_ ((map pgNodeId ns)) n_id)
 
 -- TODO: NodeType should match with `a'
 getNodesWith :: JSONB a => NodeId -> proxy a -> Maybe NodeType
@@ -98,7 +99,7 @@ getNodesWith parentId _ nodeType maybeOffset maybeLimit =
 
 -- TODO: Why is the second parameter ignored?
 -- TODO: Why not use getNodesWith?
-getNodesWithParentId :: (Hyperdata a, QueryRunnerColumnDefault PGJsonb a)
+getNodesWithParentId :: (Hyperdata a, JSONB a)
                      => Maybe NodeId
                      -> Cmd err [Node a]
 getNodesWithParentId n = runOpaQuery $ selectNodesWithParentID n'
@@ -107,6 +108,31 @@ getNodesWithParentId n = runOpaQuery $ selectNodesWithParentID n'
       Just n'' -> n''
       Nothing  -> 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 :: NodeId
+                         -> NodeType
+                         -> Cmd err (Maybe NodeId)
+getClosestParentIdByType nId nType = do
+  result <- runPGSQuery query (nId, 0 :: Int)
+  case result of
+    [DPS.Only parentId, DPS.Only pTypename] -> do
+      if nodeTypeId nType == pTypename then
+        pure $ Just $ NodeId parentId
+      else
+        getClosestParentIdByType (NodeId parentId) nType
+    _ -> pure Nothing
+  where
+    query :: DPS.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 = ?;
+    |]
+
 ------------------------------------------------------------------------
 getDocumentsV3WithParentId :: NodeId -> Cmd err [Node HyperdataDocumentV3]
 getDocumentsV3WithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
@@ -115,8 +141,8 @@ getDocumentsV3WithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocume
 getDocumentsWithParentId :: NodeId -> Cmd err [Node HyperdataDocument]
 getDocumentsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
 
-getListsModelWithParentId :: NodeId -> Cmd err [Node HyperdataListModel]
-getListsModelWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeListModel)
+getListsModelWithParentId :: NodeId -> Cmd err [Node HyperdataModel]
+getListsModelWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeModel)
 
 getCorporaWithParentId :: NodeId -> Cmd err [Node HyperdataCorpus]
 getCorporaWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeCorpus)
@@ -124,17 +150,35 @@ getCorporaWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeCorpus)
 ------------------------------------------------------------------------
 selectNodesWithParentID :: NodeId -> Query NodeRead
 selectNodesWithParentID n = proc () -> do
-    row@(Node _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
+    row@(Node _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
     restrict -< parent_id .== (pgNodeId n)
     returnA -< row
 
-selectNodesWithType :: Column PGInt4 -> Query NodeRead
-selectNodesWithType type_id = proc () -> do
-    row@(Node _ tn _ _ _ _ _) <- queryNodeTable -< ()
-    restrict -< tn .== type_id
-    returnA -< row
 
-type JSONB = QueryRunnerColumnDefault PGJsonb
+------------------------------------------------------------------------
+-- | Example of use:
+-- runCmdReplEasy  (getNodesWithType NodeList (Proxy :: Proxy HyperdataList))
+getNodesWithType :: (HasNodeError err, JSONB a) => NodeType -> proxy a -> Cmd err [Node a]
+getNodesWithType nt _ = runOpaQuery $ selectNodesWithType nt
+  where
+    selectNodesWithType :: NodeType -> Query NodeRead
+    selectNodesWithType nt = proc () -> do
+        row@(Node _ _ tn _ _ _ _ _) <- queryNodeTable -< ()
+        restrict -< tn .== (pgInt4 $ nodeTypeId nt)
+        returnA -< row
+
+getNodesIdWithType :: HasNodeError err => NodeType -> Cmd err [NodeId]
+getNodesIdWithType nt = do
+  ns <- runOpaQuery $ selectNodesIdWithType nt
+  pure (map NodeId ns)
+
+selectNodesIdWithType :: NodeType -> Query (Column PGInt4)
+selectNodesIdWithType nt = proc () -> do
+    row@(Node _ _ tn _ _ _ _ _) <- queryNodeTable -< ()
+    restrict -< tn .== (pgInt4 $ nodeTypeId nt)
+    returnA -< _node_id row
+
+------------------------------------------------------------------------
 
 
 getNode :: HasNodeError err => NodeId -> Cmd err (Node Value)
@@ -152,140 +196,22 @@ getNodeWith nId _ = do
     Nothing -> nodeError (DoesNotExist nId)
     Just  r -> pure r
 
-------------------------------------------------------------------------
-nodeContactW :: Maybe Name -> Maybe HyperdataContact
-             -> AnnuaireId -> UserId -> NodeWrite
-nodeContactW maybeName maybeContact aId = 
-  node NodeContact name contact (Just aId)
-    where
-      name    = maybe "Contact" identity maybeName
-      contact = maybe arbitraryHyperdataContact identity maybeContact
-------------------------------------------------------------------------
-defaultFolder :: HyperdataCorpus
-defaultFolder = defaultCorpus
-
-nodeFolderW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite
-nodeFolderW maybeName maybeFolder pid = node NodeFolder name folder (Just pid)
-  where
-    name   = maybe "Folder" identity maybeName
-    folder = maybe defaultFolder identity maybeFolder
-------------------------------------------------------------------------
-nodeCorpusW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite
-nodeCorpusW maybeName maybeCorpus pId = node NodeCorpus name corpus (Just pId)
-  where
-    name   = maybe "Corpus" identity maybeName
-    corpus = maybe defaultCorpus identity maybeCorpus
-                   --------------------------
-defaultDocument :: HyperdataDocument
-defaultDocument = hyperdataDocument
-
-nodeDocumentW :: Maybe Name -> Maybe HyperdataDocument -> CorpusId -> UserId -> NodeWrite
-nodeDocumentW maybeName maybeDocument cId = node NodeDocument name doc (Just cId)
-  where
-    name = maybe "Document" identity maybeName
-    doc  = maybe defaultDocument identity maybeDocument
-------------------------------------------------------------------------
-defaultAnnuaire :: HyperdataAnnuaire
-defaultAnnuaire = HyperdataAnnuaire (Just "Title") (Just "Description")
-
-nodeAnnuaireW :: Maybe Name -> Maybe HyperdataAnnuaire -> ParentId -> UserId -> NodeWrite
-nodeAnnuaireW maybeName maybeAnnuaire pId = node NodeAnnuaire name annuaire (Just pId)
-  where
-    name     = maybe "Annuaire" identity maybeName
-    annuaire = maybe defaultAnnuaire identity maybeAnnuaire
 
 ------------------------------------------------------------------------
+-- | Sugar to insert Node with NodeType in Database
+insertDefaultNode :: NodeType -> ParentId -> UserId -> Cmd err [NodeId]
+insertDefaultNode nt p u = insertNode nt Nothing Nothing p u
 
-{-
-class IsNodeDb a where
-  data Node'' a :: *
-  data Hyper  a :: *
-
-instance IsNodeDb NodeType where
-  data 
-
-instance HasHyperdata NodeType where
-  data Hyper NodeType = HyperList   HyperdataList
-                      | HyperCorpus HyperdataCorpus
-
-  hasHyperdata nt = case nt of
-    NodeList   -> HyperList $ HyperdataList (Just "list")
-
-  unHyper h = case h of
-    HyperList h' -> h'
-
---}
-
-
-class HasDefault a where
-  hasDefaultData :: a -> HyperData
-  hasDefaultName :: a -> Text
-
-instance HasDefault NodeType where
-  hasDefaultData nt = case nt of
-      NodeTexts    -> HyperdataTexts (Just "Preferences")
-      NodeList     -> HyperdataList' (Just "Preferences")
-      NodeListCooc -> HyperdataList' (Just "Preferences")
-      _         -> undefined
-      --NodeAnnuaire -> HyperdataAnnuaire (Just "Title") (Just "Description")
-
-  hasDefaultName nt = case nt of
-      NodeTexts -> "Texts"
-      NodeList  -> "Lists"
-      NodeListCooc -> "Cooc"
-      _         -> undefined
+insertNode :: NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> Cmd err [NodeId]
+insertNode nt n h p u = insertNodesR [nodeW nt n h p u]
 
-------------------------------------------------------------------------
-nodeDefault :: NodeType -> ParentId -> UserId -> NodeWrite
-nodeDefault nt parent = node nt name hyper (Just parent)
-  where
-    name  = (hasDefaultName nt)
-    hyper = (hasDefaultData nt)
-
-------------------------------------------------------------------------
-arbitraryListModel :: HyperdataListModel
-arbitraryListModel = HyperdataListModel (400,500) "data/models/test.model" (Just 0.83)
-
-mkListModelNode :: HasNodeError err => ParentId -> UserId -> Cmd err [NodeId]
-mkListModelNode p u = insertNodesR [nodeListModelW Nothing Nothing p u]
-
-nodeListModelW :: Maybe Name -> Maybe HyperdataListModel -> ParentId -> UserId -> NodeWrite
-nodeListModelW maybeName maybeListModel pId = node NodeListModel name list (Just pId)
+nodeW :: NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> NodeWrite
+nodeW nt n h p u = node nt n' h' (Just p) u
   where
-    name = maybe "List Model" identity maybeName
-    list = maybe arbitraryListModel identity maybeListModel
+    n' = fromMaybe (defaultName nt) n
+    h' = maybe     (defaultHyperdata nt) identity h
 
 ------------------------------------------------------------------------
-arbitraryGraph :: HyperdataGraph
-arbitraryGraph = HyperdataGraph Nothing
-
-nodeGraphW :: Maybe Name -> Maybe HyperdataGraph -> ParentId -> UserId -> NodeWrite
-nodeGraphW maybeName maybeGraph pId = node NodeGraph name graph (Just pId)
-  where
-    name = maybe "Graph" identity maybeName
-    graph = maybe arbitraryGraph identity maybeGraph
-
-mkGraph :: ParentId -> UserId -> Cmd err [GraphId]
-mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
-
-insertGraph :: ParentId -> UserId -> HyperdataGraph -> Cmd err [GraphId]
-insertGraph p u h = insertNodesR [nodeGraphW Nothing (Just h) p u]
-
-------------------------------------------------------------------------
-arbitraryPhylo :: HyperdataPhylo
-arbitraryPhylo = HyperdataPhylo Nothing Nothing
-
-nodePhyloW :: Maybe Name -> Maybe HyperdataPhylo -> ParentId -> UserId -> NodeWrite
-nodePhyloW maybeName maybePhylo pId = node NodePhylo name graph (Just pId)
-  where
-    name = maybe "Phylo" identity maybeName
-    graph = maybe arbitraryPhylo identity maybePhylo
-
-------------------------------------------------------------------------
-arbitraryDashboard :: HyperdataDashboard
-arbitraryDashboard = HyperdataDashboard (Just "Preferences") []
-------------------------------------------------------------------------
-
 node :: (ToJSON a, Hyperdata a)
      => NodeType
      -> Name
@@ -294,7 +220,7 @@ node :: (ToJSON a, Hyperdata a)
      -> UserId
      -> NodeWrite
 node nodeType name hyperData parentId userId =
-  Node Nothing
+  Node Nothing Nothing
        (pgInt4 typeId)
        (pgInt4 userId)
        (pgNodeId <$> parentId)
@@ -308,9 +234,26 @@ node nodeType name hyperData parentId userId =
 insertNodes :: [NodeWrite] -> Cmd err Int64
 insertNodes ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns rCount 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)
+                        (pgInt4 $ nodeTypeId   t)
+                        (pgInt4                u)
+                        (pgNodeId          <$> p)
+                        (pgStrictText          n)
+                        (pgUTCTime         <$> d)
+                        (pgJSONB $ cs $ encode h)
+              ) ns
+-}
+
 insertNodesR :: [NodeWrite] -> Cmd err [NodeId]
 insertNodesR ns = mkCmd $ \conn ->
-  runInsert_ conn (Insert nodeTable ns (rReturning (\(Node i _ _ _ _ _ _) -> i)) Nothing)
+  runInsert_ conn (Insert nodeTable ns (rReturning (\(Node i _ _ _ _ _ _ _) -> i)) Nothing)
 
 insertNodesWithParent :: Maybe ParentId -> [NodeWrite] -> Cmd err Int64
 insertNodesWithParent pid ns = insertNodes (set node_parentId (pgNodeId <$> pid) <$> ns)
@@ -318,25 +261,12 @@ insertNodesWithParent pid ns = insertNodes (set node_parentId (pgNodeId <$> pid)
 insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [NodeId]
 insertNodesWithParentR pid ns = insertNodesR (set node_parentId (pgNodeId <$> pid) <$> ns)
 ------------------------------------------------------------------------
--- TODO Hierachy of Nodes
--- post and get same types Node' and update if changes
-
-{- TODO semantic to achieve
-post c uid pid [ Node' NodeCorpus "name" "{}" []
-               , Node' NodeFolder "name" "{}" [Node' NodeCorpus "test 2" "" [ Node' NodeDocument "title" "metaData" []
-                                                                    , Node' NodeDocument "title" "jsonData" []
-                                                                    ]
-                                          ]
-               ]
--}
-------------------------------------------------------------------------
-
 -- TODO
 -- currently this function removes the child relation
 -- needs a Temporary type between Node' and NodeWriteT
 
 node2table :: UserId -> Maybe ParentId -> Node' -> NodeWrite
-node2table uid pid (Node' nt txt v []) = Node Nothing (pgInt4 $ nodeTypeId nt) (pgInt4 uid) (fmap pgNodeId pid) (pgStrictText txt) Nothing (pgStrictJSONB $ cs $ encode v)
+node2table uid pid (Node' nt txt v []) = Node Nothing Nothing (pgInt4 $ nodeTypeId nt) (pgInt4 uid) (fmap pgNodeId pid) (pgStrictText txt) Nothing (pgStrictJSONB $ cs $ encode v)
 node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
 
 
@@ -354,41 +284,6 @@ mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
 mkNodeR ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns (rReturning _node_id) Nothing
 
 ------------------------------------------------------------------------
-
-{-
-data NewNode = NewNode { _newNodeId :: NodeId
-                       , _newNodeChildren :: [NodeId] }
-
-postNode :: HasNodeError err
-         => UserId
-         -> Maybe ParentId
-         -> Node'
-         -> Cmd err NewNode
-
-postNode uid pid (Node' nt txt v []) = do
-  pids <- mkNodeR [node2table uid pid (Node' nt txt v [])]
-  case pids of
-    [pid'] -> pure $ NewNode pid' []
-    _ -> nodeError ManyParents
-
-postNode uid pid (Node' NodeCorpus txt v ns) = do
-  NewNode pid' _ <- postNode uid pid (Node' NodeCorpus txt v [])
-  pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
-  pure $ NewNode pid' pids
-
-postNode uid pid (Node' NodeAnnuaire txt v ns) = do
-  NewNode pid' _ <- postNode uid pid (Node' NodeAnnuaire txt v [])
-  pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
-  pure $ NewNode pid' pids
-
-postNode uid pid (Node' NodeDashboard txt v ns) = do
-  NewNode pid' _ <- postNode uid pid (Node' NodeDashboard txt v [])
-  pids  <- mkNodeR (concat $ map (\n -> [childWith uid pid' n]) ns)
-  pure $ NewNode pid' pids
-
-postNode _ _ (Node' _ _ _ _) = nodeError NotImplYet
--}
-
 childWith :: UserId -> ParentId -> Node' -> NodeWrite
 childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
 childWith uId pId (Node' NodeContact  txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
@@ -407,12 +302,14 @@ class MkCorpus a
 
 instance MkCorpus HyperdataCorpus
   where
-    mk n h p u = insertNodesR [nodeCorpusW n h p u]
+    mk n Nothing  p u = insertNode NodeCorpus n Nothing p u
+    mk n (Just h) p u = insertNode NodeCorpus n (Just $ DefaultCorpus h) p u
 
 
 instance MkCorpus HyperdataAnnuaire
   where
-    mk n h p u = insertNodesR [nodeAnnuaireW n h p u]
+    mk n Nothing  p u = insertNode NodeCorpus   n Nothing p u
+    mk n (Just h) p u = insertNode NodeAnnuaire n (Just $ DefaultAnnuaire h) p u
 
 
 getOrMkList :: HasNodeError err
@@ -422,39 +319,14 @@ getOrMkList :: HasNodeError err
 getOrMkList pId uId =
   maybe (mkList' pId uId) (pure . view node_id) . headMay =<< getListsWithParentId pId
     where
-      mkList' pId uId = maybe (nodeError MkNode) pure . headMay =<< mkNode NodeList pId uId
-
-mkList :: HasNodeError err
-            => ParentId
-            -> UserId
-            -> Cmd err [ListId]
-mkList pId uId = mkNode NodeList pId uId
+      mkList' pId uId = maybe (nodeError MkNode) pure . headMay =<< insertDefaultNode NodeList pId uId
 
 -- | TODO remove defaultList
 defaultList :: HasNodeError err => CorpusId -> Cmd err ListId
 defaultList cId =
   maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
 
-mkNode :: NodeType -> ParentId -> UserId -> Cmd err [NodeId]
-mkNode nt p u = insertNodesR [nodeDefault nt p u]
-
-mkDashboard :: ParentId -> UserId -> Cmd err [NodeId]
-mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
-  where
-    nodeDashboardW :: Maybe Name -> Maybe HyperdataDashboard -> ParentId -> UserId -> NodeWrite
-    nodeDashboardW maybeName maybeDashboard pId = node NodeDashboard name dashboard (Just pId)
-      where
-        name = maybe "Board" identity maybeName
-        dashboard = maybe arbitraryDashboard identity maybeDashboard
-
-
-mkPhylo :: ParentId -> UserId -> Cmd err [NodeId]
-mkPhylo p u = insertNodesR [nodePhyloW Nothing Nothing p u]
 
 getListsWithParentId :: NodeId -> Cmd err [Node HyperdataList]
 getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
 
--- import Gargantext.Database.Node.UpdateOpaleye (updateHyperdata)
--- updateNodeUser_fake :: NodeId -> Cmd err Int64
--- updateNodeUser_fake n = updateHyperdata n fake_HyperdataUser
-