[graphql] initial, dummy user endpoint

package.yaml

@@ -170,6 +170,8 @@ library:
   - matrix
   - monad-control
   - monad-logger
+  - morpheus-graphql
+  - morpheus-graphql-subscriptions
   - mtl
   - natural-transformation
   - opaleye
@@ -237,7 +239,9 @@ library:
   - wai-app-static
   - wai-cors
   - wai-extra
+  - wai-websockets
   - warp
+  - websockets
   - wreq
   - xml-conduit
   - xml-types

src/Gargantext/API/GraphQL.hs

+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}  -- permit duplications for field names in multiple constructors
+{-# LANGUAGE KindSignatures #-}  -- for use of Endpoint (name :: Symbol)
+{-# LANGUAGE TypeOperators #-}
+
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+
+module Gargantext.API.GraphQL where
+
+import Data.Morpheus
+  ( App
+  , deriveApp )
+import Data.Morpheus.Subscriptions
+  ( Event (..)
+  , Hashable
+  , webSocketsApp
+  )
+import Data.Morpheus.Types
+  ( GQLType
+  -- , ResolverM
+  , ResolverQ
+  , RootResolver (..)
+  , publish
+  -- , subscribe
+  )
+import Data.Text (Text)
+import GHC.Generics (Generic)
+
+import Control.Monad.IO.Class (liftIO)
+import Data.ByteString.Lazy.Char8
+  ( ByteString
+  )
+import Data.List.NonEmpty (NonEmpty ((:|)))
+import Data.Morpheus.Server
+  ( httpPlayground
+  )
+import Data.Morpheus.Subscriptions
+  ( PubApp
+  , SubApp
+  , httpPubApp
+  )
+import Data.Morpheus.Types
+  ( -- App
+    GQLRequest
+  , GQLResponse
+  , Undefined (..)
+  , liftEither
+  , render
+  )
+-- import Data.Proxy (Proxy)
+-- import Data.Text (Text)
+import qualified Data.Text.Lazy as LT
+import Data.Text.Lazy.Encoding (decodeUtf8)
+import Data.Typeable (Typeable)
+import GHC.TypeLits
+import Network.HTTP.Media ((//), (/:))
+-- import Network.Wai.Handler.Warp
+--   ( defaultSettings,
+--     runSettings,
+--     setPort,
+--   )
+-- import Network.Wai.Handler.WebSockets
+--   ( websocketsOr,
+--   )
+import Network.WebSockets
+  ( ServerApp,
+--    defaultConnectionOptions,
+  )
+import Servant
+  ( (:<|>) (..),
+    (:>),
+    Accept (..),
+    Get,
+--    HasServer,
+    JSON,
+    MimeRender (..),
+    PlainText,
+    Post,
+    ReqBody,
+    Server,
+--    serve,
+  )
+import Prelude
+
+import qualified Data.Swagger as Swagger
+import Gargantext.Database.Prelude (Cmd)
+
+type EVENT = Event Channel Contet
+
+data Query m
+  = Query
+    { user :: UserArgs -> m User
+    } deriving (Generic, GQLType)
+
+data Channel
+  = Update
+  | New
+  deriving (Eq, Show, Generic, Hashable)
+
+data Contet
+  = UserContet User
+data User
+  = User
+    { name    :: Text
+    , user_id :: Int
+    } deriving (Generic, GQLType)
+
+data UserArgs
+  = UserArgs
+    { name :: Text
+    } deriving (Generic, GQLType)
+
+resolveUser :: UserArgs -> ResolverQ e IO User
+resolveUser UserArgs { name } = liftEither $ dbUser name
+
+dbUser :: Text -> IO (Either String User)
+dbUser name = pure $ Right $ User { name, user_id = 1 }
+
+rootResolver :: RootResolver IO EVENT Query Undefined Undefined
+rootResolver =
+  RootResolver
+    { queryResolver = Query { user = resolveUser }
+    , mutationResolver = Undefined
+    , subscriptionResolver = Undefined }
+
+app :: App EVENT IO
+app = deriveApp rootResolver
+
+----------------------------------------------
+
+data HTML deriving (Typeable)
+instance Accept HTML where
+  contentTypes _ = "text" // "html" /: ("charset", "utf-8") :| ["text" // "html"]
+instance MimeRender HTML ByteString where
+  mimeRender _ = id
+
+type GQAPI = ReqBody '[JSON] GQLRequest :> Post '[JSON] GQLResponse
+type Schema = "schema" :> Get '[PlainText] Text
+type Playground = Get '[HTML] ByteString
+type API' (name :: Symbol) = name :> (GQAPI :<|> Schema :<|> Playground)
+type API = "gql" :> (GQAPI :<|> Playground)
+
+-- serveEndpoint ::
+--   ( SubApp ServerApp e
+--   , PubApp e
+--   ) =>
+--   [e -> IO ()] ->
+--   App e IO ->
+--   Server (API name)
+-- serveEndpoint publish app' = (liftIO . httpPubApp publish app') :<|> withSchema app' :<|> pure httpPlayground
+-- 
+-- withSchema :: (Applicative f) => App e m -> f Text
+-- withSchema = pure . LT.toStrict . decodeUtf8 . render
+
+api :: Server API
+api = do
+  --(wsApp, publish') <- liftIO $ webSocketsApp app
+  (liftIO . httpPubApp [] app) :<|> pure httpPlayground

src/Gargantext/API/Routes.hs

@@ -44,6 +44,7 @@ import Gargantext.API.Admin.Auth.Types (AuthRequest, AuthResponse, Authenticated
 import Gargantext.API.Admin.Auth (withAccess)
 import Gargantext.API.Admin.FrontEnd (FrontEndAPI)
 import Gargantext.API.Count  (CountAPI, count, Query)
+import qualified Gargantext.API.GraphQL as GraphQL
 import Gargantext.API.Job (jobLogInit)
 import Gargantext.API.Ngrams (TableNgramsApi, apiNgramsTableDoc)
 import Gargantext.API.Node
@@ -167,7 +168,6 @@ type GargPrivateAPI' =
            :<|> List.GETAPI
            :<|> List.JSONAPI
            :<|> List.CSVAPI
-
 {-
            :<|> "wait"   :> Summary "Wait test"
                          :> Capture "x" Int
@@ -184,6 +184,7 @@ type GargPrivateAPI' =
 
 type API = SwaggerAPI
        :<|> GargAPI
+       :<|> GraphQL.API
        :<|> FrontEndAPI
 
 -- | API for serving @swagger.json@

src/Gargantext/API/Server.hs

@@ -29,6 +29,7 @@ import qualified Gargantext.API.Public      as Public
 import Gargantext.API.Admin.Auth.Types (AuthContext)
 import Gargantext.API.Admin.Auth (auth)
 import Gargantext.API.Admin.FrontEnd (frontEndServer)
+import qualified Gargantext.API.GraphQL as GraphQL
 import Gargantext.API.Prelude
 import Gargantext.API.Routes
 import Gargantext.API.Swagger (swaggerDoc)
@@ -61,6 +62,7 @@ server env = do
             (Proxy :: Proxy AuthContext)
             transform
             (serverGargAPI (env ^. hasConfig . gc_url_backend_api))
+     :<|> GraphQL.api
      :<|> frontEndServer
   where
     transform :: forall a. GargM env GargError a -> Handler a

src/Gargantext/API/ThrowAll.hs

@@ -10,6 +10,7 @@ Portability : POSIX
 -}
 
 {-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MonoLocalBinds         #-}
 {-# LANGUAGE TypeOperators          #-}
 {-# LANGUAGE UndecidableInstances   #-}