src/Gargantext/Database/Query/Tree/Root.hs

   1 {-|
   2 Module      : Gargantext.Database.Root
   3 Description : Main requests to get root of users
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9 -}
  10
  11 {-# LANGUAGE Arrows #-}
  12
  13 module Gargantext.Database.Query.Tree.Root
  14   where
  15
  16 import Control.Arrow (returnA)
  17 import Data.Either (Either, fromLeft, fromRight)
  18 import Gargantext.Core.Types.Individu (User(..))
  19 import Gargantext.Core.Types.Main (CorpusName)
  20 import Gargantext.Database.Action.Node
  21 import Gargantext.Database.Action.User (getUserId, getUsername)
  22 import Gargantext.Database.Admin.Config (nodeTypeId, userMaster)
  23 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser)
  24 import Gargantext.Database.Admin.Types.Node
  25 import Gargantext.Database.Prelude (Cmd, runOpaQuery)
  26 import Gargantext.Database.Query.Table.Node
  27 import Gargantext.Database.Query.Table.Node.Error
  28 import Gargantext.Database.Query.Table.User (queryUserTable, UserPoly(..))
  29 import Gargantext.Database.Schema.Node (NodePoly(..), NodeRead)
  30 import Gargantext.Database.Schema.Node (queryNodeTable)
  31 import Gargantext.Prelude
  32 import Opaleye (restrict, (.==), Query)
  33 import Opaleye.PGTypes (pgStrictText, pgInt4)
  34
  35
  36 getRootId :: (HasNodeError err) => User -> Cmd err NodeId
  37 getRootId u = do
  38   maybeRoot <- head <$> getRoot u
  39   case maybeRoot of
  40     Nothing -> nodeError $ NodeError "[G.D.Q.T.R.getRootId] No root id"
  41     Just  r -> pure (_node_id r)
  42
  43 getRoot :: User -> Cmd err [Node HyperdataUser]
  44 getRoot = runOpaQuery . selectRoot
  45
  46 getOrMkRoot :: (HasNodeError err)
  47             => User
  48             -> Cmd err (UserId, RootId)
  49 getOrMkRoot user = do
  50   userId <- getUserId user
  51
  52   rootId' <- map _node_id <$> getRoot user
  53
  54   rootId'' <- case rootId' of
  55         []  -> mkRoot user
  56         n   -> case length n >= 2 of
  57             True  -> nodeError ManyNodeUsers
  58             False -> pure rootId'
  59
  60   rootId <- maybe (nodeError NoRootFound) pure (head rootId'')
  61   pure (userId, rootId)
  62
  63
  64 getOrMk_RootWithCorpus :: (HasNodeError err, MkCorpus a)
  65                       => User
  66                       -> Either CorpusName [CorpusId]
  67                       -> Maybe a
  68                       -> Cmd err (UserId, RootId, CorpusId)
  69 getOrMk_RootWithCorpus user cName c = do
  70   (userId, rootId) <- getOrMkRoot user
  71   corpusId'' <- if user == UserName userMaster
  72                   then do
  73                     ns <- getCorporaWithParentId rootId
  74                     pure $ map _node_id ns
  75                   else
  76                     pure $ fromRight [] cName
  77
  78   corpusId' <- if corpusId'' /= []
  79                   then pure corpusId''
  80                   else do
  81                     c' <- mk (Just $ fromLeft "Default" cName) c rootId userId
  82                     _tId <- case head c' of
  83                               Nothing  -> nodeError $ NodeError "[G.D.Q.T.Root.getOrMk...] mk Corpus failed"
  84                               Just c'' -> insertDefaultNode NodeTexts c'' userId
  85                     pure c'
  86
  87   corpusId <- maybe (nodeError NoCorpusFound) pure (head corpusId')
  88   pure (userId, rootId, corpusId)
  89
  90
  91 mkRoot :: HasNodeError err
  92        => User
  93        -> Cmd err [RootId]
  94 mkRoot user = do
  95
  96   -- TODO
  97   -- udb <- getUserDb user
  98   -- let uid = user_id udb
  99   uid <- getUserId user
 100
 101   -- TODO ? Which name for user Node ?
 102   una <- getUsername user
 103
 104   case uid > 0 of
 105      False -> nodeError NegativeId
 106      True  -> do
 107        rs <- mkNodeWithParent NodeUser Nothing uid una
 108        _ <- case rs of
 109          [r] -> do
 110            _ <- insertNode NodeFolderPrivate Nothing Nothing r uid
 111            _ <- insertNode NodeFolderShared Nothing Nothing r uid
 112            _ <- insertNode NodeFolderPublic Nothing Nothing r uid
 113            pure rs
 114          _   -> pure rs
 115        pure rs
 116
 117 selectRoot :: User -> Query NodeRead
 118 selectRoot (UserName username) = proc () -> do
 119     row   <- queryNodeTable -< ()
 120     users <- queryUserTable -< ()
 121     restrict -< _node_typename row   .== (pgInt4 $ nodeTypeId NodeUser)
 122     restrict -< user_username  users .== (pgStrictText username)
 123     restrict -< _node_userId   row   .== (user_id users)
 124     returnA  -< row
 125
 126 selectRoot (UserDBId uid) = proc () -> do
 127     row   <- queryNodeTable -< ()
 128     restrict -< _node_typename row   .== (pgInt4 $ nodeTypeId NodeUser)
 129     restrict -< _node_userId   row   .== (pgInt4 uid)
 130     returnA  -< row
 131
 132 selectRoot (RootId nid) =
 133  proc () -> do
 134     row   <- queryNodeTable -< ()
 135     restrict -< _node_typename row   .== (pgInt4 $ nodeTypeId NodeUser)
 136     restrict -< _node_id   row   .== (pgNodeId nid)
 137     returnA  -< row
 138 selectRoot UserPublic = panic {-nodeError $ NodeError-}  "[G.D.Q.T.Root.selectRoot] No root for Public"