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