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