{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Hipsql.Client.Internal
(
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
theHipsqlClientVersion :: Version
theHipsqlClientVersion :: Version
theHipsqlClientVersion = Version -> Version
mkVersion Version
Paths_hipsql_client.version
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 :: 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
<> "]"
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
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
}
newtype ClientState = ClientState
{ ClientState -> ByteString
queryBuffer :: ByteString
}
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
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 }
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
}
data ClientIO = ClientIO
{ ClientIO -> String -> PsqlM (Maybe String)
inputStrLn' :: String -> PsqlM (Maybe String)
, ClientIO -> ByteString -> InputT (ReaderT PsqlEnv IO) ()
writeLBSLn' :: Lazy.ByteString -> PsqlM ()
}
type PsqlM = InputT (ReaderT PsqlEnv IO)
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
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 :: (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')
initPsqlEnv :: ServantClient -> IO PsqlEnv
initPsqlEnv :: ServantClient -> IO PsqlEnv
initPsqlEnv = ClientIO -> ServantClient -> IO PsqlEnv
initPsqlEnv' ClientIO
defaultClientIO
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
}
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
}
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
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