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