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 module Gargantext.API.GraphQL where
   8
   9 import Data.ByteString.Lazy.Char8
  10   ( ByteString
  11   )
  12 import Data.List.NonEmpty (NonEmpty ((:|)))
  13 import Data.Map (Map)
  14 import Data.Morpheus
  15   ( App
  16   , deriveApp )
  17 import Data.Morpheus.Server
  18   ( httpPlayground
  19   )
  20 import Data.Morpheus.Subscriptions
  21   ( Event (..)
  22   , Hashable
  23   , httpPubApp
  24   )
  25 import Data.Morpheus.Types
  26   ( GQLRequest
  27   , GQLResponse
  28   , GQLType
  29   , RootResolver(..)
  30   , Undefined(..)
  31   )
  32 import Data.Proxy
  33 import Gargantext.API.Admin.Auth.Types (AuthenticatedUser)
  34 import Gargantext.API.Admin.Orchestrator.Types (JobLog)
  35 import Gargantext.API.Prelude (HasJobEnv')
  36 import qualified Gargantext.API.GraphQL.Annuaire as GQLA
  37 import qualified Gargantext.API.GraphQL.AsyncTask as GQLAT
  38 import qualified Gargantext.API.GraphQL.IMT as GQLIMT
  39 import qualified Gargantext.API.GraphQL.Node as GQLNode
  40 import qualified Gargantext.API.GraphQL.User as GQLUser
  41 import qualified Gargantext.API.GraphQL.UserInfo as GQLUserInfo
  42 import qualified Gargantext.API.GraphQL.TreeFirstLevel as GQLTree
  43 import Gargantext.API.Prelude (GargM, GargError)
  44 import Gargantext.Core.Mail.Types (HasMail)
  45 import Gargantext.Database.Prelude (HasConnectionPool, HasConfig)
  46 import Gargantext.Prelude
  47 import GHC.Generics (Generic)
  48 import Network.HTTP.Media ((//), (/:))
  49 import qualified Prelude
  50 import Servant
  51   ( (:<|>) (..)
  52   , (:>)
  53   , Accept (..)
  54   , Get
  55   , JSON
  56   , MimeRender (..)
  57   , Post
  58   , ReqBody
  59   ,  ServerT
  60   )
  61 import qualified Servant.Auth as SA
  62 import qualified Servant.Auth.Server as SAS
  63 import Gargantext.API.Admin.Types (HasSettings)
  64
  65 -- | Represents possible GraphQL queries.
  66 data Query m
  67   = Query
  68     { annuaire_contacts :: GQLA.AnnuaireContactArgs -> m [GQLA.AnnuaireContact]
  69     , imt_schools :: GQLIMT.SchoolsArgs -> m [GQLIMT.School]
  70     , job_logs    :: GQLAT.JobLogArgs -> m (Map Int JobLog)
  71     , nodes       :: GQLNode.NodeArgs -> m [GQLNode.Node]
  72     , node_parent :: GQLNode.NodeParentArgs -> m [GQLNode.Node]
  73     , user_infos  :: GQLUserInfo.UserInfoArgs -> m [GQLUserInfo.UserInfo]
  74     , users       :: GQLUser.UserArgs -> m [GQLUser.User m]
  75     , tree        :: GQLTree.TreeArgs -> m (GQLTree.TreeFirstLevel m)
  76     } deriving (Generic, GQLType)
  77
  78 data Mutation m
  79   = Mutation
  80     { update_user_info :: GQLUserInfo.UserInfoMArgs -> m Int }
  81     deriving (Generic, GQLType)
  82
  83 -- | Possible GraphQL Events, i.e. here we describe how we will
  84 -- manipulate the data.
  85 type EVENT m = Event Channel (Contet m)
  86
  87 -- | Channels are possible actions to call when manipulating the data.
  88 data Channel
  89   = Update
  90   | New
  91   deriving (Eq, Show, Generic, Hashable)
  92
  93 -- | This type describes what data we will operate on.
  94 data Contet m
  95   = UserContet [GQLUser.User m]
  96   | UserInfoContet [GQLUserInfo.UserInfo]
  97
  98 -- | The main GraphQL resolver: how queries, mutations and
  99 -- subscriptions are handled.
 100 rootResolver
 101   :: (HasConnectionPool env, HasConfig env, HasMail env, HasJobEnv' env, HasSettings env)
 102   => RootResolver (GargM env GargError) e Query Mutation Undefined
 103 rootResolver =
 104   RootResolver
 105     { queryResolver = Query { annuaire_contacts = GQLA.resolveAnnuaireContacts
 106                             , imt_schools       = GQLIMT.resolveSchools
 107                             , job_logs          = GQLAT.resolveJobLogs
 108                             , nodes             = GQLNode.resolveNodes
 109                             , node_parent       = GQLNode.resolveNodeParent
 110                             , user_infos        = GQLUserInfo.resolveUserInfos
 111                             , users             = GQLUser.resolveUsers
 112                             , tree              = GQLTree.resolveTree }
 113     , mutationResolver = Mutation { update_user_info = GQLUserInfo.updateUserInfo }
 114     , subscriptionResolver = Undefined }
 115
 116 -- | Main GraphQL "app".
 117 app
 118   :: (Typeable env, HasConnectionPool env, HasConfig env, HasMail env, HasJobEnv' env, HasSettings env)
 119   => App (EVENT (GargM env GargError)) (GargM env GargError)
 120 app = deriveApp rootResolver
 121
 122 ----------------------------------------------
 123
 124 -- Now for some boilerplate to integrate the above GraphQL app with
 125 -- servant.
 126
 127 -- | HTML type is needed for the GraphQL Playground.
 128 data HTML deriving (Typeable)
 129 instance Accept HTML where
 130   contentTypes _ = "text" // "html" /: ("charset", "utf-8") :| ["text" // "html"]
 131 instance MimeRender HTML ByteString where
 132   mimeRender _ = Prelude.id
 133
 134 -- | Servant route for the app we defined above.
 135 type GQAPI = ReqBody '[JSON] GQLRequest :> Post '[JSON] GQLResponse
 136 -- type Schema = "schema" :> Get '[PlainText] Text
 137 -- | Servant route for the playground.
 138 type Playground = Get '[HTML] ByteString
 139 -- type API' (name :: Symbol) = name :> (GQAPI :<|> Schema :<|> Playground)
 140 -- | Our API consists of `GQAPI` and `Playground`.
 141 type API = SA.Auth '[SA.JWT, SA.Cookie] AuthenticatedUser
 142             :> "gql" :> (GQAPI :<|> Playground)
 143
 144 gqapi :: Proxy API
 145 gqapi = Proxy
 146
 147 -- serveEndpoint ::
 148 --   ( SubApp ServerApp e
 149 --   , PubApp e
 150 --   ) =>
 151 --   [e -> IO ()] ->
 152 --   App e IO ->
 153 --   Server (API name)
 154 -- serveEndpoint publish app' = (liftIO . httpPubApp publish app') :<|> withSchema app' :<|> pure httpPlayground
 155 --
 156 -- withSchema :: (Applicative f) => App e m -> f Text
 157 -- withSchema = pure . LT.toStrict . decodeUtf8 . render
 158
 159 -- | Implementation of our API.
 160 --api :: Server API
 161 api
 162   :: (Typeable env, HasConnectionPool env, HasConfig env, HasMail env, HasJobEnv' env, HasSettings env)
 163   => ServerT API (GargM env GargError)
 164 api (SAS.Authenticated _auser) = httpPubApp [] app :<|> pure httpPlayground
 165 api _                          = panic "401 in graphql" -- SAS.throwAll (_ServerError # err401)