src/Gargantext/API/GraphQL.hs

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