module AirGQL.Servant.GraphQL (
  gqlQueryGetHandler,
  gqlQueryPostHandler,
  playgroundDefaultQueryHandler,
  readOnlyGqlPostHandler,
  writeOnlyGqlPostHandler,
) where

import Protolude (
  Applicative (pure),
  MonadIO (liftIO),
  Monoid (mempty),
  Semigroup ((<>)),
  ($),
  (&),
 )
import Protolude qualified as P

import Control.Monad.Catch (catchAll)
import Data.Aeson (Object)
import Data.Text (Text)
import Data.Text qualified as T
import DoubleXEncoding (doubleXEncodeGql)
import Servant (NoContent, err303, errHeaders)
import Servant.Server qualified as Servant
import System.Directory (makeAbsolute)

import AirGQL.Lib (
  AccessMode (ReadOnly, WriteOnly),
  column_name,
  getColumns,
  getTableNames,
 )
import AirGQL.ServerUtils (executeQuery)
import AirGQL.Types.SchemaConf (SchemaConf (accessMode), defaultSchemaConf)
import AirGQL.Types.Types (GQLPost (operationName, query, variables))
import AirGQL.Utils (
  getDbDir,
  getMainDbPath,
  getReadOnlyFilePath,
  throwErr400WithMsg,
  throwErr404WithMsg,
  withRetryConn,
 )
import System.FilePath (pathSeparator, takeDirectory)


gqlQueryGetHandler :: Text -> Servant.Handler NoContent
gqlQueryGetHandler :: Text -> Handler NoContent
gqlQueryGetHandler Text
dbId =
  ServerError -> Handler NoContent
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
P.throwError
    ServerError
err303
      { errHeaders =
          [("Location", P.encodeUtf8 $ "/dbs/" <> dbId <> "/graphiql")]
      }


gqlQueryPostHandler
  :: SchemaConf
  -> Text
  -> GQLPost
  -> Servant.Handler Object
gqlQueryPostHandler :: SchemaConf -> Text -> GQLPost -> Handler Object
gqlQueryPostHandler SchemaConf
schemaConf Text
dbIdOrPath GQLPost
gqlPost = do
  let
    handleNoDbError :: P.SomeException -> Servant.Handler a
    handleNoDbError :: forall a. SomeException -> Handler a
handleNoDbError SomeException
excpetion = do
      let errMsg :: Text
errMsg = SomeException -> Text
forall a b. (Show a, StringConv String b) => a -> b
P.show SomeException
excpetion

      if Text
"unable to open database file" Text -> Text -> Bool
`T.isInfixOf` Text
errMsg
        then
          Text -> Handler a
forall a. Text -> Handler a
throwErr404WithMsg (Text -> Handler a) -> Text -> Handler a
forall a b. (a -> b) -> a -> b
$
            Text
"Database \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
dbIdOrPath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" does not exist"
        else do
          Text -> Handler ()
forall a (m :: * -> *). (Print a, MonadIO m) => a -> m ()
forall (m :: * -> *). MonadIO m => Text -> m ()
P.putErrLn (Text -> Handler ()) -> Text -> Handler ()
forall a b. (a -> b) -> a -> b
$
            Text
"Error during execution of GraphQL query: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
errMsg
          Text -> Handler a
forall a. Text -> Handler a
throwErr400WithMsg Text
errMsg

  Handler Object
-> (SomeException -> Handler Object) -> Handler Object
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
catchAll
    ( IO Object -> Handler Object
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Object -> Handler Object) -> IO Object -> Handler Object
forall a b. (a -> b) -> a -> b
$ do
        String
reqDir <-
          if Char
pathSeparator Char -> Text -> Bool
`T.elem` Text
dbIdOrPath
            then String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> String
takeDirectory (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
dbIdOrPath
            else String -> IO String
makeAbsolute (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ Text -> String
getDbDir Text
dbIdOrPath

        SchemaConf
-> Text -> String -> Text -> Object -> Maybe Text -> IO Object
executeQuery
          SchemaConf
schemaConf
          Text
dbIdOrPath
          String
reqDir
          GQLPost
gqlPost.query
          (GQLPost
gqlPost.variables Maybe Object -> (Maybe Object -> Object) -> Object
forall a b. a -> (a -> b) -> b
& Object -> Maybe Object -> Object
forall a. a -> Maybe a -> a
P.fromMaybe Object
forall a. Monoid a => a
mempty)
          GQLPost
gqlPost.operationName
    )
    SomeException -> Handler Object
forall a. SomeException -> Handler a
handleNoDbError


readOnlyGqlPostHandler :: Text -> GQLPost -> Servant.Handler Object
readOnlyGqlPostHandler :: Text -> GQLPost -> Handler Object
readOnlyGqlPostHandler Text
dbIdOrPath GQLPost
gqlPost =
  IO Object -> Handler Object
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Object -> Handler Object) -> IO Object -> Handler Object
forall a b. (a -> b) -> a -> b
$ do
    String
