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