-- | Internal module which implements the @hipsql@ executable.
-- While it is exposed as a library, it is not intended to be used
-- as such.
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Hipsql.Client.Internal
  ( -- * Disclaimer
    -- $disclaimer

    -- ** Internals
    module Hipsql.Client.Internal
  ) where

import Control.Exception (catch, throwIO)
import Control.Monad ((<=<), unless, void)
import Control.Monad.Reader (MonadIO(liftIO), MonadTrans(lift), ReaderT(runReaderT), ask, asks)
import Data.ByteString (ByteString)
import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)
import Hipsql.API (HipsqlRoutes(eval, getVersion), isCompatibleWith, renderVersion, theHipsqlApiVersion)
import Hipsql.API.Internal (Version, defaultHipsqlPort, lookupHipsqlPort, mkVersion)
import Servant.Client
  ( ClientError(ConnectionError, FailureResponse), ResponseF(responseBody, responseStatusCode)
  , mkClientEnv, parseBaseUrl, runClientM
  )
import Servant.Client.Generic (AsClientT, genericClientHoist)
import System.Console.Haskeline (InputT, getInputLine, runInputT)
import System.Directory (getHomeDirectory)
import System.Environment (getArgs)
import System.Exit (exitFailure, exitSuccess)
import System.FilePath ((</>))
import Text.Read (readMaybe)
import qualified Data.ByteString.Char8 as Char8
import qualified Data.ByteString.Lazy as Lazy
import qualified Data.ByteString.Lazy.Char8 as Lazy.Char8
import qualified Network.HTTP.Client as HTTPClient
import qualified Network.HTTP.Types.Status as HTTP
import qualified Paths_hipsql_client
import qualified System.Console.Haskeline as Haskeline
import qualified System.IO as IO

-- | The compiled @hipsql@ client version.
theHipsqlClientVersion :: Version
theHipsqlClientVersion :: Version
theHipsqlClientVersion = Version -> Version
mkVersion Version
Paths_hipsql_client.version

-- | Main entry point for the @hipsql@ client executable.
main :: IO ()
main :: IO ()
main = (Int -> IO ()) -> IO ()
run \port :: Int
port -> do
  Manager
httpManager <- ManagerSettings -> IO Manager
HTTPClient.newManager ManagerSettings
HTTPClient.defaultManagerSettings
  ClientIO -> Int -> Manager -> IO ()
hipsqlClient ClientIO
defaultClientIO Int
port Manager
httpManager
  where
  run :: (Int -> IO ()) -> IO ()
  run :: (Int -> IO ()) -> IO ()
run action :: Int -> IO ()
action = do
    IO [String]
