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