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.Lens ((#))
  12 import Control.Monad.Base (liftBase)
  13 import Control.Monad.IO.Class (liftIO)
  14 import Data.ByteString.Lazy.Char8
  15   ( ByteString
  16   )
  17 import Data.List.NonEmpty (NonEmpty ((:|)))
  18 import Data.Maybe (fromMaybe)
  19 import Data.Morpheus
  20   ( App
  21   , deriveApp )
  22 import Data.Morpheus.Server
  23   ( httpPlayground
  24   )
  25 import Data.Morpheus.Subscriptions
  26   ( Event (..)
  27   , Hashable
  28   , PubApp
  29   , SubApp
  30   , httpPubApp
  31   , webSocketsApp
  32   )
  33 import Data.Morpheus.Types
  34   ( GQLRequest
  35   , GQLResponse
  36   , GQLType
  37   , ResolverQ
  38   , RootResolver(..)
  39   , Undefined(..)
  40   , lift
  41   , liftEither
  42   , publish
  43   , render
  44   )
  45 import Data.Morpheus.Types.Internal.AST
  46   ( msg )
  47 import Data.Text (Text)
  48 import qualified Data.Text.Lazy as LT
  49 import Data.Text.Lazy.Encoding (decodeUtf8)
  50 import Data.Typeable (Typeable)
  51 import Gargantext.API.Admin.Auth.Types (AuthenticatedUser)
  52 import qualified Gargantext.API.GraphQL.User as GQLUser
  53 import qualified Gargantext.API.GraphQL.UserInfo as GQLUserInfo
  54 import Gargantext.API.Prelude (GargServerT, GargM, GargError, _ServerError)
  55 import Gargantext.Database.Prelude (Cmd, HasConnectionPool, HasConfig)
  56 import Gargantext.Database.Schema.User (UserPoly(..))
  57 import Gargantext.Prelude
  58 import GHC.Generics (Generic)
  59 import GHC.TypeLits
  60 import Network.HTTP.Media ((//), (/:))
  61 import Network.WebSockets
  62   ( ServerApp,
  63   )
  64 import qualified Prelude as Prelude
  65 import Servant
  66   ( (:<|>) (..),
  67     (:>),
  68     Accept (..),
  69     Get,
  70     JSON,
  71     MimeRender (..),
  72     PlainText,
  73     Post,
  74     ReqBody,
  75     ServerT,
  76     err401
  77   )
  78 import qualified Servant.Auth as SA
  79 import qualified Servant.Auth.Server as SAS
  80
  81 -- | Represents possible GraphQL queries.
  82 data Query m
  83   = Query
  84     { user_infos :: GQLUserInfo.UserInfoArgs -> m [GQLUserInfo.UserInfo]
  85     , users :: GQLUser.UserArgs -> m [GQLUser.User m]
  86     } deriving (Generic, GQLType)
  87
  88 data Mutation m
  89   = Mutation
  90     { update_user_info :: GQLUserInfo.UserInfoMArgs -> 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   :: (HasConnectionPool env, HasConfig env)
 112   => RootResolver (GargM env GargError) e Query Mutation Undefined
 113 rootResolver =
 114   RootResolver
 115     { queryResolver = Query { user_infos = GQLUserInfo.resolveUserInfos
 116                             , users = GQLUser.resolveUsers }
 117     , mutationResolver = Mutation { update_user_info = GQLUserInfo.updateUserInfo }
 118     , subscriptionResolver = Undefined }
 119
 120 -- | Main GraphQL "app".
 121 app
 122   :: (Typeable env, HasConnectionPool env, HasConfig env)
 123   => App (EVENT (GargM env GargError)) (GargM env GargError)
 124 app = deriveApp rootResolver
 125
 126 ----------------------------------------------
 127
 128 -- Now for some boilerplate to integrate the above GraphQL app with
 129 -- servant.
 130
 131 -- | HTML type is needed for the GraphQL Playground.
 132 data HTML deriving (Typeable)
 133 instance Accept HTML where
 134   contentTypes _ = "text" // "html" /: ("charset", "utf-8") :| ["text" // "html"]
 135 instance MimeRender HTML ByteString where
 136   mimeRender _ = Prelude.id
 137
 138 -- | Servant route for the app we defined above.
 139 type GQAPI = ReqBody '[JSON] GQLRequest :> Post '[JSON] GQLResponse
 140 -- type Schema = "schema" :> Get '[PlainText] Text
 141 -- | Servant route for the playground.
 142 type Playground = Get '[HTML] ByteString
 143 -- type API' (name :: Symbol) = name :> (GQAPI :<|> Schema :<|> Playground)
 144 -- | Our API consists of `GQAPI` and `Playground`.
 145 type API = SA.Auth '[SA.JWT, SA.Cookie] AuthenticatedUser
 146             :> "gql" :> (GQAPI :<|> Playground)
 147
 148 -- serveEndpoint ::
 149 --   ( SubApp ServerApp e
 150 --   , PubApp e
 151 --   ) =>
 152 --   [e -> IO ()] ->
 153 --   App e IO ->
 154 --   Server (API name)
 155 -- serveEndpoint publish app' = (liftIO . httpPubApp publish app') :<|> withSchema app' :<|> pure httpPlayground
 156 --
 157 -- withSchema :: (Applicative f) => App e m -> f Text
 158 -- withSchema = pure . LT.toStrict . decodeUtf8 . render
 159
 160 -- | Implementation of our API.
 161 --api :: Server API
 162 api
 163   :: (Typeable env, HasConnectionPool env, HasConfig env)
 164   => ServerT API (GargM env GargError)
 165 api (SAS.Authenticated _auser) = httpPubApp [] app :<|> pure httpPlayground
 166 api _                         = panic "401 in graphql" --SAS.throwAll (_ServerError # err401)