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