install: proposal
[gargantext.git] / src / Gargantext / Database / Node.hs
index 2f70e0c8785836f3c3ca1beca127e2407e27f53c..fa44f50c9ec35599183095aae8022580aea54dd3 100644 (file)
@@ -32,7 +32,6 @@ import Database.PostgreSQL.Simple.FromField ( Conversion
                                             , returnError
                                             )
 import Prelude hiding (null, id, map, sum)
-import           Data.Time.Segment (jour, timesAfter, Granularity(D))
 
 import Gargantext.Core.Types
 import Gargantext.Core.Types.Node (NodeType)
@@ -45,7 +44,7 @@ import Control.Arrow (returnA)
 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
 import Data.Aeson
 import Data.Maybe (Maybe, fromMaybe)
-import Data.Text (Text)
+import Data.Text (Text, pack)
 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
 import Data.Typeable (Typeable)
 
@@ -55,7 +54,7 @@ import Data.ByteString (ByteString)
 
 import Database.PostgreSQL.Simple (Connection)
 import Opaleye hiding (FromField)
-import Opaleye.Internal.QueryArr (Query(..))
+import Opaleye.Internal.QueryArr (Query)
 import qualified Data.Profunctor.Product as PP
 -- | Types for Node Database Management
 data PGTSVector
@@ -189,7 +188,7 @@ deleteNodes conn ns = fromIntegral <$> runDelete conn nodeTable
 
 
 getNodesWith :: Connection   -> Int         -> Maybe NodeType 
-             -> Maybe Offset -> Maybe Limit -> IO [Node HyperdataDocument]
+             -> Maybe Offset -> Maybe Limit -> IO [Node Value]
 getNodesWith conn parentId nodeType maybeOffset maybeLimit = 
     runQuery conn $ selectNodesWith 
                   parentId nodeType maybeOffset maybeLimit
@@ -197,7 +196,7 @@ getNodesWith conn parentId nodeType maybeOffset maybeLimit =
 
 -- NP check type
 getNodesWithParentId :: Connection -> Int 
-                     -> Maybe Text -> IO [Node HyperdataDocument]
+                     -> Maybe Text -> IO [Node Value]
 getNodesWithParentId conn n _ = runQuery conn $ selectNodesWithParentID n
 
 getNodesWithParentId' :: Connection -> Int 
@@ -227,7 +226,7 @@ getNode' c id = do
   fromMaybe (error "TODO: 404") . headMay <$> runQuery c (limit 1 $ selectNode (pgInt4 id))
 
 
-getNode :: Connection -> Int -> IO (Node HyperdataDocument)
+getNode :: Connection -> Int -> IO (Node Value)
 getNode conn id = do
     fromMaybe (error "TODO: 404") . headMay <$> runQuery conn (limit 1 $ selectNode (pgInt4 id))
 
@@ -251,6 +250,14 @@ node userId parentId nodeType name nodeData = Node Nothing typeId userId parentI
     typeId = nodeTypeId nodeType
     byteData = DB.pack $ DBL.unpack $ encode nodeData
 
+
+
+node2write :: (Functor f2, Functor f1) =>
+              Int
+              -> NodePoly (f1 Int) Int Int parentId Text (f2 UTCTime) ByteString
+              -> (f1 (Column PGInt4), Column PGInt4, Column PGInt4,
+                  Column PGInt4, Column PGText, f2 (Column PGTimestamptz),
+                  Column PGJsonb)
 node2write pid (Node id tn ud _ nm dt hp) = ((pgInt4    <$> id)
                                          ,(pgInt4        tn)
                                          ,(pgInt4        ud)
@@ -288,7 +295,7 @@ post c uid pid [ Node' Corpus "name" "{}" []
 node2table :: UserId -> ParentId -> Node' -> [NodeWriteT]
 node2table uid pid (Node' nt txt v []) = [( Nothing, (pgInt4$ nodeTypeId nt), (pgInt4 uid), (pgInt4 pid)
                                          , pgStrictText txt, Nothing, pgStrictJSONB $ DB.pack $ DBL.unpack $ encode v)]
-node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
+node2table _ _ (Node' _ _ _ _) = panic $ pack "node2table: should not happen, Tree insert not implemented yet"
 
 
 data Node' = Node' { _n_type :: NodeType
@@ -312,13 +319,24 @@ mkNode' conn ns = runInsertMany conn nodeTable' ns
 mkNodeR' :: Connection -> [NodeWriteT] -> IO [Int]
 mkNodeR' conn ns = runInsertManyReturning conn nodeTable' ns (\(i,_,_,_,_,_,_) -> i)
 
+-- | postNode
 postNode :: Connection -> UserId -> ParentId -> Node' -> IO [Int]
 postNode c uid pid (Node' nt txt v []) = mkNodeR' c (node2table uid pid (Node' nt txt v []))
-postNode c uid pid (Node' Corpus txt v ns) = do
-  [pid']  <- postNode c uid pid (Node' Corpus txt v [])
-  pids    <- mkNodeR' c $ concat $ (map (\(Node' Document txt v _) -> node2table uid pid' $ Node' Document txt v []) ns)
+
+postNode c uid pid (Node' NodeCorpus txt v ns) = do
+  [pid']  <- postNode c uid pid (Node' NodeCorpus txt v [])
+  pids    <- mkNodeR' c $ concat $ map (\n -> childWith uid pid' n) ns
+  pure (pids)
+
+postNode c uid pid (Node' Annuaire txt v ns) = do
+  [pid']  <- postNode c uid pid (Node' Annuaire txt v [])
+  pids    <- mkNodeR' c $ concat $ map (\n -> childWith uid pid' n) ns
   pure (pids)
-postNode c uid pid (Node' _ _ _ _) = panic "postNode for this type not implemented yet"
+postNode _ _ _ (Node' _ _ _ _) = panic $ pack "postNode for this type not implemented yet"
 
 
+childWith :: UserId -> ParentId -> Node' -> [NodeWriteT]
+childWith uId pId (Node' Document txt v []) = node2table uId pId (Node' Document txt v [])
+childWith uId pId (Node' UserPage txt v []) = node2table uId pId (Node' UserPage txt v [])
+childWith _   _   (Node' _        _   _ _) = panic $ pack "This NodeType can not be a child"