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