{-# LANGUAGE DuplicateRecordFields, TypeFamilies #-}
module Network.Greskell.WebSocket.Client.Impl
where
import Control.Applicative ((<$>), (<*>))
import Control.Concurrent.STM
( STM, atomically,
TVar, newTVarIO, readTVar, writeTVar
)
import Control.Exception.Safe
( throw, Typeable, Exception, SomeException, catch
)
import Data.Aeson (Object)
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson (Parser)
import Data.Greskell.Greskell (ToGreskell(GreskellReturn), toGremlin)
import Data.Greskell.GraphSON (GraphSON, gsonValue, GValue, FromGraphSON(..), parseEither)
import Data.Greskell.AsIterator (AsIterator(IteratorItem))
import Data.Monoid (mempty)
import Data.Vector (Vector, (!))
import Data.Text (Text)
import Data.Traversable (traverse)
import Data.Vector (Vector)
import Network.Greskell.WebSocket.Client.Options (Options)
import qualified Network.Greskell.WebSocket.Client.Options as Opt
import Network.Greskell.WebSocket.Connection
( Host, Port, Connection, ResponseHandle
)
import qualified Network.Greskell.WebSocket.Connection as Conn
import qualified Network.Greskell.WebSocket.Request.Standard as ReqStd
import Network.Greskell.WebSocket.Response (ResponseCode, ResponseMessage)
import qualified Network.Greskell.WebSocket.Response as Res
import Network.Greskell.WebSocket.Util (slurp, drain)
data Client =
Client
{ Client -> Options
clientOpts :: Options,
Client -> Connection GValue
clientConn :: Connection GValue
}
connect :: Host -> Port -> IO Client
connect :: Host -> Port -> IO Client
connect = Options -> Host -> Port -> IO Client
connectWith Options
Opt.defOptions
connectWith :: Options -> Host -> Port -> IO Client
connectWith :: Options -> Host -> Port -> IO Client
connectWith Options
opts Host
host Port
port = do
Connection GValue
conn <- Settings GValue -> Host -> Port -> IO (Connection GValue)
forall s. Settings s -> Host -> Port -> IO (Connection s)
Conn.connect (Options -> Settings GValue
Opt.connectionSettings Options
opts) Host
host Port
port
Client -> IO Client
forall (m :: * -> *) a. Monad m => a -> m a
return (Client -> IO Client) -> Client -> IO Client
forall a b. (a -> b) -> a -> b
$ Client :: Options -> Connection GValue -> Client
Client { $sel:clientOpts:Client :: Options
clientOpts = Options
opts,
$sel:clientConn:Client :: Connection GValue
clientConn = Connection GValue
conn
}
close :: Client -> IO ()
close :: Client -> IO ()
close Client
c = Connection GValue -> IO ()
forall s. Connection s -> IO ()
Conn.close (Connection GValue -> IO ()) -> Connection GValue -> IO ()
forall a b. (a -> b) -> a -> b
$ Client -> Connection GValue
clientConn Client
c
data HandleState =
HandleOpen
| HandleClose
| HandleError SomeException
deriving (Port -> HandleState -> ShowS
[HandleState] -> ShowS
HandleState -> Host
(Port -> HandleState -> ShowS)
-> (HandleState -> Host)
-> ([HandleState] -> ShowS)
-> Show HandleState
forall a.
(Port -> a -> ShowS) -> (a -> Host) -> ([a] -> ShowS) -> Show a
showList :: [HandleState] -> ShowS
$cshowList :: [HandleState] -> ShowS
show :: HandleState -> Host
$cshow :: HandleState -> Host
showsPrec :: Port -> HandleState -> ShowS
$cshowsPrec :: Port -> HandleState -> ShowS
Show)
data ResultHandle v =
ResultHandle
{ ResultHandle v -> ResponseHandle GValue
rhResHandle :: ResponseHandle GValue,
ResultHandle v -> GValue -> Either Host (Vector v)
rhParseGValue :: GValue -> Either String (Vector v),
ResultHandle v -> TVar (Vector v)
rhResultCache :: TVar (Vector v),
ResultHandle v -> TVar Port
rhNextResultIndex :: TVar Int,
ResultHandle v -> TVar HandleState
rhState :: TVar HandleState
}
submitBase :: FromGraphSON r => Client -> Text -> Maybe Object -> IO (ResultHandle r)
submitBase :: Client -> Text -> Maybe Object -> IO (ResultHandle r)
submitBase Client
client Text
script Maybe Object
bindings = do
ResponseHandle GValue
rh <- Connection GValue -> OpEval -> IO (ResponseHandle GValue)
forall o s.
Operation o =>
Connection s -> o -> IO (ResponseHandle s)
Conn.sendRequest Connection GValue
conn OpEval
op
(TVar (Vector r)
cache, TVar Port
index, TVar HandleState
state) <- (,,) (TVar (Vector r)
-> TVar Port
-> TVar HandleState
-> (TVar (Vector r), TVar Port, TVar HandleState))
-> IO (TVar (Vector r))
-> IO
(TVar Port
-> TVar HandleState
-> (TVar (Vector r), TVar Port, TVar HandleState))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector r -> IO (TVar (Vector r))
forall a. a -> IO (TVar a)
newTVarIO Vector r
forall a. Monoid a => a
mempty IO
(TVar Port
-> TVar HandleState
-> (TVar (Vector r), TVar Port, TVar HandleState))
-> IO (TVar Port)
-> IO
(TVar HandleState
-> (TVar (Vector r), TVar Port, TVar HandleState))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Port -> IO (TVar Port)
forall a. a -> IO (TVar a)
newTVarIO Port
0 IO
(TVar HandleState
-> (TVar (Vector r), TVar Port, TVar HandleState))
-> IO (TVar HandleState)
-> IO (TVar (Vector r), TVar Port, TVar HandleState)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HandleState -> IO (TVar HandleState)
forall a. a -> IO (TVar a)
newTVarIO HandleState
HandleOpen
ResultHandle r -> IO (ResultHandle r)
forall (m :: * -> *) a. Monad m => a -> m a
return (ResultHandle r -> IO (ResultHandle r))
-> ResultHandle r -> IO (ResultHandle r)
forall a b. (a -> b) -> a -> b
$ ResultHandle :: forall v.
ResponseHandle GValue
-> (GValue -> Either Host (Vector v))
-> TVar (Vector v)
-> TVar Port
-> TVar HandleState
-> ResultHandle v
ResultHandle { $sel:rhResHandle:ResultHandle :: ResponseHandle GValue
rhResHandle = ResponseHandle GValue
rh,
$sel:rhParseGValue:ResultHandle :: GValue -> Either Host (Vector r)
rhParseGValue = GValue -> Either Host (Vector r)
forall a. FromGraphSON a => GValue -> Either Host a
parseEither,
$sel:rhResultCache:ResultHandle :: TVar (Vector r)
rhResultCache = TVar (Vector r)
cache,
$sel:rhNextResultIndex:ResultHandle :: TVar Port
rhNextResultIndex = TVar Port
index,
$sel:rhState:ResultHandle :: TVar HandleState
rhState = TVar HandleState
state
}
where
conn :: Connection GValue
conn = Client -> Connection GValue
clientConn Client
client
opts :: Options
opts = Client -> Options
clientOpts Client
client
op :: OpEval
op = OpEval :: Maybe Port
-> Text
-> Maybe Object
-> Maybe Text
-> Maybe (HashMap Text Text)
-> Maybe Port
-> OpEval
ReqStd.OpEval { $sel:batchSize:OpEval :: Maybe Port
ReqStd.batchSize = Options -> Maybe Port
Opt.batchSize Options
opts,
$sel:gremlin:OpEval :: Text
ReqStd.gremlin = Text
script,
$sel:bindings:OpEval :: Maybe Object
ReqStd.bindings = Maybe Object
bindings,
$sel:language:OpEval :: Maybe Text
ReqStd.language = Options -> Maybe Text
Opt.language Options
opts,
$sel:aliases:OpEval :: Maybe (HashMap Text Text)
ReqStd.aliases = Options -> Maybe (HashMap Text Text)
Opt.aliases Options
opts,
$sel:scriptEvaluationTimeout:OpEval :: Maybe Port
ReqStd.scriptEvaluationTimeout = Options -> Maybe Port
Opt.scriptEvaluationTimeout Options
opts
}
submit :: (ToGreskell g, r ~ GreskellReturn g, AsIterator r, v ~ IteratorItem r, FromGraphSON v)
=> Client
-> g
-> Maybe Object
-> IO (ResultHandle v)
submit :: Client -> g -> Maybe Object -> IO (ResultHandle v)
submit Client
client g
greskell Maybe Object
bindings = Client -> Text -> Maybe Object -> IO (ResultHandle v)
forall r.
FromGraphSON r =>
Client -> Text -> Maybe Object -> IO (ResultHandle r)
submitBase Client
client (g -> Text
forall a. ToGreskell a => a -> Text
toGremlin g
greskell) Maybe Object
bindings
submitPair :: (ToGreskell g, r ~ GreskellReturn g, AsIterator r, v ~ IteratorItem r, FromGraphSON v)
=> Client
-> (g, Object)
-> IO (ResultHandle v)
submitPair :: Client -> (g, Object) -> IO (ResultHandle v)
submitPair Client
c (g
g, Object
b) = Client -> g -> Maybe Object -> IO (ResultHandle v)
forall g r v.
(ToGreskell g, r ~ GreskellReturn g, AsIterator r,
v ~ IteratorItem r, FromGraphSON v) =>
Client -> g -> Maybe Object -> IO (ResultHandle v)
submit Client
c g
g (Object -> Maybe Object
forall a. a -> Maybe a
Just Object
b)
submitRaw :: Client
-> Text
-> Maybe Object
-> IO (ResultHandle GValue)
submitRaw :: Client -> Text -> Maybe Object -> IO (ResultHandle GValue)
submitRaw = Client -> Text -> Maybe Object -> IO (ResultHandle GValue)
forall r.
FromGraphSON r =>
Client -> Text -> Maybe Object -> IO (ResultHandle r)
submitBase
data SubmitException =
ResponseError (ResponseMessage GValue)
| ParseError (ResponseMessage GValue) String
deriving (Port -> SubmitException -> ShowS
[SubmitException] -> ShowS
SubmitException -> Host
(Port -> SubmitException -> ShowS)
-> (SubmitException -> Host)
-> ([SubmitException] -> ShowS)
-> Show SubmitException
forall a.
(Port -> a -> ShowS) -> (a -> Host) -> ([a] -> ShowS) -> Show a
showList :: [SubmitException] -> ShowS
$cshowList :: [SubmitException] -> ShowS
show :: SubmitException -> Host
$cshow :: SubmitException -> Host
showsPrec :: Port -> SubmitException -> ShowS
$cshowsPrec :: Port -> SubmitException -> ShowS
Show,Typeable)
instance Exception SubmitException
nextResult :: ResultHandle v -> IO (Maybe v)
nextResult :: ResultHandle v -> IO (Maybe v)
nextResult = STM (Maybe v) -> IO (Maybe v)
forall a. STM a -> IO a
atomically (STM (Maybe v) -> IO (Maybe v))
-> (ResultHandle v -> STM (Maybe v))
-> ResultHandle v
-> IO (Maybe v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResultHandle v -> STM (Maybe v)
forall v. ResultHandle v -> STM (Maybe v)
nextResultSTM
nextResultSTM :: ResultHandle v -> STM (Maybe v)
nextResultSTM :: ResultHandle v -> STM (Maybe v)
nextResultSTM ResultHandle v
rh = do
HandleState
cur_state <- TVar HandleState -> STM HandleState
forall a. TVar a -> STM a
readTVar (TVar HandleState -> STM HandleState)
-> TVar HandleState -> STM HandleState
forall a b. (a -> b) -> a -> b
$ ResultHandle v -> TVar HandleState
forall v. ResultHandle v -> TVar HandleState
rhState ResultHandle v
rh
case HandleState
cur_state of
HandleError SomeException
err -> SomeException -> STM (Maybe v)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw SomeException
err
HandleState
HandleClose -> Maybe v -> STM (Maybe v)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe v
forall a. Maybe a
Nothing
HandleState
HandleOpen -> STM (Maybe v)
doNext STM (Maybe v) -> (SomeException -> STM ()) -> STM (Maybe v)
forall (m :: * -> *) e a a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`withExceptionSTM` SomeException -> STM ()
gotoError
where
doNext :: STM (Maybe v)
doNext = do
Maybe v
mret <- STM (Maybe v)
getNext
case Maybe v
mret of
Maybe v
Nothing -> TVar HandleState -> HandleState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (ResultHandle v -> TVar HandleState
forall v. ResultHandle v -> TVar HandleState
rhState ResultHandle v
rh) HandleState
HandleClose
Maybe v
_ -> () -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe v -> STM (Maybe v)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe v
mret
getNext :: STM (Maybe v)
getNext = do
Maybe v
mnext <- ResultHandle v -> STM (Maybe v)
forall v. ResultHandle v -> STM (Maybe v)
getNextCachedResult ResultHandle v
rh
case Maybe v
mnext of
Just v
v -> Maybe v -> STM (Maybe v)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe v -> STM (Maybe v)) -> Maybe v -> STM (Maybe v)
forall a b. (a -> b) -> a -> b
$ v -> Maybe v
forall a. a -> Maybe a
Just v
v
Maybe v
Nothing -> ResultHandle v -> STM (Maybe v)
forall v. ResultHandle v -> STM (Maybe v)
loadResponse ResultHandle v
rh
withExceptionSTM :: m a -> (e -> m a) -> m a
withExceptionSTM m a
main e -> m a
finish =
m a
main m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\e
ex -> e -> m a
finish e
ex m a -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw e
ex)
gotoError :: SomeException -> STM ()
gotoError SomeException
ex = TVar HandleState -> HandleState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (ResultHandle v -> TVar HandleState
forall v. ResultHandle v -> TVar HandleState
rhState ResultHandle v
rh) (HandleState -> STM ()) -> HandleState -> STM ()
forall a b. (a -> b) -> a -> b
$ SomeException -> HandleState
HandleError SomeException
ex
getNextCachedResult :: ResultHandle v -> STM (Maybe v)
getNextCachedResult :: ResultHandle v -> STM (Maybe v)
getNextCachedResult ResultHandle v
rh = do
(Vector v
cache, Port
index) <- (,) (Vector v -> Port -> (Vector v, Port))
-> STM (Vector v) -> STM (Port -> (Vector v, Port))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TVar (Vector v) -> STM (Vector v)
forall a. TVar a -> STM a
readTVar (TVar (Vector v) -> STM (Vector v))
-> TVar (Vector v) -> STM (Vector v)
forall a b. (a -> b) -> a -> b
$ ResultHandle v -> TVar (Vector v)
forall v. ResultHandle v -> TVar (Vector v)
rhResultCache ResultHandle v
rh) STM (Port -> (Vector v, Port)) -> STM Port -> STM (Vector v, Port)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TVar Port -> STM Port
forall a. TVar a -> STM a
readTVar (TVar Port -> STM Port) -> TVar Port -> STM Port
forall a b. (a -> b) -> a -> b
$ ResultHandle v -> TVar Port
forall v. ResultHandle v -> TVar Port
rhNextResultIndex ResultHandle v
rh)
if Port
index Port -> Port -> Bool
forall a. Ord a => a -> a -> Bool
< Vector v -> Port
forall (t :: * -> *) a. Foldable t => t a -> Port
length Vector v
cache
then Vector v -> Port -> STM (Maybe v)
fromCache Vector v
cache Port
index
else Maybe v -> STM (Maybe v)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe v
forall a. Maybe a
Nothing
where
fromCache :: Vector v -> Port -> STM (Maybe v)
fromCache Vector v
cache Port
index = do
TVar Port -> Port -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (ResultHandle v -> TVar Port
forall v. ResultHandle v -> TVar Port
rhNextResultIndex ResultHandle v
rh) (Port -> STM ()) -> Port -> STM ()
forall a b. (a -> b) -> a -> b
$ Port
index Port -> Port -> Port
forall a. Num a => a -> a -> a
+ Port
1
Maybe v -> STM (Maybe v)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe v -> STM (Maybe v)) -> Maybe v -> STM (Maybe v)
forall a b. (a -> b) -> a -> b
$ v -> Maybe v
forall a. a -> Maybe a
Just (Vector v
cache Vector v -> Port -> v
forall a. Vector a -> Port -> a
! Port
index)
loadResponse :: ResultHandle v -> STM (Maybe v)
loadResponse :: ResultHandle v -> STM (Maybe v)
loadResponse ResultHandle v
rh = Maybe (ResponseMessage GValue) -> STM (Maybe v)
parseResponse (Maybe (ResponseMessage GValue) -> STM (Maybe v))
-> STM (Maybe (ResponseMessage GValue)) -> STM (Maybe v)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ResponseHandle GValue -> STM (Maybe (ResponseMessage GValue))
forall s. ResponseHandle s -> STM (Maybe (ResponseMessage s))
Conn.nextResponseSTM (ResponseHandle GValue -> STM (Maybe (ResponseMessage GValue)))
-> ResponseHandle GValue -> STM (Maybe (ResponseMessage GValue))
forall a b. (a -> b) -> a -> b
$ ResultHandle v -> ResponseHandle GValue
forall v. ResultHandle v -> ResponseHandle GValue
rhResHandle ResultHandle v
rh)
where
parseResponse :: Maybe (ResponseMessage GValue) -> STM (Maybe v)
parseResponse Maybe (ResponseMessage GValue)
Nothing = Maybe v -> STM (Maybe v)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe v
forall a. Maybe a
Nothing
parseResponse (Just ResponseMessage GValue
res) =
case ResponseStatus -> ResponseCode
Res.code (ResponseStatus -> ResponseCode) -> ResponseStatus -> ResponseCode
forall a b. (a -> b) -> a -> b
$ ResponseMessage GValue -> ResponseStatus
forall s. ResponseMessage s -> ResponseStatus
Res.status ResponseMessage GValue
res of
ResponseCode
Res.Success -> ResponseMessage GValue -> STM (Maybe v)
parseData ResponseMessage GValue
res
ResponseCode
Res.NoContent -> Maybe v -> STM (Maybe v)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe v
forall a. Maybe a
Nothing
ResponseCode
Res.PartialContent -> ResponseMessage GValue -> STM (Maybe v)
parseData ResponseMessage GValue
res
ResponseCode
_ -> SubmitException -> STM (Maybe v)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw (SubmitException -> STM (Maybe v))
-> SubmitException -> STM (Maybe v)
forall a b. (a -> b) -> a -> b
$ ResponseMessage GValue -> SubmitException
ResponseError ResponseMessage GValue
res
parseData :: ResponseMessage GValue -> STM (Maybe v)
parseData ResponseMessage GValue
res =
case ResultHandle v -> GValue -> Either Host (Vector v)
forall v. ResultHandle v -> GValue -> Either Host (Vector v)
rhParseGValue ResultHandle v
rh (GValue -> Either Host (Vector v))
-> GValue -> Either Host (Vector v)
forall a b. (a -> b) -> a -> b
$ ResponseResult GValue -> GValue
forall s. ResponseResult s -> s
Res.resultData (ResponseResult GValue -> GValue)
-> ResponseResult GValue -> GValue
forall a b. (a -> b) -> a -> b
$ ResponseMessage GValue -> ResponseResult GValue
forall s. ResponseMessage s -> ResponseResult s
Res.result ResponseMessage GValue
res of
Left Host
err -> SubmitException -> STM (Maybe v)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw (SubmitException -> STM (Maybe v))
-> SubmitException -> STM (Maybe v)
forall a b. (a -> b) -> a -> b
$ ResponseMessage GValue -> Host -> SubmitException
ParseError ResponseMessage GValue
res Host
err
Right Vector v
parsed -> do
TVar (Vector v) -> Vector v -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (ResultHandle v -> TVar (Vector v)
forall v. ResultHandle v -> TVar (Vector v)
rhResultCache ResultHandle v
rh) Vector v
parsed
if Vector v -> Port
forall (t :: * -> *) a. Foldable t => t a -> Port
length Vector v
parsed Port -> Port -> Bool
forall a. Eq a => a -> a -> Bool
== Port
0
then do
TVar Port -> Port -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (ResultHandle v -> TVar Port
forall v. ResultHandle v -> TVar Port
rhNextResultIndex ResultHandle v
rh) Port
0
Maybe v -> STM (Maybe v)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe v
forall a. Maybe a
Nothing
else do
TVar Port -> Port -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (ResultHandle v -> TVar Port
forall v. ResultHandle v -> TVar Port
rhNextResultIndex ResultHandle v
rh) Port
1
Maybe v -> STM (Maybe v)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe v -> STM (Maybe v)) -> Maybe v -> STM (Maybe v)
forall a b. (a -> b) -> a -> b
$ v -> Maybe v
forall a. a -> Maybe a
Just (Vector v
parsed Vector v -> Port -> v
forall a. Vector a -> Port -> a
! Port
0)
slurpResults :: ResultHandle v -> IO (Vector v)
slurpResults :: ResultHandle v -> IO (Vector v)
slurpResults ResultHandle v
h = IO (Maybe v) -> IO (Vector v)
forall (m :: * -> *) a. Monad m => m (Maybe a) -> m (Vector a)
slurp (IO (Maybe v) -> IO (Vector v)) -> IO (Maybe v) -> IO (Vector v)
forall a b. (a -> b) -> a -> b
$ ResultHandle v -> IO (Maybe v)
forall v. ResultHandle v -> IO (Maybe v)
nextResult ResultHandle v
h
drainResults :: ResultHandle v -> IO ()
drainResults :: ResultHandle v -> IO ()
drainResults ResultHandle v
h = IO (Maybe v) -> IO ()
forall (m :: * -> *) a. Monad m => m (Maybe a) -> m ()
drain (IO (Maybe v) -> IO ()) -> IO (Maybe v) -> IO ()
forall a b. (a -> b) -> a -> b
$ ResultHandle v -> IO (Maybe v)
forall v. ResultHandle v -> IO (Maybe v)
nextResult ResultHandle v
h