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.Admin.Types.Node (Node, NodeType(NodeUser), pgNodeId)
  37 import Gargantext.Database.Prelude (Cmd, runOpaQuery)
  38 import Gargantext.Prelude
  39 import Opaleye (restrict, (.==), Query)
  40 import Opaleye.PGTypes (pgStrictText, pgInt4)
  41
  42
  43 getRootId :: User -> Cmd err NodeId
  44 getRootId u = do
  45   maybeRoot <- head <$> getRoot u
  46   case maybeRoot of
  47     Nothing -> panic "no root id"
  48     Just  r -> pure (_node_id r)
  49
  50 getRoot :: User -> Cmd err [Node HyperdataUser]
  51 getRoot = runOpaQuery . selectRoot
  52
  53
  54 getOrMkRoot :: (HasNodeError err)
  55             => User
  56             -> Cmd err (UserId, RootId)
  57 getOrMkRoot user = do
  58   userId <- getUserId user
  59
  60   rootId' <- map _node_id <$> getRoot user
  61
  62   rootId'' <- case rootId' of
  63         []  -> mkRoot user
  64         n   -> case length n >= 2 of
  65             True  -> nodeError ManyNodeUsers
  66             False -> pure rootId'
  67
  68   rootId <- maybe (nodeError NoRootFound) pure (head rootId'')
  69   pure (userId, rootId)
  70
  71
  72 getOrMk_RootWithCorpus :: (HasNodeError err, MkCorpus a)
  73                       => User
  74                       -> Either CorpusName [CorpusId]
  75                       -> Maybe a
  76                       -> Cmd err (UserId, RootId, CorpusId)
  77 getOrMk_RootWithCorpus user cName c = do
  78   (userId, rootId) <- getOrMkRoot user
  79   corpusId'' <- if user == UserName userMaster
  80                   then do
  81                     ns <- getCorporaWithParentId rootId
  82                     pure $ map _node_id ns
  83                   else
  84                     pure $ fromRight [] cName
  85
  86   corpusId' <- if corpusId'' /= []
  87                   then pure corpusId''
  88                   else do
  89                     c' <- mk (Just $ fromLeft "Default" cName) c rootId userId
  90                     _tId <- case head c' of
  91                               Nothing -> pure [0]
  92                               Just c'' -> insertDefaultNode NodeTexts c'' userId
  93                     pure c'
  94
  95   corpusId <- maybe (nodeError NoCorpusFound) pure (head corpusId')
  96   pure (userId, rootId, corpusId)
  97
  98
  99 mkRoot :: HasNodeError err
 100        => User
 101        -> Cmd err [RootId]
 102 mkRoot user = do
 103
 104   -- TODO
 105   -- udb <- getUserDb user
 106   -- let uid = user_id udb
 107   uid <- getUserId user
 108
 109   -- TODO ? Which name for user Node ?
 110   let una = "username"
 111
 112   case uid > 0 of
 113      False -> nodeError NegativeId
 114      True  -> do
 115        rs <- mkNodeWithParent NodeUser Nothing uid una
 116        _ <- case rs of
 117          [r] -> do
 118            _ <- insertNode NodeFolderPrivate Nothing Nothing r uid
 119            _ <- insertNode NodeFolderShared Nothing Nothing r uid
 120            _ <- insertNode NodeFolderPublic Nothing Nothing r uid
 121            pure rs
 122          _   -> pure rs
 123        pure rs
 124
 125 selectRoot :: User -> Query NodeRead
 126 selectRoot (UserName username) = proc () -> do
 127     row   <- queryNodeTable -< ()
 128     users <- queryUserTable -< ()
 129     restrict -< _node_typename row   .== (pgInt4 $ nodeTypeId NodeUser)
 130     restrict -< user_username  users .== (pgStrictText username)
 131     restrict -< _node_userId   row   .== (user_id users)
 132     returnA  -< row
 133
 134 selectRoot (UserDBId uid) = proc () -> do
 135     row   <- queryNodeTable -< ()
 136     restrict -< _node_typename row   .== (pgInt4 $ nodeTypeId NodeUser)
 137     restrict -< _node_userId   row   .== (pgInt4 uid)
 138     returnA  -< row
 139
 140 selectRoot (RootId nid) =
 141  proc () -> do
 142     row   <- queryNodeTable -< ()
 143     restrict -< _node_typename row   .== (pgInt4 $ nodeTypeId NodeUser)
 144     restrict -< _node_id   row   .== (pgNodeId nid)
 145     returnA  -< row
 146 selectRoot UserPublic = panic "No root for Public"