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