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