[graphql] (does not compile) attempt to lift to GargServer

package.yaml

@@ -171,6 +171,8 @@ library:
   - monad-control
   - monad-logger
   - morpheus-graphql
+  - morpheus-graphql-app
+  - morpheus-graphql-core
   - morpheus-graphql-subscriptions
   - mtl
   - natural-transformation

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 PartialTypeSignatures #-}  -- to automatically use suggested type hole signatures during compilation
 {-# LANGUAGE TypeOperators #-}
 
 {-# OPTIONS_GHC -fno-warn-unused-imports #-}
 
 module Gargantext.API.GraphQL where
 
+import Control.Monad.Base (liftBase)
 import Control.Monad.IO.Class (liftIO)
 import Data.ByteString.Lazy.Char8
   ( ByteString
@@ -15,6 +17,8 @@ import Data.List.NonEmpty (NonEmpty ((:|)))
 import Data.Morpheus
   ( App
   , deriveApp )
+import Data.Morpheus.App.Internal.Resolving
+  ( failure )
 import Data.Morpheus.Server
   ( httpPlayground
   )
@@ -32,15 +36,22 @@ import Data.Morpheus.Types
   , GQLType
   , ResolverQ
   , RootResolver(..)
-  , Undefined
+  , Undefined(..)
+  , lift
   , liftEither
   , publish
   , render
   )
+import Data.Morpheus.Types.Internal.AST
+  ( msg )
 import Data.Text (Text)
 import qualified Data.Text.Lazy as LT
 import Data.Text.Lazy.Encoding (decodeUtf8)
 import Data.Typeable (Typeable)
+import Gargantext.API.Prelude (GargServer)
+import Gargantext.Database.Prelude (Cmd)
+import Gargantext.Database.Query.Table.User (getUsersWithId)
+import Gargantext.Database.Schema.User (UserPoly(..), UserLight)
 import GHC.Generics (Generic)
 import GHC.TypeLits
 import Network.HTTP.Media ((//), (/:))
@@ -60,25 +71,17 @@ import Servant
     Server,
   )
 import Prelude
-import Gargantext.Database.Prelude (Cmd)
-
--- | Our simple datatype.
-data User
-  = User
-    { name    :: Text
-    , user_id :: Int
-    } deriving (Generic, GQLType)
 
 -- | Represents possible GraphQL queries.
 data Query m
   = Query
-    { user :: UserArgs -> m User
+    { user :: UserArgs -> m UserLight
     } deriving (Generic, GQLType)
 
 -- | Arguments to the "user" query.
 data UserArgs
   = UserArgs
-    { name :: Text
+    { user_id :: Int
     } deriving (Generic, GQLType)
 
 -- | Possible GraphQL Events, i.e. here we describe how we will
@@ -93,12 +96,12 @@ data Channel
 
 -- | This type describes what data we will operate on.
 data Contet
-  = UserContet User
+  = UserContet UserLight
 
 
 -- | The main GraphQL resolver: how queries, mutations and
 -- subscriptions are handled.
-rootResolver :: RootResolver IO EVENT Query Undefined Undefined
+rootResolver :: RootResolver _ EVENT Query Undefined Undefined
 rootResolver =
   RootResolver
     { queryResolver = Query { user = resolveUser }
@@ -106,15 +109,25 @@ rootResolver =
     , subscriptionResolver = Undefined }
 
 -- | Function to resolve user from a query.
-resolveUser :: UserArgs -> ResolverQ e IO User
-resolveUser UserArgs { name } = liftEither $ dbUser name
+resolveUser :: UserArgs -> ResolverQ e _ UserLight
+resolveUser UserArgs { user_id } = do
+  liftEither $ dbUser user_id
+--  user <- lift $ dbUser user_id
+--  case user of
+--    --Left err -> failure $ msg err
+--    Left err -> error "fail"
+--    Right u -> pure u
 
 -- | Inner function to fetch the user from DB.
-dbUser :: Text -> IO (Either String User)
-dbUser name = pure $ Right $ User { name, user_id = 1 }
+dbUser :: Int -> Cmd err (Either String UserLight)
+dbUser user_id = do
+  users <- getUsersWithId user_id
+  case users of
+    [] -> pure $ Left "User not found"
+    (user:_) -> pure $ Right user
 
 -- | Main GraphQL "app".
-app :: App EVENT IO
+app :: App EVENT _
 app = deriveApp rootResolver
 
 ----------------------------------------------
@@ -127,7 +140,7 @@ data HTML deriving (Typeable)
 instance Accept HTML where
   contentTypes _ = "text" // "html" /: ("charset", "utf-8") :| ["text" // "html"]
 instance MimeRender HTML ByteString where
-  mimeRender _ = id
+  mimeRender _ = Prelude.id
 
 -- | Servant route for the app we defined above.
 type GQAPI = ReqBody '[JSON] GQLRequest :> Post '[JSON] GQLResponse
@@ -151,7 +164,9 @@ type API = "gql" :> (GQAPI :<|> Playground)
 -- withSchema = pure . LT.toStrict . decodeUtf8 . render
 
 -- | Implementation of our API.
-api :: Server API
+--api :: Server API
+api :: GargServer API
 api = do
   --(wsApp, publish') <- liftIO $ webSocketsApp app
-  (liftIO . httpPubApp [] app) :<|> pure httpPlayground
+  --(liftIO . httpPubApp [] app) :<|> pure httpPlayground
+  (liftBase . httpPubApp [] app) :<|> pure httpPlayground

src/Gargantext/API/Server.hs

@@ -62,7 +62,11 @@ server env = do
             (Proxy :: Proxy AuthContext)
             transform
             (serverGargAPI (env ^. hasConfig . gc_url_backend_api))
-     :<|> GraphQL.api
+     :<|> hoistServerWithContext
+            (Proxy :: Proxy GraphQL.API)
+            (Proxy :: Proxy AuthContext)
+            transform
+            GraphQL.api
      :<|> frontEndServer
   where
     transform :: forall a. GargM env GargError a -> Handler a

src/Gargantext/Database/Schema/User.hs

@@ -13,12 +13,14 @@ Functions to deal with users, database side.
 
 {-# OPTIONS_GHC -fno-warn-orphans        #-}
 
+{-# LANGUAGE DeriveAnyClass              #-}
 {-# LANGUAGE FunctionalDependencies      #-}
 {-# LANGUAGE Arrows                      #-}
-{-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE TemplateHaskell             #-}
 
 module Gargantext.Database.Schema.User where
 
+import Data.Morpheus.Types (GQLType)
 import Data.Text (Text)
 import Data.Time (UTCTime)
 import Gargantext.Prelude
@@ -41,7 +43,7 @@ data UserLight = UserLight { userLight_id       :: !Int
                            , userLight_username :: !Text
                            , userLight_email    :: !Text
                            , userLight_password :: !Text
-                           } deriving (Show, Generic)
+                           } deriving (Show, Generic, GQLType)
 
 toUserLight :: UserDB -> UserLight
 toUserLight (UserDB id p _ _ u _ _ e _ _ _ ) = UserLight id u e p