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 (GargServer)
  52 import Gargantext.Database.Prelude (Cmd)
  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     Server,
  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 :: RootResolver _ EVENT Query Undefined Undefined
 105 rootResolver =
 106   RootResolver
 107     { queryResolver = Query { user = resolveUser }
 108     , mutationResolver = Undefined
 109     , subscriptionResolver = Undefined }
 110
 111 -- | Function to resolve user from a query.
 112 resolveUser :: UserArgs -> ResolverQ e _ UserLight
 113 resolveUser UserArgs { user_id } = do
 114   liftEither $ dbUser user_id
 115 --  user <- lift $ dbUser user_id
 116 --  case user of
 117 --    --Left err -> failure $ msg err
 118 --    Left err -> error "fail"
 119 --    Right u -> pure u
 120
 121 -- | Inner function to fetch the user from DB.
 122 dbUser :: Int -> Cmd err (Either String UserLight)
 123 dbUser user_id = do
 124   users <- getUsersWithId user_id
 125   case users of
 126     [] -> pure $ Left "User not found"
 127     (user:_) -> pure $ Right user
 128
 129 -- | Main GraphQL "app".
 130 app :: App EVENT _
 131 app = deriveApp rootResolver
 132
 133 ----------------------------------------------
 134
 135 -- Now for some boilerplate to integrate the above GraphQL app with
 136 -- servant.
 137
 138 -- | HTML type is needed for the GraphQL Playground.
 139 data HTML deriving (Typeable)
 140 instance Accept HTML where
 141   contentTypes _ = "text" // "html" /: ("charset", "utf-8") :| ["text" // "html"]
 142 instance MimeRender HTML ByteString where
 143   mimeRender _ = Prelude.id
 144
 145 -- | Servant route for the app we defined above.
 146 type GQAPI = ReqBody '[JSON] GQLRequest :> Post '[JSON] GQLResponse
 147 -- type Schema = "schema" :> Get '[PlainText] Text
 148 -- | Servant route for the playground.
 149 type Playground = Get '[HTML] ByteString
 150 -- type API' (name :: Symbol) = name :> (GQAPI :<|> Schema :<|> Playground)
 151 -- | Our API consists of `GQAPI` and `Playground`.
 152 type API = "gql" :> (GQAPI :<|> Playground)
 153
 154 -- serveEndpoint ::
 155 --   ( SubApp ServerApp e
 156 --   , PubApp e
 157 --   ) =>
 158 --   [e -> IO ()] ->
 159 --   App e IO ->
 160 --   Server (API name)
 161 -- serveEndpoint publish app' = (liftIO . httpPubApp publish app') :<|> withSchema app' :<|> pure httpPlayground
 162 --
 163 -- withSchema :: (Applicative f) => App e m -> f Text
 164 -- withSchema = pure . LT.toStrict . decodeUtf8 . render
 165
 166 -- | Implementation of our API.
 167 --api :: Server API
 168 api :: GargServer API
 169 api = do
 170   --(wsApp, publish') <- liftIO $ webSocketsApp app
 171   --(liftIO . httpPubApp [] app) :<|> pure httpPlayground
 172   (liftBase . httpPubApp [] app) :<|> pure httpPlayground