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 {-# OPTIONS_GHC -fno-warn-unused-imports #-}
   8
   9 module Gargantext.API.GraphQL where
  10
  11 import Control.Monad.Base (liftBase)
  12 import Control.Monad.IO.Class (liftIO)
  13 import Data.ByteString.Lazy.Char8
  14   ( ByteString
  15   )
  16 import Data.List.NonEmpty (NonEmpty ((:|)))
  17 import Data.Maybe (fromMaybe)
  18 import Data.Morpheus
  19   ( App
  20   , deriveApp )
  21 import Data.Morpheus.App.Internal.Resolving
  22   ( failure )
  23 import Data.Morpheus.Server
  24   ( httpPlayground
  25   )
  26 import Data.Morpheus.Subscriptions
  27   ( Event (..)
  28   , Hashable
  29   , PubApp
  30   , SubApp
  31   , httpPubApp
  32   , webSocketsApp
  33   )
  34 import Data.Morpheus.Types
  35   ( GQLRequest
  36   , GQLResponse
  37   , GQLType
  38   , ResolverQ
  39   , RootResolver(..)
  40   , Undefined(..)
  41   , lift
  42   , liftEither
  43   , publish
  44   , render
  45   )
  46 import Data.Morpheus.Types.Internal.AST
  47   ( msg )
  48 import Data.Text (Text)
  49 import qualified Data.Text.Lazy as LT
  50 import Data.Text.Lazy.Encoding (decodeUtf8)
  51 import Data.Typeable (Typeable)
  52 import Gargantext.API.GraphQL.User
  53 import Gargantext.API.Prelude (GargServerT, GargM, GargError)
  54 import Gargantext.Database.Prelude (Cmd, HasConnectionPool, HasConfig)
  55 import Gargantext.Database.Schema.User (UserPoly(..), UserLight)
  56 import Gargantext.Prelude
  57 import GHC.Generics (Generic)
  58 import GHC.TypeLits
  59 import Network.HTTP.Media ((//), (/:))
  60 import Network.WebSockets
  61   ( ServerApp,
  62   )
  63 import qualified Prelude as Prelude
  64 import Servant
  65   ( (:<|>) (..),
  66     (:>),
  67     Accept (..),
  68     Get,
  69     JSON,
  70     MimeRender (..),
  71     PlainText,
  72     Post,
  73     ReqBody,
  74     ServerT,
  75   )
  76
  77 -- | Represents possible GraphQL queries.
  78 data Query m
  79   = Query
  80     { users :: UserArgs -> m [UserLight]
  81     } deriving (Generic, GQLType)
  82
  83 -- | Possible GraphQL Events, i.e. here we describe how we will
  84 -- manipulate the data.
  85 type EVENT = Event Channel Contet
  86
  87 -- | Channels are possible actions to call when manipulating the data.
  88 data Channel
  89   = Update
  90   | New
  91   deriving (Eq, Show, Generic, Hashable)
  92
  93 -- | This type describes what data we will operate on.
  94 data Contet
  95   = UserContet [UserLight]
  96
  97
  98 -- | The main GraphQL resolver: how queries, mutations and
  99 -- subscriptions are handled.
 100 rootResolver
 101   :: (HasConnectionPool env, HasConfig env)
 102   => RootResolver (GargM env GargError) EVENT Query Undefined Undefined
 103 rootResolver =
 104   RootResolver
 105     { queryResolver = Query { users = resolveUsers }
 106     , mutationResolver = Undefined
 107     , subscriptionResolver = Undefined }
 108
 109 -- | Main GraphQL "app".
 110 app
 111   :: (Typeable env, HasConnectionPool env, HasConfig env)
 112   => App EVENT (GargM env GargError)
 113 app = deriveApp rootResolver
 114
 115 ----------------------------------------------
 116
 117 -- Now for some boilerplate to integrate the above GraphQL app with
 118 -- servant.
 119
 120 -- | HTML type is needed for the GraphQL Playground.
 121 data HTML deriving (Typeable)
 122 instance Accept HTML where
 123   contentTypes _ = "text" // "html" /: ("charset", "utf-8") :| ["text" // "html"]
 124 instance MimeRender HTML ByteString where
 125   mimeRender _ = Prelude.id
 126
 127 -- | Servant route for the app we defined above.
 128 type GQAPI = ReqBody '[JSON] GQLRequest :> Post '[JSON] GQLResponse
 129 -- type Schema = "schema" :> Get '[PlainText] Text
 130 -- | Servant route for the playground.
 131 type Playground = Get '[HTML] ByteString
 132 -- type API' (name :: Symbol) = name :> (GQAPI :<|> Schema :<|> Playground)
 133 -- | Our API consists of `GQAPI` and `Playground`.
 134 type API = "gql" :> (GQAPI :<|> Playground)
 135
 136 -- serveEndpoint ::
 137 --   ( SubApp ServerApp e
 138 --   , PubApp e
 139 --   ) =>
 140 --   [e -> IO ()] ->
 141 --   App e IO ->
 142 --   Server (API name)
 143 -- serveEndpoint publish app' = (liftIO . httpPubApp publish app') :<|> withSchema app' :<|> pure httpPlayground
 144 --
 145 -- withSchema :: (Applicative f) => App e m -> f Text
 146 -- withSchema = pure . LT.toStrict . decodeUtf8 . render
 147
 148 -- | Implementation of our API.
 149 --api :: Server API
 150 api
 151   :: (Typeable env, HasConnectionPool env, HasConfig env)
 152   => ServerT API (GargM env GargError)
 153 api = httpPubApp [] app :<|> pure httpPlayground