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