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