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.Strict (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.Context as GQLCTX
  40 import qualified Gargantext.API.GraphQL.IMT as GQLIMT
  41 import qualified Gargantext.API.GraphQL.Node as GQLNode
  42 import qualified Gargantext.API.GraphQL.User as GQLUser
  43 import qualified Gargantext.API.GraphQL.UserInfo as GQLUserInfo
  44 import qualified Gargantext.API.GraphQL.TreeFirstLevel as GQLTree
  45 import qualified Gargantext.API.GraphQL.Team as GQLTeam
  46 import Gargantext.API.Prelude (GargM, GargError)
  47 import Gargantext.API.Types
  48 import Gargantext.Database.Prelude (CmdCommon)
  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     , contexts            :: GQLCTX.NodeContextArgs -> m [GQLCTX.NodeContextGQL]
  70     , contexts_for_ngrams :: GQLCTX.ContextsForNgramsArgs -> m [GQLCTX.ContextGQL]
  71     , imt_schools         :: GQLIMT.SchoolsArgs -> m [GQLIMT.School]
  72     , job_logs            :: GQLAT.JobLogArgs -> m (Map Int JobLog)
  73     , nodes               :: GQLNode.NodeArgs -> m [GQLNode.Node]
  74     , node_parent         :: GQLNode.NodeParentArgs -> m [GQLNode.Node]
  75     , user_infos          :: GQLUserInfo.UserInfoArgs -> m [GQLUserInfo.UserInfo]
  76     , users               :: GQLUser.UserArgs -> m [GQLUser.User m]
  77     , tree                :: GQLTree.TreeArgs -> m (GQLTree.TreeFirstLevel m)
  78     , team                :: GQLTeam.TeamArgs -> m GQLTeam.Team
  79     } deriving (Generic, GQLType)
  80
  81 data Mutation m
  82   = Mutation
  83     { update_user_info       :: GQLUserInfo.UserInfoMArgs -> m Int
  84     , delete_team_membership :: GQLTeam.TeamDeleteMArgs -> m [Int]
  85     , update_node_context_category :: GQLCTX.NodeContextCategoryMArgs -> m [Int]
  86     } deriving (Generic, GQLType)
  87
  88 -- | Possible GraphQL Events, i.e. here we describe how we will
  89 -- manipulate the data.
  90 type EVENT m = Event Channel (Contet m)
  91
  92 -- | Channels are possible actions to call when manipulating the data.
  93 data Channel
  94   = Update
  95   | New
  96   deriving (Eq, Show, Generic, Hashable)
  97
  98 -- | This type describes what data we will operate on.
  99 data Contet m
 100   = UserContet [GQLUser.User m]
 101   | UserInfoContet [GQLUserInfo.UserInfo]
 102
 103 -- | The main GraphQL resolver: how queries, mutations and
 104 -- subscriptions are handled.
 105 rootResolver
 106   :: (CmdCommon env, HasJobEnv' env, HasSettings env)
 107   => RootResolver (GargM env GargError) e Query Mutation Undefined
 108 rootResolver =
 109   RootResolver
 110     { queryResolver = Query { annuaire_contacts   = GQLA.resolveAnnuaireContacts
 111                             , contexts            = GQLCTX.resolveNodeContext
 112                             , contexts_for_ngrams = GQLCTX.resolveContextsForNgrams
 113                             , imt_schools         = GQLIMT.resolveSchools
 114                             , job_logs            = GQLAT.resolveJobLogs
 115                             , nodes               = GQLNode.resolveNodes
 116                             , node_parent         = GQLNode.resolveNodeParent
 117                             , user_infos          = GQLUserInfo.resolveUserInfos
 118                             , users               = GQLUser.resolveUsers
 119                             , tree                = GQLTree.resolveTree
 120                             , team                = GQLTeam.resolveTeam }
 121     , mutationResolver = Mutation { update_user_info       = GQLUserInfo.updateUserInfo
 122                                   , delete_team_membership = GQLTeam.deleteTeamMembership
 123                                   , update_node_context_category = GQLCTX.updateNodeContextCategory }
 124     , subscriptionResolver = Undefined }
 125
 126 -- | Main GraphQL "app".
 127 app
 128   :: (Typeable env, CmdCommon env, HasJobEnv' env, HasSettings env)
 129   => App (EVENT (GargM env GargError)) (GargM env GargError)
 130 app = deriveApp rootResolver
 131
 132 ----------------------------------------------
 133
 134 -- Now for some boilerplate to integrate the above GraphQL app with
 135 -- servant.
 136
 137 -- | Servant route for the app we defined above.
 138 type GQAPI = ReqBody '[JSON] GQLRequest :> Post '[JSON] GQLResponse
 139 -- type Schema = "schema" :> Get '[PlainText] Text
 140 -- | Servant route for the playground.
 141 type Playground = Get '[HTML] ByteString
 142 -- type API' (name :: Symbol) = name :> (GQAPI :<|> Schema :<|> Playground)
 143 -- | Our API consists of `GQAPI` and `Playground`.
 144 type API = SA.Auth '[SA.JWT, SA.Cookie] AuthenticatedUser
 145             :> "gql" :> (GQAPI :<|> Playground)
 146
 147 gqapi :: Proxy API
 148 gqapi = Proxy
 149
 150 -- serveEndpoint ::
 151 --   ( SubApp ServerApp e
 152 --   , PubApp e
 153 --   ) =>
 154 --   [e -> IO ()] ->
 155 --   App e IO ->
 156 --   Server (API name)
 157 -- serveEndpoint publish app' = (liftIO . httpPubApp publish app') :<|> withSchema app' :<|> pure httpPlayground
 158 --
 159 -- withSchema :: (Applicative f) => App e m -> f Text
 160 -- withSchema = pure . LT.toStrict . decodeUtf8 . render
 161
 162 -- | Implementation of our API.
 163 --api :: Server API
 164 api
 165   :: (Typeable env, CmdCommon env, HasJobEnv' env, HasSettings env)
 166   => ServerT API (GargM env GargError)
 167 api (SAS.Authenticated _auser) = httpPubApp [] app :<|> pure httpPlayground
 168 api _                          = panic "401 in graphql" -- SAS.throwAll (_ServerError # err401)