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