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