src/Gargantext/Database/NodeStory.hs

   1 {-# LANGUAGE Arrows #-}
   2 {-# LANGUAGE TemplateHaskell           #-}
   3
   4 module Gargantext.Database.NodeStory where
   5
   6 import Control.Arrow (returnA)
   7 import Control.Monad (foldM)
   8 import qualified Data.Map.Strict as Map
   9 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
  10 import Gargantext.API.Ngrams.Tools (getRepo)
  11 import Gargantext.Core (HasDBid)
  12 import Gargantext.Core.Mail.Types (HasMail)
  13 import Gargantext.Core.NodeStory (Archive(..), NodeStory(..), NodeListStory, NgramsState', NgramsStatePatch')
  14 import qualified Gargantext.Core.NodeStory as NS
  15 import Gargantext.Core.Types (NodeId(..), NodeType(..))
  16 import Gargantext.Database.Prelude (Cmd, mkCmd, runOpaQuery)
  17 import Gargantext.Database.Query.Table.Node (getNodesIdWithType, nodeExists)
  18 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
  19 import Gargantext.Prelude
  20 import Opaleye hiding (FromField)
  21 import Opaleye.Internal.Table (Table(..))
  22
  23
  24 data NodeStoryPoly a b = NodeStoryDB { node_id :: a
  25                                      , archive :: b }
  26   deriving (Eq)
  27
  28 type ArchiveQ = Archive NgramsState' NgramsStatePatch'
  29
  30 type NodeListStoryQ = NodeStoryPoly Int ArchiveQ
  31
  32 type NodeStoryWrite = NodeStoryPoly (Column SqlInt4) (Column SqlJsonb)
  33 type NodeStoryRead = NodeStoryPoly (Column SqlInt4) (Column SqlJsonb)
  34
  35 $(makeAdaptorAndInstance "pNodeStory" ''NodeStoryPoly)
  36
  37 nodeStoryTable :: Table NodeStoryRead NodeStoryWrite
  38 nodeStoryTable =
  39   Table "node_stories"
  40     ( pNodeStory NodeStoryDB { node_id = tableField "node_id"
  41                              , archive = tableField "archive" } )
  42
  43 nodeStorySelect :: Select NodeStoryRead
  44 nodeStorySelect = selectTable nodeStoryTable
  45
  46 getNodeStory :: NodeId -> Cmd err NodeListStory
  47 getNodeStory (NodeId nodeId) = do
  48   res <- runOpaQuery query
  49   pure $ NodeStory $ Map.fromListWith (<>) $ (\(NodeStoryDB nId a) -> (nId, a)) <$> res
  50   where
  51     query :: Select NodeStoryRead
  52     query = proc () -> do
  53       row@(NodeStoryDB node_id _) <- nodeStorySelect -< ()
  54       restrict -< node_id .== sqlInt4 nodeId
  55       returnA -< row
  56
  57 insertNodeArchive :: NodeId -> ArchiveQ -> Cmd err Int64
  58 insertNodeArchive (NodeId nId) a = mkCmd $ \c -> runInsert c insert
  59   where
  60     insert = Insert { iTable      = nodeStoryTable
  61                     , iRows       = [NodeStoryDB { node_id = sqlInt4 nId
  62                                                  , archive = sqlValueJSONB a }]
  63                     , iReturning  = rCount
  64                     , iOnConflict = Nothing }
  65
  66 updateNodeArchive :: NodeId -> ArchiveQ -> Cmd err Int64
  67 updateNodeArchive (NodeId nId) a = mkCmd $ \c -> runUpdate c update
  68   where
  69     update = Update { uTable      = nodeStoryTable
  70                     , uUpdateWith = updateEasy (\(NodeStoryDB { .. }) -> NodeStoryDB { archive = sqlValueJSONB a, .. })
  71                     , uWhere      = (\row -> node_id row .== sqlInt4 nId)
  72                     , uReturning  = rCount }
  73
  74 nodeStoryRemove :: NodeId -> Cmd err Int64
  75 nodeStoryRemove (NodeId nId) = mkCmd $ \c -> runDelete c delete
  76   where
  77     delete = Delete { dTable     = nodeStoryTable
  78                     , dWhere     = (\row -> node_id row .== sqlInt4 nId)
  79                     , dReturning = rCount }
  80
  81 upsertNodeArchive :: NodeId -> ArchiveQ -> Cmd err Int64
  82 upsertNodeArchive nId a = do
  83   (NodeStory m) <- getNodeStory nId
  84   case Map.lookup nId m of
  85     Nothing -> insertNodeArchive nId a
  86     Just _  -> updateNodeArchive nId a
  87
  88 -- | Returns a `NodeListStory`, updating the given one for given `NodeId`
  89 nodeStoryInc :: Maybe NodeListStory -> NodeId -> Cmd err NodeListStory
  90 nodeStoryInc Nothing nId = getNodeStory nId
  91 nodeStoryInc (Just ns@(NodeStory nls)) nId = do
  92   case Map.lookup nId nls of
  93     Nothing -> do
  94       (NodeStory nls') <- getNodeStory nId
  95       pure $ NodeStory $ Map.union nls nls'
  96     Just _ -> pure ns
  97
  98 nodeStoryIncs :: Maybe NodeListStory -> [NodeId] -> Cmd err NodeListStory
  99 nodeStoryIncs Nothing [] = panic "nodeStoryIncs: Empty"
 100 nodeStoryIncs (Just nls) ns = foldM (\m n -> nodeStoryInc (Just m) n) nls ns
 101 nodeStoryIncs Nothing (ni:ns) = do
 102   m <- getNodeStory ni
 103   nodeStoryIncs (Just m) ns
 104
 105 nodeStoryDec :: NodeListStory -> NodeId -> Cmd err NodeListStory
 106 nodeStoryDec ns@(NodeStory nls) ni = do
 107   case Map.lookup ni nls of
 108     Nothing -> do
 109       _ <- nodeStoryRemove ni
 110       pure ns
 111     Just _ -> do
 112       let ns' = Map.filterWithKey (\k _v -> k /= ni) nls
 113       _ <- nodeStoryRemove ni
 114       pure $ NodeStory ns'
 115
 116 -- TODO
 117 -- readNodeStoryEnv
 118
 119 -- getRepo from G.A.N.Tools
 120
 121 migrateFromDir :: (HasMail env, HasNodeError err, NS.HasNodeStory env err m, HasDBid NodeType)
 122                => m ()
 123 migrateFromDir = do
 124   listIds <- getNodesIdWithType NodeList
 125   (NodeStory nls) <- getRepo listIds
 126   _ <- mapM (\(nId, a) -> do
 127                 n <- nodeExists nId
 128                 case n of
 129                   False -> pure 0
 130                   True  -> upsertNodeArchive nId a
 131             ) $ Map.toList nls
 132   _ <- nodeStoryIncs (Just $ NodeStory nls) listIds
 133   pure ()