src/Gargantext/Database/Action/Query/Node/User.hs

   1 {-|
   2 Module      : Gargantext.Database.Node.User
   3 Description : User Node in Gargantext
   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
  12 {-# LANGUAGE DeriveGeneric          #-}
  13 {-# LANGUAGE NoImplicitPrelude      #-}
  14 {-# LANGUAGE FunctionalDependencies #-}
  15 {-# LANGUAGE OverloadedStrings      #-}
  16 {-# LANGUAGE FlexibleInstances      #-}
  17 {-# LANGUAGE MultiParamTypeClasses  #-}
  18 {-# LANGUAGE TemplateHaskell        #-}
  19
  20 module Gargantext.Database.Action.Query.Node.User
  21   where
  22
  23 import Control.Lens (makeLenses)
  24 import Data.Aeson.TH (deriveJSON)
  25 import Data.Swagger (ToSchema(..), genericDeclareNamedSchema)
  26 import Data.Text (Text)
  27 import Database.PostgreSQL.Simple.FromField (FromField, fromField)
  28 import GHC.Generics (Generic)
  29 import Gargantext.Core (Lang(..))
  30 import Gargantext.Core.Types.Individu (Username, arbitraryUsername, User(..), UserId)
  31 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
  32 import Gargantext.Database.Action.Query.Node (getNode)
  33 import Gargantext.Database.Action.Query.Node.Contact (HyperdataContact, fake_HyperdataContact)
  34 import Gargantext.Database.Admin.Types.Node (Node,Hyperdata, DocumentId, NodeId(..))
  35 import Gargantext.Database.Admin.Utils (fromField')
  36 import Gargantext.Database.Schema.Node (Node(..))
  37 import Gargantext.Prelude
  38 import Opaleye (QueryRunnerColumnDefault, queryRunnerColumnDefault, PGJsonb, fieldQueryRunnerColumn)
  39 import Test.QuickCheck (elements)
  40 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  41
  42 ------------------------------------------------------------------------
  43 type NodeUser  = Node HyperdataUser
  44
  45 data HyperdataUser =
  46      HyperdataUser { _hu_private   :: !(Maybe HyperdataPrivate)
  47                    , _hu_shared    :: !(Maybe HyperdataContact)
  48                    , _hu_public    :: !(Maybe HyperdataPublic)
  49                    } deriving (Eq, Show, Generic)
  50
  51 data HyperdataPrivate =
  52      HyperdataPrivate { _hpr_password :: !Text
  53                       , _hpr_lang     :: !Lang
  54                       }
  55      deriving (Eq, Show, Generic)
  56
  57 data HyperdataPublic =
  58      HyperdataPublic { _hpu_pseudo :: !Text
  59                      , _hpu_publications :: ![DocumentId]
  60                      }
  61      deriving (Eq, Show, Generic)
  62
  63 -- | Fake instances
  64
  65 fake_HyperdataUser :: HyperdataUser
  66 fake_HyperdataUser = HyperdataUser (Just fake_HyperdataPrivate)
  67                                    (Just fake_HyperdataContact)
  68                                    (Just fake_HyperdataPublic)
  69
  70 fake_HyperdataPublic :: HyperdataPublic
  71 fake_HyperdataPublic = HyperdataPublic "pseudo" [1..10]
  72
  73 fake_HyperdataPrivate :: HyperdataPrivate
  74 fake_HyperdataPrivate = HyperdataPrivate "password" EN
  75
  76 -- | ToSchema instances
  77 instance ToSchema HyperdataUser where
  78   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_hu_")
  79
  80 instance ToSchema HyperdataPrivate where
  81   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_hpr_")
  82
  83 instance ToSchema HyperdataPublic where
  84   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_hpu_")
  85
  86
  87 -- | Arbitrary instances
  88 instance Arbitrary HyperdataUser where
  89   arbitrary = HyperdataUser <$> arbitrary <*> arbitrary <*> arbitrary
  90
  91 instance Arbitrary HyperdataPrivate where
  92   arbitrary = elements [HyperdataPrivate "" EN]
  93
  94 instance Arbitrary HyperdataPublic where
  95   arbitrary = elements [HyperdataPublic "pseudo" [NodeId 2]]
  96
  97
  98 -- | Specific Gargantext instance
  99 instance Hyperdata HyperdataUser
 100 instance Hyperdata HyperdataPrivate
 101 instance Hyperdata HyperdataPublic
 102
 103 -- | Database (Posgresql-simple instance)
 104 instance FromField HyperdataUser where
 105   fromField = fromField'
 106 instance FromField HyperdataPrivate where
 107   fromField = fromField'
 108 instance FromField HyperdataPublic where
 109   fromField = fromField'
 110
 111 -- | Database (Opaleye instance)
 112 instance QueryRunnerColumnDefault PGJsonb HyperdataUser   where
 113   queryRunnerColumnDefault = fieldQueryRunnerColumn
 114
 115 instance QueryRunnerColumnDefault PGJsonb HyperdataPrivate   where
 116   queryRunnerColumnDefault = fieldQueryRunnerColumn
 117
 118 instance QueryRunnerColumnDefault PGJsonb HyperdataPublic   where
 119   queryRunnerColumnDefault = fieldQueryRunnerColumn
 120
 121 -- | All lenses
 122 makeLenses ''HyperdataUser
 123 makeLenses ''HyperdataPrivate
 124 makeLenses ''HyperdataPublic
 125
 126 -- | All Json instances
 127 $(deriveJSON (unPrefix "_hu_") ''HyperdataUser)
 128 $(deriveJSON (unPrefix "_hpr_") ''HyperdataPrivate)
 129 $(deriveJSON (unPrefix "_hpu_") ''HyperdataPublic)
 130
 131
 132 -----------------------------------------------------------------
 133 getUserId :: HasNodeError err
 134           => User
 135           -> Cmd err UserId
 136 getUserId (UserDBId uid) = pure uid
 137 getUserId (RootId   rid) = do
 138   n <- getNode rid
 139   pure $ _node_userId n
 140 getUserId (UserName u  ) = do
 141   muser <- getUser u
 142   case muser of
 143     Just user -> pure $ userLight_id user
 144     Nothing   -> nodeError NoUserFound
 145
 146
 147 getNodeUser :: NodeId -> Cmd err (Node HyperdataUser)
 148 getNodeUser nId = do
 149     fromMaybe (error $ "Node does not exist: " <> show nId) . headMay
 150              <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
 151
 152
 153 nodeUserW :: Maybe Name -> Maybe HyperdataUser -> UserId -> NodeWrite
 154 nodeUserW maybeName maybeHyperdata = node NodeUser name user Nothing
 155   where
 156     name = maybe "User" identity maybeName
 157     user = maybe fake_HyperdataUser identity maybeHyperdata
 158
 159
 160