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 qualified Gargantext.API.GraphQL.User as GQLUser
  51 import qualified Gargantext.API.GraphQL.UserInfo as GQLUserInfo
  52 import Gargantext.API.Prelude (GargServerT, GargM, GargError)
  53 import Gargantext.Database.Prelude (Cmd, HasConnectionPool, HasConfig)
  54 import Gargantext.Database.Schema.User (UserPoly(..))
  55 import Gargantext.Prelude
  56 import GHC.Generics (Generic)
  57 import GHC.TypeLits
  58 import Network.HTTP.Media ((//), (/:))
  59 import Network.WebSockets
  60   ( ServerApp,
  61   )
  62 import qualified Prelude as Prelude
  63 import Servant
  64   ( (:<|>) (..),
  65     (:>),
  66     Accept (..),
  67     Get,
  68     JSON,
  69     MimeRender (..),
  70     PlainText,
  71     Post,
  72     ReqBody,
  73     ServerT,
  74   )
  75
  76 -- | Represents possible GraphQL queries.
  77 data Query m
  78   = Query
  79     { user_infos :: GQLUserInfo.UserInfoArgs -> m [GQLUserInfo.UserInfo]
  80     , users :: GQLUser.UserArgs -> m [GQLUser.User m]
  81     } deriving (Generic, GQLType)
  82
  83 data Mutation m
  84   = Mutation
  85     { update_user_info :: GQLUserInfo.UserInfoMArgs -> m GQLUserInfo.UserInfo }
  86     deriving (Generic, GQLType)
  87
  88 -- | Possible GraphQL Events, i.e. here we describe how we will
  89 -- manipulate the data.
  90 type EVENT m = Event Channel (Contet m)
  91
  92 -- | Channels are possible actions to call when manipulating the data.
  93 data Channel
  94   = Update
  95   | New
  96   deriving (Eq, Show, Generic, Hashable)
  97
  98 -- | This type describes what data we will operate on.
  99 data Contet m
 100   = UserContet [GQLUser.User m]
 101   | UserInfoContet [GQLUserInfo.UserInfo]
 102
 103 -- | The main GraphQL resolver: how queries, mutations and
 104 -- subscriptions are handled.
 105 rootResolver
 106   :: (HasConnectionPool env, HasConfig env)
 107   => RootResolver (GargM env GargError) e Query Mutation Undefined
 108 rootResolver =
 109   RootResolver
 110     { queryResolver = Query { user_infos = GQLUserInfo.resolveUserInfos
 111                             , users = GQLUser.resolveUsers }
 112     , mutationResolver = Mutation { update_user_info = GQLUserInfo.updateUserInfo }
 113     , subscriptionResolver = Undefined }
 114
 115 -- | Main GraphQL "app".
 116 app
 117   :: (Typeable env, HasConnectionPool env, HasConfig env)
 118   => App (EVENT (GargM env GargError)) (GargM env GargError)
 119 app = deriveApp rootResolver
 120
 121 ----------------------------------------------
 122
 123 -- Now for some boilerplate to integrate the above GraphQL app with
 124 -- servant.
 125
 126 -- | HTML type is needed for the GraphQL Playground.
 127 data HTML deriving (Typeable)
 128 instance Accept HTML where
 129   contentTypes _ = "text" // "html" /: ("charset", "utf-8") :| ["text" // "html"]
 130 instance MimeRender HTML ByteString where
 131   mimeRender _ = Prelude.id
 132
 133 -- | Servant route for the app we defined above.
 134 type GQAPI = ReqBody '[JSON] GQLRequest :> Post '[JSON] GQLResponse
 135 -- type Schema = "schema" :> Get '[PlainText] Text
 136 -- | Servant route for the playground.
 137 type Playground = Get '[HTML] ByteString
 138 -- type API' (name :: Symbol) = name :> (GQAPI :<|> Schema :<|> Playground)
 139 -- | Our API consists of `GQAPI` and `Playground`.
 140 type API = "gql" :> (GQAPI :<|> Playground)
 141
 142 -- serveEndpoint ::
 143 --   ( SubApp ServerApp e
 144 --   , PubApp e
 145 --   ) =>
 146 --   [e -> IO ()] ->
 147 --   App e IO ->
 148 --   Server (API name)
 149 -- serveEndpoint publish app' = (liftIO . httpPubApp publish app') :<|> withSchema app' :<|> pure httpPlayground
 150 --
 151 -- withSchema :: (Applicative f) => App e m -> f Text
 152 -- withSchema = pure . LT.toStrict . decodeUtf8 . render
 153
 154 -- | Implementation of our API.
 155 --api :: Server API
 156 api
 157   :: (Typeable env, HasConnectionPool env, HasConfig env)
 158   => ServerT API (GargM env GargError)
 159 api = httpPubApp [] app :<|> pure httpPlayground