reqDir <- String -> IO String
makeAbsolute (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ Text -> String
getReadOnlyFilePath Text
dbIdOrPath

    SchemaConf
-> Text -> String -> Text -> Object -> Maybe Text -> IO Object
executeQuery
      SchemaConf
defaultSchemaConf{accessMode = ReadOnly}
      Text
dbIdOrPath
      String
reqDir
      GQLPost
gqlPost.query
      (GQLPost
gqlPost.variables Maybe Object -> (Maybe Object -> Object) -> Object
forall a b. a -> (a -> b) -> b
& Object -> Maybe Object -> Object
forall a. a -> Maybe a -> a
P.fromMaybe Object
forall a. Monoid a => a
mempty)
      GQLPost
gqlPost.operationName


writeOnlyGqlPostHandler :: Text -> GQLPost -> Servant.Handler Object
writeOnlyGqlPostHandler :: Text -> GQLPost -> Handler Object
writeOnlyGqlPostHandler Text
dbPath GQLPost
gqlPost =
  IO Object -> Handler Object
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Object -> Handler Object) -> IO Object -> Handler Object
forall a b. (a -> b) -> a -> b
$ do
    String
reqDir <- String -> IO String
makeAbsolute (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ Text -> String
getReadOnlyFilePath Text
dbPath

    SchemaConf
-> Text -> String -> Text -> Object -> Maybe Text -> IO Object
executeQuery
      SchemaConf
defaultSchemaConf{accessMode = WriteOnly}
      Text
dbPath
      String
reqDir
      GQLPost
gqlPost.query
      (GQLPost
gqlPost.variables Maybe Object -> (Maybe Object -> Object) -> Object
forall a b. a -> (a -> b) -> b
& Object -> Maybe Object -> Object
forall a. a -> Maybe a -> a
P.fromMaybe Object
forall a. Monoid a => a
mempty)
      GQLPost
gqlPost.operationName


playgroundDefaultQueryHandler
  :: Text
  -> Servant.Handler Text
playgroundDefaultQueryHandler :: Text -> Handler Text
playgroundDefaultQueryHandler Text
dbId = do
  IO Text -> Handler Text
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> Handler Text) -> IO Text -> Handler Text
forall a b. (a -> b) -> a -> b
$ String -> (Connection -> IO Text) -> IO Text
forall a. String -> (Connection -> IO a) -> IO a
withRetryConn (Text -> String
getMainDbPath Text
dbId) ((Connection -> IO Text) -> IO Text)
-> (Connection -> IO Text) -> IO Text
forall a b. (a -> b) -> a -> b
$ \Connection
mainConn -> do
    [Text]
tableEntries <- Connection -> IO [Text]
getTableNames Connection
mainConn

    case [Text]
tableEntries of
      (Text
headTable : [Text]
_) -> do
        [ColumnEntry]
cols <- Text -> Connection -> Text -> IO [ColumnEntry]
getColumns Text
dbId Connection
mainConn Text
headTable
        Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$
          [Text] -> Text
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
P.fold
            [ Text
"query "
            , Text -> Text
doubleXEncodeGql Text
headTable
            , Text
"Query {\n"
            , Text
"  "
            , Text -> Text
doubleXEncodeGql Text
headTable
            , Text
"( limit: 100 ) {\n"
            , [ColumnEntry]
cols
                [ColumnEntry] -> ([ColumnEntry] -> Text) -> Text
forall a b. a -> (a -> b) -> b
& (ColumnEntry -> Text) -> [ColumnEntry] -> Text
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
P.foldMap
                  ( \ColumnEntry
col ->
                      Text
"    " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
doubleXEncodeGql ColumnEntry
col.column_name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
                  )
            , Text
"  }\n"
            , Text
"}"
            ]
      [Text]
_ -> Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
""