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

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