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