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.Morpheus
  18   ( App
  19   , deriveApp )
  20 import Data.Morpheus.App.Internal.Resolving
  21   ( failure )
  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.Prelude (GargServerT, GargM, GargError)
  52 import Gargantext.Database.Prelude (Cmd, HasConnectionPool, HasConfig)
  53 import Gargantext.Database.Query.Table.User (getUsersWithId)
  54 import Gargantext.Database.Schema.User (UserPoly(..), UserLight)
  55 import GHC.Generics (Generic)
  56 import GHC.TypeLits
  57 import Network.HTTP.Media ((//), (/:))
  58 import Network.WebSockets
  59   ( ServerApp,
  60   )
  61 import Servant
  62   ( (:<|>) (..),
  63     (:>),
  64     Accept (..),
  65     Get,
  66     JSON,
  67     MimeRender (..),
  68     PlainText,
  69     Post,
  70     ReqBody,
  71     ServerT,
  72   )
  73 import Prelude
  74
  75 -- | Represents possible GraphQL queries.
  76 data Query m
  77   = Query
  78     { user :: UserArgs -> m UserLight
  79     } deriving (Generic, GQLType)
  80
  81 -- | Arguments to the "user" query.
  82 data UserArgs
  83   = UserArgs
  84     { user_id :: Int
  85     } deriving (Generic, GQLType)
  86
  87 -- | Possible GraphQL Events, i.e. here we describe how we will
  88 -- manipulate the data.
  89 type EVENT = Event Channel Contet
  90
  91 -- | Channels are possible actions to call when manipulating the data.
  92 data Channel
  93   = Update
  94   | New
  95   deriving (Eq, Show, Generic, Hashable)
  96
  97 -- | This type describes what data we will operate on.
  98 data Contet
  99   = UserContet UserLight
 100
 101
 102 -- | The main GraphQL resolver: how queries, mutations and
 103 -- subscriptions are handled.
 104 rootResolver
 105   :: (HasConnectionPool env, HasConfig env)
 106   => RootResolver (GargM env GargError) EVENT Query Undefined Undefined
 107 rootResolver =
 108   RootResolver
 109     { queryResolver = Query { user = resolveUser }
 110     , mutationResolver = Undefined
 111     , subscriptionResolver = Undefined }
 112
 113 -- | Function to resolve user from a query.
 114 resolveUser
 115   :: (HasConnectionPool env, HasConfig env)
 116   => UserArgs -> ResolverQ e (GargM env GargError) UserLight
 117 resolveUser UserArgs { user_id } = do
 118   liftEither $ dbUser user_id
 119 --  user <- lift $ dbUser user_id
 120 --  case user of
 121 --    --Left err -> failure $ msg err
 122 --    Left err -> error "fail"
 123 --    Right u -> pure u
 124
 125 -- | Inner function to fetch the user from DB.
 126 dbUser :: Int -> Cmd err (Either String UserLight)
 127 dbUser user_id = do
 128   users <- getUsersWithId user_id
 129   case users of
 130     [] -> pure $ Left "User not found"
 131     (user:_) -> pure $ Right user
 132
 133 -- | Main GraphQL "app".
 134 app
 135   :: (Typeable env, HasConnectionPool env, HasConfig env)
 136   => App EVENT (GargM env GargError)
 137 app = deriveApp rootResolver
 138
 139 ----------------------------------------------
 140
 141 -- Now for some boilerplate to integrate the above GraphQL app with
 142 -- servant.
 143
 144 -- | HTML type is needed for the GraphQL Playground.
 145 data HTML deriving (Typeable)
 146 instance Accept HTML where
 147   contentTypes _ = "text" // "html" /: ("charset", "utf-8") :| ["text" // "html"]
 148 instance MimeRender HTML ByteString where
 149   mimeRender _ = Prelude.id
 150
 151 -- | Servant route for the app we defined above.
 152 type GQAPI = ReqBody '[JSON] GQLRequest :> Post '[JSON] GQLResponse
 153 -- type Schema = "schema" :> Get '[PlainText] Text
 154 -- | Servant route for the playground.
 155 type Playground = Get '[HTML] ByteString
 156 -- type API' (name :: Symbol) = name :> (GQAPI :<|> Schema :<|> Playground)
 157 -- | Our API consists of `GQAPI` and `Playground`.
 158 type API = "gql" :> (GQAPI :<|> Playground)
 159
 160 -- serveEndpoint ::
 161 --   ( SubApp ServerApp e
 162 --   , PubApp e
 163 --   ) =>
 164 --   [e -> IO ()] ->
 165 --   App e IO ->
 166 --   Server (API name)
 167 -- serveEndpoint publish app' = (liftIO . httpPubApp publish app') :<|> withSchema app' :<|> pure httpPlayground
 168 --
 169 -- withSchema :: (Applicative f) => App e m -> f Text
 170 -- withSchema = pure . LT.toStrict . decodeUtf8 . render
 171
 172 -- | Implementation of our API.
 173 --api :: Server API
 174 api
 175   :: (Typeable env, HasConnectionPool env, HasConfig env)
 176   => ServerT API (GargM env GargError)
 177 api = httpPubApp [] app :<|> pure httpPlayground