getArgs IO [String] -> ([String] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      args :: [String]
args | "--help" String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
args -> do
        String -> IO ()
putStrLn String
usage
        IO ()
forall a. IO a
exitSuccess

      ["--numeric-version"] -> do
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Version -> String
renderVersion Version
theHipsqlClientVersion

      ["--api-numeric-version"] -> do
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Version -> String
renderVersion Version
theHipsqlApiVersion

      ["--version"] -> do
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "hipsql-client version: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Version -> String
renderVersion Version
theHipsqlClientVersion
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "hipsql-api    version: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Version -> String
renderVersion Version
theHipsqlApiVersion

      _ : _ : _ -> do
        String -> IO ()
forall a. String -> IO a
abort (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Invalid arguments\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
usage

      [] -> do
        IO (Either String Int)
lookupHipsqlPort IO (Either String Int) -> (Either String Int -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left message :: String
message -> do
            String -> IO ()
forall a. String -> IO a
abort (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Failed to start hipsql client; could not parse port: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
message
          Right port :: Int
port -> do
            Int -> IO ()
action Int
port

      [arg :: String
arg] ->
        case String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
arg of
          Just port :: Int
port -> Int -> IO ()
action Int
port
          Nothing -> String -> IO ()
forall a. String -> IO a
abort (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Invalid port: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
arg String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
usage

-- | Usage message for @hipsql@.
usage :: String
usage :: String
usage = "Usage: hipsql [port=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
defaultHipsqlPort String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "]"

-- | Aborts with the given message on @stderr@ and exits with a non-zero status.
abort :: String -> IO a
abort :: String -> IO a
abort message :: String
message = do
  Handle -> String -> IO ()
IO.hPutStrLn Handle
IO.stderr String
message
  IO a
forall a. IO a
exitFailure

-- | Run the client using the specified configuration.
hipsqlClient :: ClientIO -> Int -> HTTPClient.Manager -> IO ()
hipsqlClient :: ClientIO -> Int -> Manager -> IO ()
hipsqlClient io :: ClientIO
io port :: Int
port httpManager :: Manager
httpManager = do
  ServantClient
servantClient <- Manager -> Int -> IO ServantClient
mkServantClient Manager
httpManager Int
port
  PsqlEnv
psqlEnv <- ClientIO -> ServantClient -> IO PsqlEnv
initPsqlEnv' ClientIO
io ServantClient
servantClient
  Settings (ReaderT PsqlEnv IO)
settings <- IO (Settings (ReaderT PsqlEnv IO))
mkHaskelineSettings
  (ReaderT PsqlEnv IO () -> PsqlEnv -> IO ())
-> PsqlEnv -> ReaderT PsqlEnv IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT PsqlEnv IO () -> PsqlEnv -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT PsqlEnv
psqlEnv (ReaderT PsqlEnv IO () -> IO ()) -> ReaderT PsqlEnv IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Settings (ReaderT PsqlEnv IO)
-> InputT (ReaderT PsqlEnv IO) () -> ReaderT PsqlEnv IO ()
forall (m :: * -> *) a.
MonadException m =>
Settings m -> InputT m a -> m a
runInputT Settings (ReaderT PsqlEnv IO)
settings InputT (ReaderT PsqlEnv IO) ()
psql
  where
  mkHaskelineSettings :: IO (Settings (ReaderT PsqlEnv IO))
mkHaskelineSettings = do
    String
userHome <- IO String
getHomeDirectory
    Settings (ReaderT PsqlEnv IO) -> IO (Settings (ReaderT PsqlEnv IO))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Settings :: forall (m :: * -> *).
CompletionFunc m -> Maybe String -> Bool -> Settings m
Haskeline.Settings
      { complete :: CompletionFunc (ReaderT PsqlEnv IO)
complete = CompletionFunc (ReaderT PsqlEnv IO)
forall (m :: * -> *). Monad m => CompletionFunc m
Haskeline.noCompletion
      , historyFile :: Maybe String
historyFile = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
userHome String -> String -> String
</> ".hipsql_history"
      , autoAddHistory :: Bool
autoAddHistory = Bool
True
      }

-- | Runtime state of the @hipsql@ session.
newtype ClientState = ClientState
  { ClientState -> ByteString
queryBuffer :: ByteString
  }

-- | The @hipsql@ interpreter loop.
psql :: PsqlM ()
psql :: InputT (ReaderT PsqlEnv IO) ()
psql = InputT (ReaderT PsqlEnv IO) ()
checkCompatibility InputT (ReaderT PsqlEnv IO) ()
-> InputT (ReaderT PsqlEnv IO) () -> InputT (ReaderT PsqlEnv IO) ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> InputT (ReaderT PsqlEnv IO) ()
loop
  where
  checkCompatibility :: InputT (ReaderT PsqlEnv IO) ()
checkCompatibility = do
    PsqlEnv { Version
serverApiVersion :: PsqlEnv -> Version
serverApiVersion :: Version
serverApiVersion } <- ReaderT PsqlEnv IO PsqlEnv -> InputT (ReaderT PsqlEnv IO) PsqlEnv
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ReaderT PsqlEnv IO PsqlEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
    Bool
-> InputT (ReaderT PsqlEnv IO) () -> InputT (ReaderT PsqlEnv IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Version
theHipsqlApiVersion Version -> Version -> Bool
`isCompatibleWith` Version
serverApiVersion) do
      ByteString -> InputT (ReaderT PsqlEnv IO) ()
writeLBSLn (ByteString -> InputT (ReaderT PsqlEnv IO) ())
-> ByteString -> InputT (ReaderT PsqlEnv IO) ()
forall a b. (a -> b) -> a -> b
$
        "WARNING: Client may be incompatible with server: "
          ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> "\n  client api version = " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> String -> ByteString
Lazy.Char8.pack (Version -> String
renderVersion Version
theHipsqlApiVersion)
          ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> "\n  server api version = " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> String -> ByteString
Lazy.Char8.pack (Version -> String
renderVersion Version
serverApiVersion)

  loop :: InputT (ReaderT PsqlEnv IO) ()
loop = do
    String
prompt <- InputT (ReaderT PsqlEnv IO) String
getPrompt
    String -> PsqlM (Maybe String)
inputStrLn String
prompt PsqlM (Maybe String)
-> (Maybe String -> InputT (ReaderT PsqlEnv IO) ())
-> InputT (ReaderT PsqlEnv IO) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Nothing -> InputT (ReaderT PsqlEnv IO) ()
quit
      Just q :: String
q -> String -> InputT (ReaderT PsqlEnv IO) ()
evalLine String
q

  defaultPrompt :: String
defaultPrompt = "hipsql> "

  continuationPrompt :: String
continuationPrompt = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map (Char -> Char -> Char
forall a b. a -> b -> a
const ' ') String
defaultPrompt

  getPrompt :: InputT (ReaderT PsqlEnv IO) String
getPrompt = do
    ByteString
q <- (ClientState -> ByteString) -> PsqlM ByteString
forall a. (ClientState -> a) -> PsqlM a
gets ClientState -> ByteString
queryBuffer
    String -> InputT (ReaderT PsqlEnv IO) String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> InputT (ReaderT PsqlEnv IO) String)
-> String -> InputT (ReaderT PsqlEnv IO) String
forall a b. (a -> b) -> a -> b
$ if ByteString -> Bool
Char8.null ByteString
q then String
defaultPrompt else String
continuationPrompt

  evalLine :: String -> InputT (ReaderT PsqlEnv IO) ()
evalLine s :: String
s = case String
s of
    _ | String
s String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["\\q", "\\quit", "quit", "exit"] -> InputT (ReaderT PsqlEnv IO) ()
quit
    '\\' : _ -> ByteString -> InputT (ReaderT PsqlEnv IO) ()
runCommand (String -> ByteString
Lazy.Char8.pack String
s)
    _ -> ByteString -> InputT (ReaderT PsqlEnv IO) ()
runQuery (String -> ByteString
Char8.pack String
s)

  runCommand :: ByteString -> InputT (ReaderT PsqlEnv IO) ()
runCommand c :: ByteString
c = do
    ByteString -> InputT (ReaderT PsqlEnv IO) ()
writeLBSLn (ByteString -> InputT (ReaderT PsqlEnv IO) ())
-> InputT (ReaderT PsqlEnv IO) ByteString
-> InputT (ReaderT PsqlEnv IO) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ByteString -> InputT (ReaderT PsqlEnv IO) ByteString
serverEval ByteString
c
    InputT (ReaderT PsqlEnv IO) ()
loop

  runQuery :: ByteString -> InputT (ReaderT PsqlEnv IO) ()
runQuery q0 :: ByteString
q0 = do
    ByteString
q <- ByteString -> PsqlM ByteString
appendQueryBuffer ByteString
q0
    if ByteString -> Bool
Char8.null ByteString
q Bool -> Bool -> Bool
|| ByteString -> Char
Char8.last ByteString
q Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= ';' then do
      InputT (ReaderT PsqlEnv IO) ()
loop
    else do
      InputT (ReaderT PsqlEnv IO) ()
clearQueryBuffer
      ByteString -> InputT (ReaderT PsqlEnv IO) ()
writeLBSLn (ByteString -> InputT (ReaderT PsqlEnv IO) ())
-> InputT (ReaderT PsqlEnv IO) ByteString
-> InputT (ReaderT PsqlEnv IO) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ByteString -> InputT (ReaderT PsqlEnv IO) ByteString
serverEval (ByteString -> ByteString
Lazy.fromStrict ByteString
q)
      InputT (ReaderT PsqlEnv IO) ()
loop

  quit :: InputT (ReaderT PsqlEnv IO) ()
quit = do
    InputT (ReaderT PsqlEnv IO) ByteString
-> InputT (ReaderT PsqlEnv IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ByteString -> InputT (ReaderT PsqlEnv IO) ByteString
serverEval "\\q")
      InputT (ReaderT PsqlEnv IO) ()
-> (ClientError -> InputT (ReaderT PsqlEnv IO) ())
-> InputT (ReaderT PsqlEnv IO) ()
forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
m a -> (e -> m a) -> m a
`Haskeline.catch` \case
        -- In case the server shuts down before we're done reading the response.
        ConnectionError _ -> () -> InputT (ReaderT PsqlEnv IO) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        e :: ClientError
e -> ClientError -> InputT (ReaderT PsqlEnv IO) ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
Haskeline.throwIO ClientError
e

  appendQueryBuffer :: ByteString -> PsqlM ByteString
appendQueryBuffer q :: ByteString
q = do
    ClientState
s <- (ClientState -> ClientState) -> PsqlM ClientState
modify \s :: ClientState
s@ClientState { ByteString
queryBuffer :: ByteString
queryBuffer :: ClientState -> ByteString
queryBuffer } ->
          ClientState
s { queryBuffer :: ByteString
queryBuffer =
                if ByteString -> Bool
Char8.null ByteString
queryBuffer then ByteString
q else ByteString
queryBuffer ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> "\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
q
            }
    ByteString -> PsqlM ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> PsqlM ByteString) -> ByteString -> PsqlM ByteString
forall a b. (a -> b) -> a -> b
$ ClientState -> ByteString
queryBuffer ClientState
s

  clearQueryBuffer :: InputT (ReaderT PsqlEnv IO) ()
clearQueryBuffer = PsqlM ClientState -> InputT (ReaderT PsqlEnv IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (PsqlM ClientState -> InputT (ReaderT PsqlEnv IO) ())
-> PsqlM ClientState -> InputT (ReaderT PsqlEnv IO) ()
forall a b. (a -> b) -> a -> b
$ (ClientState -> ClientState) -> PsqlM ClientState
modify \s :: ClientState
s -> ClientState
s { queryBuffer :: ByteString
queryBuffer = ByteString
forall a. Monoid a => a
mempty }

-- | Runtime environment of the @hipsql@ session.
data PsqlEnv = PsqlEnv
  { PsqlEnv -> Version
serverApiVersion :: Version
  , PsqlEnv -> IORef ClientState
state :: IORef ClientState
  , PsqlEnv -> ClientIO
io :: ClientIO
  , PsqlEnv -> ByteString -> IO ByteString
serverEval' :: Lazy.ByteString -> IO Lazy.ByteString
  }

-- | Console IO actions performed by the @hipsql@ client. Useful so we can
-- write tests which do not need to interact with the real @stdout@.
data ClientIO = ClientIO
  { ClientIO -> String -> PsqlM (Maybe String)
inputStrLn' :: String -> PsqlM (Maybe String)
  , ClientIO -> ByteString -> InputT (ReaderT PsqlEnv IO) ()
writeLBSLn' :: Lazy.ByteString -> PsqlM ()
  }

-- | Interpreter monad for our @hipsql@ client.
type PsqlM = InputT (ReaderT PsqlEnv IO)

-- | Default implementation for calling @eval@ against a @hipsql-server@.
getServerEval :: ServantClient -> Lazy.ByteString -> IO Lazy.ByteString
getServerEval :: ServantClient -> ByteString -> IO ByteString
getServerEval servantClient :: ServantClient
servantClient input :: ByteString
input = do
  ServantClient -> ByteString -> IO ByteString
forall route.
HipsqlRoutes route
-> route
   :- (Summary "Evaluate a psql expression"
       :> ("eval"
           :> (ReqBody '[OctetStream] ByteString
               :> Post '[OctetStream] ByteString)))
eval ServantClient
servantClient ByteString
input IO ByteString -> (ClientError -> IO ByteString) -> IO ByteString
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \case
    FailureResponse _ r :: Response
r -> ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Response -> ByteString
go Response
r
    e :: ClientError
e -> ClientError -> IO ByteString
forall e a. Exception e => e -> IO a
throwIO ClientError
e
  where
  go :: Response -> ByteString
go r :: Response
r = ByteString
prefix ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
message
    where
    prefix :: ByteString
prefix = case Status -> Int
HTTP.statusCode (Response -> Status
forall a. ResponseF a -> Status
responseStatusCode Response
r) of
      400 -> ""
      c :: Int
c -> "HTTP " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> String -> ByteString
Lazy.Char8.pack (Int -> String
forall a. Show a => a -> String
show Int
c) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ": "

    message :: ByteString
message =
      if ByteString -> Bool
Lazy.Char8.null (Response -> ByteString
forall a. ResponseF a -> a
responseBody Response
r) then
        "(no message)"
      else
        Response -> ByteString
forall a. ResponseF a -> a
responseBody Response
r

-- | Access the runtime state with the supplied function.
gets :: (ClientState -> a) -> PsqlM a
gets :: (ClientState -> a) -> PsqlM a
gets f :: ClientState -> a
f = do
  IORef ClientState
ref <- ReaderT PsqlEnv IO (IORef ClientState)
-> InputT (ReaderT PsqlEnv IO) (IORef ClientState)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT PsqlEnv IO (IORef ClientState)
 -> InputT (ReaderT PsqlEnv IO) (IORef ClientState))
-> ReaderT PsqlEnv IO (IORef ClientState)
-> InputT (ReaderT PsqlEnv IO) (IORef ClientState)
forall a b. (a -> b) -> a -> b
$ (PsqlEnv -> IORef ClientState)
-> ReaderT PsqlEnv IO (IORef ClientState)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PsqlEnv -> IORef ClientState
state
  ClientState
s <- IO ClientState -> PsqlM ClientState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ClientState -> PsqlM ClientState)
-> IO ClientState -> PsqlM ClientState
forall a b. (a -> b) -> a -> b
$ IORef ClientState -> IO ClientState
forall a. IORef a -> IO a
readIORef IORef ClientState
ref
  a -> PsqlM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> PsqlM a) -> a -> PsqlM a
forall a b. (a -> b) -> a -> b
$ ClientState -> a
f ClientState
s

-- | Modify the runtime state given the supplied function.
modify :: (ClientState -> ClientState) -> PsqlM ClientState
modify :: (ClientState -> ClientState) -> PsqlM ClientState
modify f :: ClientState -> ClientState
f = do
  IORef ClientState
ref <- ReaderT PsqlEnv IO (IORef ClientState)
-> InputT (ReaderT PsqlEnv IO) (IORef ClientState)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT PsqlEnv IO (IORef ClientState)
 -> InputT (ReaderT PsqlEnv IO) (IORef ClientState))
-> ReaderT PsqlEnv IO (IORef ClientState)
-> InputT (ReaderT PsqlEnv IO) (IORef ClientState)
forall a b. (a -> b) -> a -> b
$ (PsqlEnv -> IORef ClientState)
-> ReaderT PsqlEnv IO (IORef ClientState)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PsqlEnv -> IORef ClientState
state
  IO ClientState -> PsqlM ClientState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ClientState -> PsqlM ClientState)
-> IO ClientState -> PsqlM ClientState
forall a b. (a -> b) -> a -> b
$ IORef ClientState
-> (ClientState -> (ClientState, ClientState)) -> IO ClientState
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef ClientState
ref \s :: ClientState
s -> let s' :: ClientState
s' = ClientState -> ClientState
f ClientState
s in (ClientState
s', ClientState
s')

-- | The default, initial 'PsqlEnv' used by the @hipsql@ client.
initPsqlEnv :: ServantClient -> IO PsqlEnv
initPsqlEnv :: ServantClient -> IO PsqlEnv
initPsqlEnv = ClientIO -> ServantClient -> IO PsqlEnv
initPsqlEnv' ClientIO
defaultClientIO

-- | Same as 'initPsqlEnv' but allows for specifying the 'ClientIO'; mostly
-- useful for tests.
initPsqlEnv' :: ClientIO -> ServantClient -> IO PsqlEnv
initPsqlEnv' :: ClientIO -> ServantClient -> IO PsqlEnv
initPsqlEnv' io :: ClientIO
io servantClient :: ServantClient
servantClient = do
  Version
serverApiVersion <- ServantClient
-> AsClientT IO
   :- (Summary "Gets the current server version"
       :> ("version" :> Get '[JSON] Version))
forall route.
HipsqlRoutes route
-> route
   :- (Summary "Gets the current server version"
       :> ("version" :> Get '[JSON] Version))
getVersion ServantClient
servantClient
  IORef ClientState
state <- ClientState -> IO (IORef ClientState)
forall a. a -> IO (IORef a)
newIORef ClientState :: ByteString -> ClientState
ClientState { queryBuffer :: ByteString
queryBuffer = ByteString
forall a. Monoid a => a
mempty }
  PsqlEnv -> IO PsqlEnv
forall (f :: * -> *) a. Applicative f => a -> f a
pure PsqlEnv :: Version
-> IORef ClientState
-> ClientIO
-> (ByteString -> IO ByteString)
-> PsqlEnv
PsqlEnv
    { Version
serverApiVersion :: Version
serverApiVersion :: Version
serverApiVersion
    , IORef ClientState
state :: IORef ClientState
state :: IORef ClientState
state
    , ClientIO
io :: ClientIO
io :: ClientIO
io
    , serverEval' :: ByteString -> IO ByteString
serverEval' = ServantClient -> ByteString -> IO ByteString
getServerEval ServantClient
servantClient
    }

-- | The default 'ClientIO' operations
defaultClientIO :: ClientIO
defaultClientIO :: ClientIO
defaultClientIO = ClientIO :: (String -> PsqlM (Maybe String))
-> (ByteString -> InputT (ReaderT PsqlEnv IO) ()) -> ClientIO
ClientIO
  { inputStrLn' :: String -> PsqlM (Maybe String)
inputStrLn' = String -> PsqlM (Maybe String)
forall (m :: * -> *).
MonadException m =>
String -> InputT m (Maybe String)
getInputLine
  , writeLBSLn' :: ByteString -> InputT (ReaderT PsqlEnv IO) ()
writeLBSLn' = IO () -> InputT (ReaderT PsqlEnv IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> InputT (ReaderT PsqlEnv IO) ())
-> (ByteString -> IO ())
-> ByteString
-> InputT (ReaderT PsqlEnv IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> IO ()
Lazy.Char8.putStrLn
  }

-- | Writes the supplied 'String' to stdout as the shell prompt
-- and reads a line from stdin as a 'String'.
inputStrLn :: String -> PsqlM (Maybe String)
inputStrLn :: String -> PsqlM (Maybe String)
inputStrLn s :: String
s = do
  String -> PsqlM (Maybe String)
f <- ReaderT PsqlEnv IO (String -> PsqlM (Maybe String))
-> InputT (ReaderT PsqlEnv IO) (String -> PsqlM (Maybe String))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT PsqlEnv IO (String -> PsqlM (Maybe String))
 -> InputT (ReaderT PsqlEnv IO) (String -> PsqlM (Maybe String)))
-> ReaderT PsqlEnv IO (String -> PsqlM (Maybe String))
-> InputT (ReaderT PsqlEnv IO) (String -> PsqlM (Maybe String))
forall a b. (a -> b) -> a -> b
$ (PsqlEnv -> String -> PsqlM (Maybe String))
-> ReaderT PsqlEnv IO (String -> PsqlM (Maybe String))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((PsqlEnv -> String -> PsqlM (Maybe String))
 -> ReaderT PsqlEnv IO (String -> PsqlM (Maybe String)))
-> (PsqlEnv -> String -> PsqlM (Maybe String))
-> ReaderT PsqlEnv IO (String -> PsqlM (Maybe String))
forall a b. (a -> b) -> a -> b
$ ClientIO -> String -> PsqlM (Maybe String)
inputStrLn' (ClientIO -> String -> PsqlM (Maybe String))
-> (PsqlEnv -> ClientIO)
-> PsqlEnv
-> String
-> PsqlM (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PsqlEnv -> ClientIO
io
  String -> PsqlM (Maybe String)
f String
s

-- | Writes the supplied 'ByteString' to stdout.
writeLBSLn :: Lazy.ByteString -> PsqlM ()
writeLBSLn :: ByteString -> InputT (ReaderT PsqlEnv IO) ()
writeLBSLn s :: ByteString
s = do
  ByteString -> InputT (ReaderT PsqlEnv IO) ()
f <- ReaderT PsqlEnv IO (ByteString -> InputT (ReaderT PsqlEnv IO) ())
-> InputT
     (ReaderT PsqlEnv IO) (ByteString -> InputT (ReaderT PsqlEnv IO) ())
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT PsqlEnv IO (ByteString -> InputT (ReaderT PsqlEnv IO) ())
 -> InputT
      (ReaderT PsqlEnv IO)
      (ByteString -> InputT (ReaderT PsqlEnv IO) ()))
-> ReaderT
     PsqlEnv IO (ByteString -> InputT (ReaderT PsqlEnv IO) ())
-> InputT
     (ReaderT PsqlEnv IO) (ByteString -> InputT (ReaderT PsqlEnv IO) ())
forall a b. (a -> b) -> a -> b
$ (PsqlEnv -> ByteString -> InputT (ReaderT PsqlEnv IO) ())
-> ReaderT
     PsqlEnv IO (ByteString -> InputT (ReaderT PsqlEnv IO) ())
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((PsqlEnv -> ByteString -> InputT (ReaderT PsqlEnv IO) ())
 -> ReaderT
      PsqlEnv IO (ByteString -> InputT (ReaderT PsqlEnv IO) ()))
-> (PsqlEnv -> ByteString -> InputT (ReaderT PsqlEnv IO) ())
-> ReaderT
     PsqlEnv IO (ByteString -> InputT (ReaderT PsqlEnv IO) ())
forall a b. (a -> b) -> a -> b
$ ClientIO -> ByteString -> InputT (ReaderT PsqlEnv IO) ()
writeLBSLn' (ClientIO -> ByteString -> InputT (ReaderT PsqlEnv IO) ())
-> (PsqlEnv -> ClientIO)
-> PsqlEnv
-> ByteString
-> InputT (ReaderT PsqlEnv IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PsqlEnv -> ClientIO
io
  ByteString -> InputT (ReaderT PsqlEnv IO) ()
f ByteString
s

serverEval :: Lazy.ByteString -> PsqlM Lazy.ByteString
serverEval :: ByteString -> InputT (ReaderT PsqlEnv IO) ByteString
serverEval s :: ByteString
s = do
  ByteString -> IO ByteString
f <- ReaderT PsqlEnv IO (ByteString -> IO ByteString)
-> InputT (ReaderT PsqlEnv IO) (ByteString -> IO ByteString)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT PsqlEnv IO (ByteString -> IO ByteString)
 -> InputT (ReaderT PsqlEnv IO) (ByteString -> IO ByteString))
-> ReaderT PsqlEnv IO (ByteString -> IO ByteString)
-> InputT (ReaderT PsqlEnv IO) (ByteString -> IO ByteString)
forall a b. (a -> b) -> a -> b
$ (PsqlEnv -> ByteString -> IO ByteString)
-> ReaderT PsqlEnv IO (ByteString -> IO ByteString)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PsqlEnv -> ByteString -> IO ByteString
serverEval'
  IO ByteString -> InputT (ReaderT PsqlEnv IO) ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> InputT (ReaderT PsqlEnv IO) ByteString)
-> IO ByteString -> InputT (ReaderT PsqlEnv IO) ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> IO ByteString
f ByteString
s

type ServantClient = HipsqlRoutes (AsClientT IO)

mkServantClient :: HTTPClient.Manager -> Int -> IO ServantClient
mkServantClient :: Manager -> Int -> IO ServantClient
mkServantClient httpManager :: Manager
httpManager port :: Int
port = do
  BaseUrl
url <- String -> IO BaseUrl
forall (m :: * -> *). MonadThrow m => String -> m BaseUrl
parseBaseUrl (String -> IO BaseUrl) -> String -> IO BaseUrl
forall a b. (a -> b) -> a -> b
$ "127.0.0.1:" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
port
  let clientEnv :: ClientEnv
clientEnv = Manager -> BaseUrl -> ClientEnv
mkClientEnv Manager
httpManager BaseUrl
url
  ServantClient -> IO ServantClient
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServantClient -> IO ServantClient)
-> ServantClient -> IO ServantClient
forall a b. (a -> b) -> a -> b
$
    (forall x. ClientM x -> IO x) -> ServantClient
forall (routes :: * -> *) (m :: * -> *) (n :: * -> *).
(HasClient m (ToServantApi routes),
 GenericServant routes (AsClientT n),
 Client n (ToServantApi routes) ~ ToServant routes (AsClientT n)) =>
(forall x. m x -> n x) -> routes (AsClientT n)
genericClientHoist ((forall x. ClientM x -> IO x) -> ServantClient)
-> (forall x. ClientM x -> IO x) -> ServantClient
forall a b. (a -> b) -> a -> b
$
      (ClientError -> IO x)
-> (x -> IO x) -> Either ClientError x -> IO x
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ClientError -> IO x
forall e a. Exception e => e -> IO a
throwIO x -> IO x
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (Either ClientError x -> IO x)
-> (ClientM x -> IO (Either ClientError x)) -> ClientM x -> IO x
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (ClientM x -> ClientEnv -> IO (Either ClientError x))
-> ClientEnv -> ClientM x -> IO (Either ClientError x)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ClientM x -> ClientEnv -> IO (Either ClientError x)
forall a. ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM ClientEnv
clientEnv

-- $disclaimer
--
-- Changes to this module will not be reflected in the library's version
-- updates.