src/Gargantext/API/GraphQL.hs

   1 {-# OPTIONS_GHC -fprint-potential-instances #-}
   2
   3 {-# LANGUAGE DeriveAnyClass #-}
   4 {-# LANGUAGE DuplicateRecordFields #-}  -- permit duplications for field names in multiple constructors
   5 {-# LANGUAGE KindSignatures #-}  -- for use of Endpoint (name :: Symbol)
   6 {-# LANGUAGE PartialTypeSignatures #-}  -- to automatically use suggested type hole signatures during compilation
   7 {-# LANGUAGE TypeOperators #-}
   8
   9 module Gargantext.API.GraphQL where
  10
  11 import Data.ByteString.Lazy.Char8
  12   ( ByteString
  13   )
  14 import Data.Map (Map)
  15 import Data.Morpheus
  16   ( App
  17   , deriveApp )
  18 import Data.Morpheus.Server
  19   ( httpPlayground
  20   )
  21 import Data.Morpheus.Subscriptions
  22   ( Event (..)
  23   , Hashable
  24   , httpPubApp
  25   )
  26 import Data.Morpheus.Types
  27   ( GQLRequest
  28   , GQLResponse
  29   , GQLType
  30   , RootResolver(..)
  31   , Undefined(..)
  32   )
  33 import Data.Proxy
  34 import Gargantext.API.Admin.Auth.Types (AuthenticatedUser)
  35 import Gargantext.API.Admin.Orchestrator.Types (JobLog)
  36 import Gargantext.API.Prelude (HasJobEnv')
  37 import qualified Gargantext.API.GraphQL.Annuaire as GQLA
  38 import qualified Gargantext.API.GraphQL.AsyncTask as GQLAT
  39 import qualified Gargantext.API.GraphQL.IMT as GQLIMT
  40 import qualified Gargantext.API.GraphQL.Node as GQLNode
  41 import qualified Gargantext.API.GraphQL.User as GQLUser
  42 import qualified Gargantext.API.GraphQL.UserInfo as GQLUserInfo
  43 import qualified Gargantext.API.GraphQL.TreeFirstLevel as GQLTree
  44 import qualified Gargantext.API.GraphQL.Team as GQLTeam
  45 import Gargantext.API.Prelude (GargM, GargError)
  46 import Gargantext.API.Types
  47 import Gargantext.Core.Mail.Types (HasMail)
  48 import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
  49 import Gargantext.Prelude
  50 import GHC.Generics (Generic)
  51 import Servant
  52   ( (:<|>) (..)
  53   , (:>)
  54   , Get
  55   , JSON
  56   , Post
  57   , ReqBody
  58   ,  ServerT
  59   )
  60 import qualified Servant.Auth as SA
  61 import qualified Servant.Auth.Server as SAS
  62 import Gargantext.API.Admin.Types (HasSettings)
  63
  64
  65 -- | Represents possible GraphQL queries.
  66 data Query m
  67   = Query
  68     { annuaire_contacts :: GQLA.AnnuaireContactArgs -> m [GQLA.AnnuaireContact]
  69     , imt_schools :: GQLIMT.SchoolsArgs -> m [GQLIMT.School]
  70     , job_logs    :: GQLAT.JobLogArgs -> m (Map Int JobLog)
  71     , nodes       :: GQLNode.NodeArgs -> m [GQLNode.Node]
  72     , node_parent :: GQLNode.NodeParentArgs -> m [GQLNode.Node]
  73     , user_infos  :: GQLUserInfo.UserInfoArgs -> m [GQLUserInfo.UserInfo]
  74     , users       :: GQLUser.UserArgs -> m [GQLUser.User m]
  75     , tree        :: GQLTree.TreeArgs -> m (GQLTree.TreeFirstLevel m)
  76     , team        :: GQLTeam.TeamArgs -> m GQLTeam.Team
  77     } deriving (Generic, GQLType)
  78
  79 data Mutation m
  80   = Mutation
  81     { update_user_info        :: GQLUserInfo.UserInfoMArgs -> m Int
  82     , delete_team_membership :: GQLTeam.TeamDeleteMArgs -> m [Int]
  83     } deriving (Generic, GQLType)
  84
  85 -- | Possible GraphQL Events, i.e. here we describe how we will
  86 -- manipulate the data.
  87 type EVENT m = Event Channel (Contet m)
  88
  89 -- | Channels are possible actions to call when manipulating the data.
  90 data Channel
  91   = Update
  92   | New
  93   deriving (Eq, Show, Generic, Hashable)
  94
  95 -- | This type describes what data we will operate on.
  96 data Contet m
  97   = UserContet [GQLUser.User m]
  98   | UserInfoContet [GQLUserInfo.UserInfo]
  99
 100 -- | The main GraphQL resolver: how queries, mutations and
 101 -- subscriptions are handled.
 102 rootResolver
 103   :: (HasConnectionPool env, HasConfig env, HasMail env, HasJobEnv' env, HasSettings env)
 104   => RootResolver (GargM env GargError) e Query Mutation Undefined
 105 rootResolver =
 106   RootResolver
 107     { queryResolver = Query { annuaire_contacts = GQLA.resolveAnnuaireContacts
 108                             , imt_schools       = GQLIMT.resolveSchools
 109                             , job_logs          = GQLAT.resolveJobLogs
 110                             , nodes             = GQLNode.resolveNodes
 111                             , node_parent       = GQLNode.resolveNodeParent
 112                             , user_infos        = GQLUserInfo.resolveUserInfos
 113                             , users             = GQLUser.resolveUsers
 114                             , tree              = GQLTree.resolveTree
 115                             , team              = GQLTeam.resolveTeam }
 116     , mutationResolver = Mutation { update_user_info       = GQLUserInfo.updateUserInfo
 117                                   , delete_team_membership = GQLTeam.deleteTeamMembership }
 118     , subscriptionResolver = Undefined }
 119
 120 -- | Main GraphQL "app".
 121 app
 122   :: (Typeable env, HasConnectionPool env, HasConfig env, HasMail env, HasJobEnv' env, HasSettings env)
 123   => App (EVENT (GargM env GargError)) (GargM env GargError)
 124 app = deriveApp rootResolver
 125
 126 ----------------------------------------------
 127
 128 -- Now for some boilerplate to integrate the above GraphQL app with
 129 -- servant.
 130
 131 -- | Servant route for the app we defined above.
 132 type GQAPI = ReqBody '[JSON] GQLRequest :> Post '[JSON] GQLResponse
 133 -- type Schema = "schema" :> Get '[PlainText] Text
 134 -- | Servant route for the playground.
 135 type Playground = Get '[HTML] ByteString
 136 -- type API' (name :: Symbol) = name :> (GQAPI :<|> Schema :<|> Playground)
 137 -- | Our API consists of `GQAPI` and `Playground`.
 138 type API = SA.Auth '[SA.JWT, SA.Cookie] AuthenticatedUser
 139             :> "gql" :> (GQAPI :<|> Playground)
 140
 141 gqapi :: Proxy API
 142 gqapi = Proxy
 143
 144 -- serveEndpoint ::
 145 --   ( SubApp ServerApp e
 146 --   , PubApp e
 147 --   ) =>
 148 --   [e -> IO ()] ->
 149 --   App e IO ->
 150 --   Server (API name)
 151 -- serveEndpoint publish app' = (liftIO . httpPubApp publish app') :<|> withSchema app' :<|> pure httpPlayground
 152 --
 153 -- withSchema :: (Applicative f) => App e m -> f Text
 154 -- withSchema = pure . LT.toStrict . decodeUtf8 . render
 155
 156 -- | Implementation of our API.
 157 --api :: Server API
 158 api
 159   :: (Typeable env, HasConnectionPool env, HasConfig env, HasMail env, HasJobEnv' env, HasSettings env)
 160   => ServerT API (GargM env GargError)
 161 api (SAS.Authenticated _auser) = httpPubApp [] app :<|> pure httpPlayground
 162 api _                          = panic "401 in graphql" -- SAS.throwAll (_ServerError # err401)