Merge branch 'dev-merge' into dev

README.md

@@ -196,3 +196,36 @@ To build documentation, run:
 stack --docker build --haddock --no-haddock-deps --fast
 ```
 
+## GraphQL
+
+Some introspection information.
+
+Playground is located at http://localhost:8008/gql
+
+### List all GraphQL types in the Playground
+
+```
+{
+  __schema {
+    types {
+      name
+    }
+  }
+}
+```
+
+### List details about a type in GraphQL
+
+```
+{
+  __type(name:"User") {
+  	fields {
+    	name
+      description
+      type {
+        name
+      }
+  	}
+	}
+}
+```

package.yaml

@@ -181,6 +181,10 @@ library:
   - matrix
   - monad-control
   - monad-logger
+  - morpheus-graphql
+  - morpheus-graphql-app
+  - morpheus-graphql-core
+  - morpheus-graphql-subscriptions
   - mtl
   - natural-transformation
   - opaleye
@@ -249,7 +253,9 @@ library:
   - wai-app-static
   - wai-cors
   - wai-extra
+  - wai-websockets
   - warp
+  - websockets
   - wreq
   - xml-conduit
   - xml-types

src/Gargantext/API.hs

@@ -193,8 +193,7 @@ serverGargAdminAPI =  roots
 --gargMock = mock apiGarg Proxy
 ---------------------------------------------------------------------
 
-
-makeApp :: EnvC env => env -> IO Application
+makeApp :: (Typeable env, EnvC env) => env -> IO Application
 makeApp env = do
   serv <- server env
   (ekgStore, ekgMid) <- newEkgStore api

src/Gargantext/API/Admin/Orchestrator/Types.hs

@@ -7,6 +7,9 @@ module Gargantext.API.Admin.Orchestrator.Types
 
 import Control.Lens hiding (elements)
 import Data.Aeson
+import Data.Morpheus.Types
+  ( GQLType
+  , typeOptions )
 import Data.Proxy
 import Data.Swagger hiding (URL, url, port)
 import Data.Text (Text)
@@ -18,6 +21,7 @@ import Servant.Job.Utils (jsonOptions)
 import Test.QuickCheck (elements)
 import Test.QuickCheck.Arbitrary
 
+import qualified Gargantext.API.GraphQL.Utils as GQLU
 import Gargantext.Core.Types (TODO(..))
 import Gargantext.Prelude
 
@@ -84,13 +88,13 @@ instance Arbitrary ScraperEvent where
   arbitrary = ScraperEvent <$> elements [Nothing, Just "test message"]
                            <*> elements [Nothing, Just "INFO", Just "WARN"]
                            <*> elements [Nothing, Just "2018-04-18"]
-
 instance ToJSON ScraperEvent where
   toJSON = genericToJSON $ jsonOptions "_scev_"
-
 instance FromJSON ScraperEvent where
   parseJSON = genericParseJSON $ jsonOptions "_scev_"
-
+instance ToSchema ScraperEvent  -- TODO _scev_ prefix
+instance GQLType ScraperEvent where
+  typeOptions _ = GQLU.unPrefix "_scev_"
 
 
 data JobLog = JobLog
@@ -109,17 +113,15 @@ instance Arbitrary JobLog where
            <*> arbitrary
            <*> arbitrary
            <*> arbitrary
-
 instance ToJSON JobLog where
   toJSON = genericToJSON $ jsonOptions "_scst_"
-
 instance FromJSON JobLog where
   parseJSON = genericParseJSON $ jsonOptions "_scst_"
-
 instance ToSchema JobLog -- TODO _scst_ prefix
+instance GQLType JobLog where
+  typeOptions _ = GQLU.unPrefix "_scst_"
 
 instance ToSchema ScraperInput  -- TODO _scin_ prefix
-instance ToSchema ScraperEvent  -- TODO _scev_ prefix
 
 instance ToParamSchema Offset -- where
   -- toParamSchema = panic "TODO"

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 #-}
+
+module Gargantext.API.GraphQL where
+
+import Data.ByteString.Lazy.Char8
+  ( ByteString
+  )
+import Data.List.NonEmpty (NonEmpty ((:|)))
+import Data.Map (Map)
+import Data.Morpheus
+  ( App
+  , deriveApp )
+import Data.Morpheus.Server
+  ( httpPlayground
+  )
+import Data.Morpheus.Subscriptions
+  ( Event (..)
+  , Hashable
+  , httpPubApp
+  )
+import Data.Morpheus.Types
+  ( GQLRequest
+  , GQLResponse
+  , GQLType
+  , RootResolver(..)
+  , Undefined(..)
+  )
+import Gargantext.API.Admin.Auth.Types (AuthenticatedUser)
+import Gargantext.API.Admin.Orchestrator.Types (JobLog)
+import Gargantext.API.Prelude (HasJobEnv')
+import qualified Gargantext.API.GraphQL.AsyncTask as GQLAT
+import qualified Gargantext.API.GraphQL.Node as GQLNode
+import qualified Gargantext.API.GraphQL.User as GQLUser
+import qualified Gargantext.API.GraphQL.UserInfo as GQLUserInfo
+import Gargantext.API.Prelude (GargM, GargError)
+import Gargantext.Core.Mail.Types (HasMail)
+import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
+import Gargantext.Prelude
+import GHC.Generics (Generic)
+import Network.HTTP.Media ((//), (/:))
+import qualified Prelude as Prelude
+import Servant
+  ( (:<|>) (..)
+  , (:>)
+  , Accept (..)
+  , Get
+  , JSON
+  , MimeRender (..)
+  , Post
+  , ReqBody
+  ,  ServerT
+  )
+import qualified Servant.Auth as SA
+import qualified Servant.Auth.Server as SAS
+
+-- | Represents possible GraphQL queries.
+data Query m
+  = Query
+    { job_logs    :: GQLAT.JobLogArgs -> m (Map Int JobLog)
+    , nodes       :: GQLNode.NodeArgs -> m [GQLNode.Node]
+    , node_parent :: GQLNode.NodeParentArgs -> m [GQLNode.Node]
+    , user_infos  :: GQLUserInfo.UserInfoArgs -> m [GQLUserInfo.UserInfo]
+    , users       :: GQLUser.UserArgs -> m [GQLUser.User m]
+    } deriving (Generic, GQLType)
+
+data Mutation m
+  = Mutation
+    { update_user_info :: GQLUserInfo.UserInfoMArgs -> m Int }
+    deriving (Generic, GQLType)
+
+-- | Possible GraphQL Events, i.e. here we describe how we will
+-- manipulate the data.
+type EVENT m = Event Channel (Contet m)
+
+-- | Channels are possible actions to call when manipulating the data.
+data Channel
+  = Update
+  | New
+  deriving (Eq, Show, Generic, Hashable)
+
+-- | This type describes what data we will operate on.
+data Contet m
+  = UserContet [GQLUser.User m]
+  | UserInfoContet [GQLUserInfo.UserInfo]
+
+-- | The main GraphQL resolver: how queries, mutations and
+-- subscriptions are handled.
+rootResolver
+  :: (HasConnectionPool env, HasConfig env, HasMail env, HasJobEnv' env)
+  => RootResolver (GargM env GargError) e Query Mutation Undefined
+rootResolver =
+  RootResolver
+    { queryResolver = Query { job_logs    = GQLAT.resolveJobLogs
+                            , nodes       = GQLNode.resolveNodes
+                            , node_parent = GQLNode.resolveNodeParent
+                            , user_infos  = GQLUserInfo.resolveUserInfos
+                            , users       = GQLUser.resolveUsers }
+    , mutationResolver = Mutation { update_user_info = GQLUserInfo.updateUserInfo }
+    , subscriptionResolver = Undefined }
+
+-- | Main GraphQL "app".
+app
+  :: (Typeable env, HasConnectionPool env, HasConfig env, HasMail env, HasJobEnv' env)
+  => App (EVENT (GargM env GargError)) (GargM env GargError)
+app = deriveApp rootResolver
+
+----------------------------------------------
+
+-- Now for some boilerplate to integrate the above GraphQL app with
+-- servant.
+
+-- | HTML type is needed for the GraphQL Playground.
+data HTML deriving (Typeable)
+instance Accept HTML where
+  contentTypes _ = "text" // "html" /: ("charset", "utf-8") :| ["text" // "html"]
+instance MimeRender HTML ByteString where
+  mimeRender _ = Prelude.id
+
+-- | Servant route for the app we defined above.
+type GQAPI = ReqBody '[JSON] GQLRequest :> Post '[JSON] GQLResponse
+-- type Schema = "schema" :> Get '[PlainText] Text
+-- | Servant route for the playground.
+type Playground = Get '[HTML] ByteString
+-- type API' (name :: Symbol) = name :> (GQAPI :<|> Schema :<|> Playground)
+-- | Our API consists of `GQAPI` and `Playground`.
+type API = SA.Auth '[SA.JWT, SA.Cookie] AuthenticatedUser
+            :> "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
+
+-- | Implementation of our API.
+--api :: Server API
+api
+  :: (Typeable env, HasConnectionPool env, HasConfig env, HasMail env, HasJobEnv' env)
+  => ServerT API (GargM env GargError)
+api (SAS.Authenticated _auser) = httpPubApp [] app :<|> pure httpPlayground
+api _                          = panic "401 in graphql" --SAS.throwAll (_ServerError # err401)
+--api _ = httpPubApp [] app :<|> pure httpPlayground

src/Gargantext/API/GraphQL/AsyncTask.hs

+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
+module Gargantext.API.GraphQL.AsyncTask where
+
+import Control.Concurrent.Async (poll)
+import Control.Concurrent.MVar (readMVar)
+import Control.Lens
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Control.Monad.Base (liftBase)
+import Control.Monad.Reader (ask, liftIO)
+import Data.Either (Either(..))
+import qualified Data.IntMap.Strict as IntMap
+import Data.Maybe (Maybe(..), catMaybes)
+import Data.Morpheus.Types
+  ( GQLType
+  , Resolver
+  , ResolverM
+  , QUERY
+  , lift
+  )
+import Data.Text (Text)
+import qualified Data.Text as T
+import Gargantext.API.Admin.Orchestrator.Types (JobLog(..))
+import Gargantext.API.Prelude (GargM, GargError, HasJobEnv')
+import Gargantext.Core.Mail.Types (HasMail)
+import Gargantext.Database.Admin.Types.Node (NodeId(..))
+import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
+import Gargantext.Prelude
+import GHC.Generics (Generic)
+import Servant.Job.Async (HasJobEnv(job_env), jenv_jobs, job_async)
+import Servant.Job.Core (env_item, env_map, env_state_mvar)
+
+data JobLogArgs
+  = JobLogArgs
+    { job_log_id :: Int
+    } deriving (Generic, GQLType)
+
+type GqlM e env = Resolver QUERY e (GargM env GargError)
+
+resolveJobLogs
+  :: (HasConnectionPool env, HasConfig env, HasJobEnv' env)
+  => JobLogArgs -> GqlM e env (Map Int JobLog)
+resolveJobLogs JobLogArgs { job_log_id } = dbJobLogs job_log_id
+
+dbJobLogs
+  :: (HasConnectionPool env, HasConfig env, HasJobEnv' env)
+  => Int -> GqlM e env (Map Int JobLog)
+dbJobLogs job_log_id = do
+  --getJobLogs job_log_id
+  lift $ do
+    env <- ask
+    --val <- liftBase $ readMVar $ env ^. job_env . jenv_jobs . env_state_mvar
+    var <- liftIO $ readMVar (env ^. job_env . jenv_jobs . env_state_mvar)
+    let envItems = var ^. env_map
+    printDebug "[dbJobLogs] env ^. job_env ^. jenv_jobs" $ length $ IntMap.keys envItems
+    printDebug "[dbJobLogs] job_log_id" job_log_id
+    --pure $ IntMap.elems val
+    liftIO $ do
+      let jobsList = IntMap.toList $ IntMap.map (\e -> e ^. env_item . job_async) envItems
+      results <- mapM (\(k, v) -> do
+                          p <- poll v
+                          let kv = case p of
+                                Nothing -> Nothing
+                                Just p' -> case p' of
+                                  Left _ -> Nothing
+                                  Right p'' -> Just (k, p'')
+                          pure kv) jobsList
+      pure $ Map.fromList $ catMaybes results

src/Gargantext/API/GraphQL/Node.hs

+
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
+module Gargantext.API.GraphQL.Node where
+
+import Data.Morpheus.Types
+  ( GQLType
+  , Resolver
+  , QUERY
+  , lift
+  )
+import Data.Text (Text)
+import Gargantext.API.Prelude (GargM, GargError)
+import Gargantext.Core.Mail.Types (HasMail)
+import Gargantext.Database.Admin.Config (fromNodeTypeId)
+import Gargantext.Database.Admin.Types.Node (NodeId(..))
+import qualified Gargantext.Database.Admin.Types.Node as NN
+import Gargantext.Database.Query.Table.Node (getClosestParentIdByType, getNode)
+import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
+import qualified Gargantext.Database.Schema.Node as N
+import Gargantext.Prelude
+import GHC.Generics (Generic)
+
+data Node = Node
+  { id        :: Int
+  , name      :: Text
+  , parent_id :: Maybe Int
+  , type_id   :: Int
+  } deriving (Show, Generic, GQLType)
+
+data NodeArgs
+  = NodeArgs
+    { node_id        :: Int
+    } deriving (Generic, GQLType)
+
+type GqlM e env = Resolver QUERY e (GargM env GargError)
+
+-- | Function to resolve user from a query.
+resolveNodes
+  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  => NodeArgs -> GqlM e env [Node]
+resolveNodes NodeArgs { node_id } = dbNodes node_id
+
+dbNodes
+  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  => Int -> GqlM e env [Node]
+dbNodes node_id = do
+  node <- lift $ getNode $ NodeId node_id
+  pure [toNode node]
+
+data NodeParentArgs
+  = NodeParentArgs
+    { node_id        :: Int
+    , parent_type_id :: Int
+    } deriving (Generic, GQLType)
+
+resolveNodeParent
+  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  => NodeParentArgs -> GqlM e env [Node]
+resolveNodeParent NodeParentArgs { node_id, parent_type_id } = dbParentNodes node_id parent_type_id
+
+dbParentNodes
+  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  => Int -> Int -> GqlM e env [Node]
+dbParentNodes node_id parent_type_id = do
+  mNodeId <- lift $ getClosestParentIdByType (NodeId node_id) (fromNodeTypeId parent_type_id)
+  case mNodeId of
+    Nothing -> pure []
+    Just id -> do
+      node <- lift $ getNode id
+      pure [toNode node]
+
+toNode :: NN.Node json -> Node
+toNode (N.Node { .. }) = Node { id = NN.unNodeId _node_id
+                              , name = _node_name
+                              , parent_id = NN.unNodeId <$> _node_parent_id
+                              , type_id = _node_typename }

src/Gargantext/API/GraphQL/User.hs

+{-# LANGUAGE DeriveAnyClass #-}
+
+module Gargantext.API.GraphQL.User where
+
+import Data.Maybe (listToMaybe)
+import Data.Morpheus.Types
+  ( GQLType
+  , Resolver, QUERY
+  , lift
+  )
+import Data.Text (Text)
+import Gargantext.API.Prelude (GargM, GargError)
+import Gargantext.Core.Mail.Types (HasMail)
+import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser(..))
+import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
+import Gargantext.Database.Query.Table.User (getUsersWithId, getUserHyperdata)
+import Gargantext.Database.Schema.User (UserLight(..))
+import Gargantext.Prelude
+import GHC.Generics (Generic)
+
+data User m = User
+  { u_email     :: Text
+  , u_hyperdata :: m (Maybe HyperdataUser)
+  , u_id        :: Int
+  , u_username  :: Text }
+  deriving (Generic, GQLType)
+
+-- | Arguments to the "user" query.
+data UserArgs
+  = UserArgs
+    { user_id :: Int
+    } deriving (Generic, GQLType)
+
+type GqlM e env = Resolver QUERY e (GargM env GargError)
+
+-- | Function to resolve user from a query.
+resolveUsers
+  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  => UserArgs -> GqlM e env [User (GqlM e env)]
+resolveUsers UserArgs { user_id } = dbUsers user_id
+
+-- | Inner function to fetch the user from DB.
+dbUsers
+  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  => Int -> GqlM e env ([User (GqlM e env)])
+dbUsers user_id = lift (map toUser <$> getUsersWithId user_id)
+
+toUser
+  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  => UserLight -> User (GqlM e env)
+toUser (UserLight { .. }) = User { u_email = userLight_email
+                                 , u_hyperdata = resolveHyperdata userLight_id
+                                 , u_id = userLight_id
+                                 , u_username = userLight_username }
+
+resolveHyperdata
+  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  => Int -> GqlM e env (Maybe HyperdataUser)
+resolveHyperdata userid = lift (listToMaybe <$> getUserHyperdata userid)

src/Gargantext/API/GraphQL/UserInfo.hs

+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
+module Gargantext.API.GraphQL.UserInfo where
+
+import Control.Lens
+import Data.Morpheus.Types
+  ( GQLType
+  , Resolver
+  , ResolverM
+  , QUERY
+  , lift
+  )
+import Data.Text (Text)
+import qualified Data.Text as T
+import Gargantext.API.Prelude (GargM, GargError)
+import Gargantext.Core.Mail.Types (HasMail)
+import Gargantext.Database.Admin.Types.Hyperdata
+  ( HyperdataUser(..)
+  , hc_source
+  , hc_title
+  , hu_shared)
+import Gargantext.Database.Admin.Types.Hyperdata.Contact
+  ( HyperdataContact
+  , ContactWho
+  , ContactWhere
+  , cw_city
+  , cw_country
+  , cw_firstName
+  , cw_lastName
+  , cw_labTeamDepts
+  , cw_office
+  , cw_organization
+  , cw_role
+  , cw_touch
+  , ct_mail
+  , ct_phone
+  , hc_who
+  , hc_where)
+import Gargantext.Database.Admin.Types.Node (NodeId(..))
+import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
+import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
+import Gargantext.Database.Query.Table.User (getUsersWithHyperdata)
+import Gargantext.Database.Schema.User (UserLight(..))
+import Gargantext.Prelude
+import GHC.Generics (Generic)
+
+data UserInfo = UserInfo
+  { ui_id             :: Int
+  , ui_username       :: Text
+  , ui_email          :: Text
+  , ui_title          :: Maybe Text
+  , ui_source         :: Maybe Text
+  , ui_cwFirstName    :: Maybe Text
+  , ui_cwLastName     :: Maybe Text
+  , ui_cwCity         :: Maybe Text
+  , ui_cwCountry      :: Maybe Text
+  , ui_cwOrganization :: [Text]
+  , ui_cwLabTeamDepts :: [Text]
+  , ui_cwOffice       :: Maybe Text
+  , ui_cwRole         :: Maybe Text
+  , ui_cwTouchPhone   :: Maybe Text
+  , ui_cwTouchMail    :: Maybe Text }
+  deriving (Generic, GQLType, Show)
+
+-- | Arguments to the "user info" query.
+data UserInfoArgs
+  = UserInfoArgs
+    { user_id :: Int
+    } deriving (Generic, GQLType)
+
+-- | Arguments to the "user info" mutation,
+data UserInfoMArgs
+  = UserInfoMArgs
+    { ui_id :: Int
+    , ui_username       :: Maybe Text
+    , ui_email          :: Maybe Text
+    , ui_title          :: Maybe Text
+    , ui_source         :: Maybe Text
+    , ui_cwFirstName    :: Maybe Text
+    , ui_cwLastName     :: Maybe Text
+    , ui_cwCity         :: Maybe Text
+    , ui_cwCountry      :: Maybe Text
+    , ui_cwOrganization :: Maybe [Text]
+    , ui_cwLabTeamDepts :: Maybe [Text]
+    , ui_cwOffice       :: Maybe Text
+    , ui_cwRole         :: Maybe Text
+    , ui_cwTouchPhone   :: Maybe Text
+    , ui_cwTouchMail    :: Maybe Text 
+    } deriving (Generic, GQLType)
+
+type GqlM e env = Resolver QUERY e (GargM env GargError)
+
+-- | Function to resolve user from a query.
+resolveUserInfos
+  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  => UserInfoArgs -> GqlM e env [UserInfo]
+resolveUserInfos UserInfoArgs { user_id } = dbUsers user_id
+
+-- | Mutation for user info
+updateUserInfo
+  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  => UserInfoMArgs -> ResolverM e (GargM env GargError) Int
+updateUserInfo (UserInfoMArgs { ui_id, .. }) = do
+  lift $ printDebug "[updateUserInfo] ui_id" ui_id
+  users <- lift (getUsersWithHyperdata ui_id)
+  case users of
+    [] -> panic $ "[updateUserInfo] User with id " <> (T.pack $ show ui_id) <> " doesn't exist."
+    ((u, u_hyperdata):_) -> do
+      lift $ printDebug "[updateUserInfo] u" u
+      let u_hyperdata' = uh ui_titleL ui_title $
+                         uh ui_sourceL ui_source $
+                         uh ui_cwFirstNameL ui_cwFirstName $
+                         uh ui_cwLastNameL ui_cwLastName $
+                         uh ui_cwCityL ui_cwCity $
+                         uh ui_cwCountryL ui_cwCountry $
+                         uh' ui_cwLabTeamDeptsL ui_cwLabTeamDepts $
+                         uh' ui_cwOrganizationL ui_cwOrganization $
+                         uh ui_cwOfficeL ui_cwOffice $
+                         uh ui_cwRoleL ui_cwRole $
+                         uh ui_cwTouchMailL ui_cwTouchMail $
+                         uh ui_cwTouchPhoneL ui_cwTouchPhone $
+                         u_hyperdata
+      lift $ printDebug "[updateUserInfo] with firstName" u_hyperdata'
+      _ <- lift $ updateHyperdata (NodeId ui_id) u_hyperdata'
+      --let _newUser = toUser (u, u_hyperdata')
+      pure 1
+  where
+    uh _ Nothing u_hyperdata = u_hyperdata
+    uh lens' (Just val) u_hyperdata = u_hyperdata & lens' .~ Just val
+    uh' _ Nothing u_hyperdata = u_hyperdata
+    uh' lens' (Just val) u_hyperdata = u_hyperdata & lens' .~ val
+
+-- | Inner function to fetch the user from DB.
+dbUsers
+  :: (HasConnectionPool env, HasConfig env, HasMail env)
+  => Int -> GqlM e env [UserInfo]
+dbUsers user_id = do
+--  user <- getUsersWithId user_id
+--  hyperdata <- getUserHyperdata user_id
+--  lift (map toUser <$> zip user hyperdata)
+  lift (map toUser <$> (getUsersWithHyperdata user_id))
+
+toUser :: (UserLight, HyperdataUser) -> UserInfo
+toUser (UserLight { .. }, u_hyperdata) =
+  UserInfo { ui_id             = userLight_id
+           , ui_username       = userLight_username
+           , ui_email          = userLight_email
+           , ui_title          = u_hyperdata ^. ui_titleL
+           , ui_source         = u_hyperdata ^. ui_sourceL
+           , ui_cwFirstName    = u_hyperdata ^. ui_cwFirstNameL
+           , ui_cwLastName     = u_hyperdata ^. ui_cwLastNameL
+           , ui_cwCity         = u_hyperdata ^. ui_cwCityL
+           , ui_cwCountry      = u_hyperdata ^. ui_cwCountryL
+           , ui_cwLabTeamDepts = u_hyperdata ^. ui_cwLabTeamDeptsL
+           , ui_cwOrganization = u_hyperdata ^. ui_cwOrganizationL
+           , ui_cwOffice       = u_hyperdata ^. ui_cwOfficeL
+           , ui_cwRole         = u_hyperdata ^. ui_cwRoleL
+           , ui_cwTouchMail    = u_hyperdata ^. ui_cwTouchMailL
+           , ui_cwTouchPhone   = u_hyperdata ^. ui_cwTouchPhoneL }
+
+sharedL :: Traversal' HyperdataUser HyperdataContact
+sharedL = hu_shared . _Just
+ui_titleL :: Traversal' HyperdataUser (Maybe Text)
+ui_titleL = sharedL . hc_title
+ui_sourceL :: Traversal' HyperdataUser (Maybe Text)
+ui_sourceL = sharedL . hc_source
+contactWhoL :: Traversal' HyperdataUser ContactWho
+contactWhoL = sharedL . hc_who . _Just
+ui_cwFirstNameL :: Traversal' HyperdataUser (Maybe Text)
+ui_cwFirstNameL = contactWhoL . cw_firstName
+ui_cwLastNameL :: Traversal' HyperdataUser (Maybe Text)
+ui_cwLastNameL = contactWhoL . cw_lastName
+contactWhereL :: Traversal' HyperdataUser ContactWhere
+contactWhereL = sharedL . hc_where . (ix 0)
+ui_cwCityL :: Traversal' HyperdataUser (Maybe Text)
+ui_cwCityL = contactWhereL . cw_city
+ui_cwCountryL :: Traversal' HyperdataUser (Maybe Text)
+ui_cwCountryL = contactWhereL . cw_country
+ui_cwLabTeamDeptsL :: Traversal' HyperdataUser [Text]
+ui_cwLabTeamDeptsL = hu_shared . _Just . (hc_where . (ix 0) . cw_labTeamDepts)
+ui_cwOrganizationL :: Traversal' HyperdataUser [Text]
+ui_cwOrganizationL = hu_shared . _Just . (hc_where . (ix 0) . cw_organization)
+ui_cwOfficeL :: Traversal' HyperdataUser (Maybe Text)
+ui_cwOfficeL = contactWhereL . cw_office
+ui_cwRoleL :: Traversal' HyperdataUser (Maybe Text)
+ui_cwRoleL = contactWhereL . cw_role
+ui_cwTouchMailL :: Traversal' HyperdataUser (Maybe Text)
+ui_cwTouchMailL = hu_shared . _Just . (hc_where . (ix 0) . cw_touch . _Just . ct_mail)
+--ui_cwTouchMailL = contactWhereL . cw_touch . _Just . ct_mail
+ui_cwTouchPhoneL :: Traversal' HyperdataUser (Maybe Text)
+ui_cwTouchPhoneL = hu_shared . _Just . (hc_where . (ix 0) . cw_touch . _Just . ct_phone)
+--ui_cwTouchPhoneL = contactWhereL . cw_touch . _Just . ct_phone

src/Gargantext/API/GraphQL/Utils.hs

+module Gargantext.API.GraphQL.Utils where
+
+import Data.Morpheus.Types (GQLTypeOptions, fieldLabelModifier)
+import qualified Data.Text as T
+import Gargantext.Core.Utils.Prefix (unCapitalize, dropPrefix)
+import Gargantext.Prelude
+
+unPrefix :: T.Text -> GQLTypeOptions -> GQLTypeOptions
+unPrefix prefix options = options { fieldLabelModifier = nflm }
+  where
+    nflm label = unCapitalize $ dropPrefix (T.unpack prefix) $ ( fieldLabelModifier options ) label

src/Gargantext/API/Prelude.hs

@@ -50,6 +50,8 @@ class HasJoseError e where
 joseError :: (MonadError e m, HasJoseError e) => Jose.Error -> m a
 joseError = throwError . (_JoseError #)
 
+type HasJobEnv' env = HasJobEnv env JobLog JobLog
+
 type EnvC env =
   ( HasConnectionPool env
   , HasSettings       env  -- TODO rename HasDbSettings

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)
@@ -52,7 +53,7 @@ serverGargAPI baseUrl -- orchestrator
     gargVersion = pure (cs $ showVersion PG.version)
 
 -- | Server declarations
-server :: forall env. EnvC env => env -> IO (Server API)
+server :: forall env. (Typeable env, EnvC env) => env -> IO (Server API)
 server env = do
   -- orchestrator <- scrapyOrchestrator env
   pure $  swaggerSchemaUIServer swaggerDoc
@@ -61,6 +62,11 @@ server env = do
             (Proxy :: Proxy AuthContext)
             transform
             (serverGargAPI (env ^. hasConfig . gc_url_backend_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/API/ThrowAll.hs

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

src/Gargantext/Core.hs

@@ -9,14 +9,17 @@ Portability : POSIX
 
 -}
 
+{-# LANGUAGE DeriveAnyClass             #-}
+
 module Gargantext.Core
   where
 
-import Data.Text (Text)
 import Data.Aeson
 import Data.Either(Either(Left))
 import Data.Hashable (Hashable)
+import Data.Morpheus.Types (GQLType)
 import Data.Swagger
+import Data.Text (Text)
 import GHC.Generics (Generic)
 import Gargantext.Prelude
 import Servant.API
@@ -38,7 +41,7 @@ import Servant.API
 -- | All languages supported
 -- TODO : DE | SP | CH
 data Lang = EN | FR | All
-  deriving (Show, Eq, Ord, Bounded, Enum, Generic)
+  deriving (Show, Eq, Ord, Bounded, Enum, Generic, GQLType)
 
 instance ToJSON Lang
 instance FromJSON Lang

src/Gargantext/Database/Admin/Types/Hyperdata/Contact.hs

@@ -9,9 +9,10 @@ Portability : POSIX
 
 -}
 
-{-# LANGUAGE FunctionalDependencies     #-}
+{-# LANGUAGE DeriveAnyClass             #-}
 {-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FunctionalDependencies     #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
 {-# LANGUAGE NoImplicitPrelude          #-}
@@ -23,72 +24,90 @@ Portability : POSIX
 module Gargantext.Database.Admin.Types.Hyperdata.Contact
   where
 
+import Data.Morpheus.Types (GQLType(..))
 import Data.Time.Segment (jour)
-import Data.Time (UTCTime)
+import qualified Gargantext.API.GraphQL.Utils as GAGU
 import Gargantext.Core.Text (HasText(..))
 import Gargantext.Database.Admin.Types.Hyperdata.Prelude
 import Gargantext.Prelude
+import Gargantext.Utils.UTCTime
 
 --------------------------------------------------------------------------------
 data HyperdataContact =
-     HyperdataContact { _hc_bdd    :: Maybe Text           -- ID of Database source
-                      , _hc_who    :: Maybe ContactWho
-                      , _hc_where  :: [ContactWhere]
-                      , _hc_title  :: Maybe Text -- TODO remove (only demo)
-                      , _hc_source :: Maybe Text -- TODO remove (only demo)
-                      , _hc_lastValidation  :: Maybe Text -- TODO UTCTime
-                      , _hc_uniqIdBdd       :: Maybe Text
-                      , _hc_uniqId          :: Maybe Text
-
+  HyperdataContact { _hc_bdd    :: Maybe Text           -- ID of Database source
+                   , _hc_who    :: Maybe ContactWho
+                   , _hc_where  :: [ContactWhere]
+                   , _hc_title  :: Maybe Text -- TODO remove (only demo)
+                   , _hc_source :: Maybe Text -- TODO remove (only demo)
+                   , _hc_lastValidation  :: Maybe Text -- TODO UTCTime
+                   , _hc_uniqIdBdd       :: Maybe Text
+                   , _hc_uniqId          :: Maybe Text
   } deriving (Eq, Show, Generic)
 
+instance GQLType HyperdataContact where
+  typeOptions _ = GAGU.unPrefix "_hc_"
+
 instance HasText HyperdataContact
   where
     hasText = undefined
 
 defaultHyperdataContact :: HyperdataContact
-defaultHyperdataContact = HyperdataContact (Just "bdd")
-                                         (Just defaultContactWho)
-                                         [defaultContactWhere]
-                                         (Just "Title")
-                                         (Just "Source")
-                                         (Just "TODO lastValidation date")
-                                         (Just "DO NOT expose this")
-                                         (Just "DO NOT expose this")
+defaultHyperdataContact =
+  HyperdataContact
+    { _hc_bdd = Just "bdd"
+    , _hc_who = Just defaultContactWho
+    , _hc_where = [defaultContactWhere]
+    , _hc_title =Just "Title"
+    , _hc_source = Just "Source"
+    , _hc_lastValidation = Just "TODO lastValidation date"
+    , _hc_uniqIdBdd = Just "DO NOT expose this"
+    , _hc_uniqId = Just "DO NOT expose this" }
 
 hyperdataContact :: FirstName -> LastName -> HyperdataContact
-hyperdataContact fn ln = HyperdataContact Nothing
-                                          (Just (contactWho fn ln))
-                                          []
-                                          Nothing
-                                          Nothing
-                                          Nothing
-                                          Nothing
-                                          Nothing
+hyperdataContact fn ln =
+  HyperdataContact
+    { _hc_bdd = Nothing
+    , _hc_who = Just (contactWho fn ln)
+    , _hc_where = []
+    , _hc_title = Nothing
+    , _hc_source = Nothing
+    , _hc_lastValidation = Nothing
+    , _hc_uniqIdBdd = Nothing
+    , _hc_uniqId = Nothing }
 
 -- TOD0 contact metadata (Type is too flat)
 data ContactMetaData =
-     ContactMetaData { _cm_bdd :: Maybe Text
-                     , _cm_lastValidation  :: Maybe Text -- TODO UTCTIME
+  ContactMetaData { _cm_bdd :: Maybe Text
+                  , _cm_lastValidation  :: Maybe Text -- TODO UTCTIME
   } deriving (Eq, Show, Generic)
 
 defaultContactMetaData :: ContactMetaData
 defaultContactMetaData = ContactMetaData (Just "bdd") (Just "TODO UTCTime")
 
 arbitraryHyperdataContact :: HyperdataContact
-arbitraryHyperdataContact = HyperdataContact Nothing Nothing []
-                                             Nothing Nothing Nothing
-                                             Nothing Nothing
+arbitraryHyperdataContact =
+  HyperdataContact
+    { _hc_bdd = Nothing
+    , _hc_who = Nothing
+    , _hc_where = []
+    , _hc_title = Nothing
+    , _hc_source = Nothing
+    , _hc_lastValidation = Nothing
+    , _hc_uniqIdBdd = Nothing
+    , _hc_uniqId = Nothing }
 
 
 data ContactWho = 
-     ContactWho { _cw_id          :: Maybe Text
-                , _cw_firstName   :: Maybe Text
-                , _cw_lastName    :: Maybe Text
-                , _cw_keywords :: [Text]
-                , _cw_freetags :: [Text]
+  ContactWho { _cw_id          :: Maybe Text
+             , _cw_firstName   :: Maybe Text
+             , _cw_lastName    :: Maybe Text
+             , _cw_keywords :: [Text]
+             , _cw_freetags :: [Text]
   } deriving (Eq, Show, Generic)
 
+instance GQLType ContactWho where
+  typeOptions _ = GAGU.unPrefix "_cw_"
+
 type FirstName = Text
 type LastName  = Text
 
@@ -96,40 +115,44 @@ defaultContactWho :: ContactWho
 defaultContactWho = contactWho "Pierre" "Dupont"
 
 contactWho :: FirstName -> LastName -> ContactWho
-contactWho fn ln = ContactWho Nothing
-                             (Just fn)
-                             (Just ln)
-                             []
-                             []
-
-
+contactWho fn ln =
+  ContactWho { _cw_id = Nothing
+             , _cw_firstName = Just fn
+             , _cw_lastName = Just ln
+             , _cw_keywords = []
+             , _cw_freetags = [] }
 
 data ContactWhere =
-     ContactWhere { _cw_organization :: [Text]
-                  , _cw_labTeamDepts :: [Text]
-
-                  , _cw_role         :: Maybe Text
-
-                  , _cw_office       :: Maybe Text
-                  , _cw_country      :: Maybe Text
-                  , _cw_city         :: Maybe Text
-
-                  , _cw_touch        :: Maybe ContactTouch
-
-                  , _cw_entry        :: Maybe UTCTime
-                  , _cw_exit         :: Maybe UTCTime
+  ContactWhere { _cw_organization :: [Text]
+               , _cw_labTeamDepts :: [Text]
+               
+               , _cw_role         :: Maybe Text
+               
+               , _cw_office       :: Maybe Text
+               , _cw_country      :: Maybe Text
+               , _cw_city         :: Maybe Text
+               
+               , _cw_touch        :: Maybe ContactTouch
+               
+               , _cw_entry        :: Maybe NUTCTime
+               , _cw_exit         :: Maybe NUTCTime
   } deriving (Eq, Show, Generic)
 
+instance GQLType ContactWhere where
+  typeOptions _ = GAGU.unPrefix "_cw_"
+
 defaultContactWhere :: ContactWhere
-defaultContactWhere = ContactWhere ["Organization X"]
-                                 ["Lab Z"]
-                                 (Just "Role")
-                                 (Just "Office")
-                                 (Just "Country")
-                                 (Just "City")
-                                 (Just defaultContactTouch)
-                                 (Just $ jour 01 01 2020)
-                                 (Just $ jour 01 01 2029)
+defaultContactWhere =
+  ContactWhere
+    { _cw_organization = ["Organization X"]
+    , _cw_labTeamDepts = ["Lab Z"]
+    , _cw_role = Just "Role"
+    , _cw_office = Just "Office"
+    , _cw_country = Just "Country"
+    , _cw_city = Just "City"
+    , _cw_touch = Just defaultContactTouch
+    , _cw_entry = Just $ NUTCTime $ jour 01 01 2020
+    , _cw_exit = Just $ NUTCTime $ jour 01 01 2029 }
 
 data ContactTouch =
      ContactTouch { _ct_mail      :: Maybe Text
@@ -137,10 +160,15 @@ data ContactTouch =
                   , _ct_url       :: Maybe Text
   } deriving (Eq, Show, Generic)
 
+instance GQLType ContactTouch where
+  typeOptions _ = GAGU.unPrefix "_ct_"
+
 defaultContactTouch :: ContactTouch
-defaultContactTouch = ContactTouch (Just "email@data.com")
-                                 (Just "+336 328 283 288")
-                                 (Just "https://url.com")
+defaultContactTouch =
+  ContactTouch
+    { _ct_mail = Just "email@data.com"
+    , _ct_phone = Just "+336 328 283 288"
+    , _ct_url = Just "https://url.com" }
 
 -- | ToSchema instances
 instance ToSchema HyperdataContact where

src/Gargantext/Database/Admin/Types/Hyperdata/User.hs

@@ -11,6 +11,7 @@ Portability : POSIX
 
 {-# LANGUAGE FunctionalDependencies     #-}
 {-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE DeriveAnyClass             #-}
 {-# LANGUAGE FlexibleContexts           #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
@@ -23,11 +24,13 @@ Portability : POSIX
 module Gargantext.Database.Admin.Types.Hyperdata.User
   where
 
-import Gargantext.Prelude
+import Data.Morpheus.Types (GQLType(typeOptions))
+import qualified Gargantext.API.GraphQL.Utils as GAGU
 import Gargantext.Core (Lang(..))
 import Gargantext.Database.Admin.Types.Hyperdata.Prelude
 import Gargantext.Database.Admin.Types.Hyperdata.Contact
 import Gargantext.Database.Admin.Types.Node (DocumentId)
+import Gargantext.Prelude
 
 -- import Gargantext.Database.Schema.Node -- (Node(..))
 
@@ -37,23 +40,35 @@ data HyperdataUser =
                    , _hu_public    :: !(Maybe HyperdataPublic)
                    } deriving (Eq, Show, Generic)
 
+instance GQLType HyperdataUser where
+  typeOptions _ = GAGU.unPrefix "_hu_"
+
 data HyperdataPrivate =
      HyperdataPrivate { _hpr_password :: !Text
                       , _hpr_lang     :: !Lang
                       }
      deriving (Eq, Show, Generic)
 
+instance GQLType HyperdataPrivate where
+  typeOptions _ = GAGU.unPrefix "_hpr_"
+
+
 data HyperdataPublic =
      HyperdataPublic { _hpu_pseudo       :: !Text
                      , _hpu_publications :: ![DocumentId]
                      }
      deriving (Eq, Show, Generic)
 
+instance GQLType HyperdataPublic where
+  typeOptions _ = GAGU.unPrefix "_hpu_"
+
 -- | Default
 defaultHyperdataUser :: HyperdataUser
-defaultHyperdataUser = HyperdataUser (Just defaultHyperdataPrivate)
-                                   (Just defaultHyperdataContact)
-                                   (Just defaultHyperdataPublic)
+defaultHyperdataUser =
+  HyperdataUser
+    { _hu_private = Just defaultHyperdataPrivate
+    , _hu_shared = Just defaultHyperdataContact
+    , _hu_public = Just defaultHyperdataPublic }
 
 defaultHyperdataPublic :: HyperdataPublic
 defaultHyperdataPublic = HyperdataPublic "pseudo" [1..10]

src/Gargantext/Database/Admin/Types/Node.hs

@@ -25,6 +25,7 @@ import Data.Aeson
 import Data.Aeson.TH (deriveJSON)
 import Data.Either
 import Data.Hashable (Hashable)
+import Data.Morpheus.Types (GQLType)
 import Data.Swagger
 import Data.Text (Text, unpack)
 import Data.Time (UTCTime)
@@ -152,6 +153,7 @@ pgNodeId = O.sqlInt4 . id2int
 ------------------------------------------------------------------------
 newtype NodeId = NodeId Int
   deriving (Read, Generic, Num, Eq, Ord, Enum, ToJSONKey, FromJSONKey, ToJSON, FromJSON, Hashable)
+instance GQLType NodeId
 instance Show NodeId where
   show (NodeId n) = "nodeId-" <> show n
 instance Serialise NodeId

src/Gargantext/Database/Query/Table/User.hs

@@ -23,6 +23,8 @@ module Gargantext.Database.Query.Table.User
   , deleteUsers
   , updateUserDB
   , queryUserTable
+  , getUserHyperdata
+  , getUsersWithHyperdata
   , getUser
   , insertNewUsers
   , selectUsersLightWith
@@ -36,13 +38,16 @@ module Gargantext.Database.Query.Table.User
   where
 
 import Control.Arrow (returnA)
+import Control.Lens ((^.))
 import Data.List (find)
 import Data.Text (Text)
 import Data.Time (UTCTime)
 import Gargantext.Core.Types.Individu
 import qualified Gargantext.Prelude.Crypto.Auth as Auth
-import Gargantext.Database.Schema.User
+import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser)
 import Gargantext.Database.Prelude
+import Gargantext.Database.Schema.Node (node_hyperdata, node_id, queryNodeTable)
+import Gargantext.Database.Schema.User
 import Gargantext.Prelude
 import Opaleye
 
@@ -107,10 +112,25 @@ getUsersWithId i = map toUserLight <$> runOpaQuery (selectUsersLightWithId i)
           returnA  -< row
 
 
-
 queryUserTable :: Query UserRead
 queryUserTable = selectTable userTable
 
+----------------------------------------------------------------------
+getUserHyperdata :: Int -> Cmd err [HyperdataUser]
+getUserHyperdata i = do
+  runOpaQuery (selectUserHyperdataWithId i)
+  where
+    selectUserHyperdataWithId :: Int -> Query (Column PGJsonb)
+    selectUserHyperdataWithId i' = proc () -> do
+      row      <- queryNodeTable -< ()
+      restrict -< row^.node_id .== (sqlInt4 i')
+      returnA  -< row^.node_hyperdata
+
+getUsersWithHyperdata :: Int -> Cmd err [(UserLight, HyperdataUser)]
+getUsersWithHyperdata i = do
+  u <- getUsersWithId i
+  h <- getUserHyperdata i
+  pure $ zip u h
 ------------------------------------------------------------------
 -- | Select User with some parameters
 -- Not optimized version
@@ -129,7 +149,6 @@ userLightWithUsername t xs = userWith userLight_username t xs
 
 userLightWithId :: Int -> [UserLight] -> Maybe UserLight
 userLightWithId t xs = userWith userLight_id t xs
-
 ----------------------------------------------------------------------
 users :: Cmd err [UserDB]
 users = runOpaQuery queryUserTable

src/Gargantext/Database/Schema/User.hs

@@ -13,20 +13,23 @@ 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(typeOptions))
 import Data.Text (Text)
 import Data.Time (UTCTime)
+import qualified Gargantext.API.GraphQL.Utils as GAGU
+import Gargantext.Core.Utils.Prefix (unPrefix)
+import Gargantext.Database.Prelude (fromField')
 import Gargantext.Prelude
 import GHC.Generics (Generic)
 import Database.PostgreSQL.Simple.FromField (FromField, fromField)
 import Data.Aeson.TH (deriveJSON)
-import Gargantext.Database.Prelude (fromField')
-import Gargantext.Core.Utils.Prefix (unPrefix)
 
 -- FIXME PLZ : the import below leads to an error, why ?
 -- import Gargantext.Database.Schema.Prelude hiding (makeLensesWith, abbreviatedFields, makeAdaptorAndInstance)
@@ -43,6 +46,9 @@ data UserLight = UserLight { userLight_id       :: !Int
                            , userLight_password :: !Text
                            } deriving (Show, Generic)
 
+instance GQLType UserLight where
+  typeOptions _ = GAGU.unPrefix "userLight_"
+
 toUserLight :: UserDB -> UserLight
 toUserLight (UserDB id p _ _ u _ _ e _ _ _ ) = UserLight id u e p
 

src/Gargantext/Utils/UTCTime.hs

+{-# LANGUAGE DeriveAnyClass             #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE TypeFamilies               #-}
+
+module Gargantext.Utils.UTCTime where
+
+import Data.Aeson (FromJSON, ToJSON)
+import Data.Either (Either(..))
+import Data.Morpheus.Kind (SCALAR)
+import Data.Morpheus.Types (GQLType(..), DecodeScalar(..), EncodeScalar(..))
+import qualified Data.Morpheus.Types as DMT
+import Data.Swagger (ToSchema)
+import qualified Data.Text as T
+import Data.Time (UTCTime)
+import Gargantext.Prelude
+import GHC.Generics (Generic)
+import Text.Read (readEither)
+
+
+newtype NUTCTime = NUTCTime UTCTime
+  deriving (Eq, Show, Generic)
+instance DecodeScalar NUTCTime where
+  decodeScalar (DMT.String x) = case (readEither $ T.unpack x) of
+    Right r  -> pure $ NUTCTime r
+    Left err -> Left $ T.pack err
+  decodeScalar          _ = Left "Invalid value for NUTCTime"
+instance EncodeScalar NUTCTime where
+  encodeScalar (NUTCTime x) = DMT.String $ T.pack $ show x
+instance GQLType NUTCTime where
+  type KIND NUTCTime = SCALAR
+instance FromJSON NUTCTime
+instance ToJSON NUTCTime
+instance ToSchema NUTCTime

stack.yaml

@@ -28,7 +28,7 @@ allow-newer: true
 
 extra-deps:
 - git: https://gitlab.iscpif.fr/gargantext/haskell-gargantext-prelude.git
-  commit: 220f32810f988a5a121f110a7d557fc7d0721712
+  commit: 6bfdb29e9a576472c7fd7ebe648ad101e5b3927f
   # Data Mining Libs
 - git: https://github.com/delanoe/data-time-segment.git
   commit: 10a416b9f6c443866b36479c3441ebb3bcdeb7ef