{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE TypeFamilies          #-}
-- |
-- Module: Network.Greskell.WebSocket.Client.Impl
-- Description:
-- Maintainer: Toshio Ito <debug.ito@gmail.com>
--
-- __Internal module__. It's like
-- "Network.Greskell.WebSocket.Connection.Impl".
module Network.Greskell.WebSocket.Client.Impl where

import           Control.Applicative                         ((<$>), (<*>))
import           Control.Concurrent.STM                      (STM, TVar, atomically, newTVarIO,
                                                              readTVar, writeTVar)
import           Control.Exception.Safe                      (Exception, SomeException, Typeable,
                                                              catch, throw)
import           Data.Aeson                                  (Object)
import qualified Data.Aeson                                  as Aeson
import qualified Data.Aeson.Types                            as Aeson (Parser)
import           Data.Greskell.AsIterator                    (AsIterator (IteratorItem))
import           Data.Greskell.GraphSON                      (FromGraphSON (..), GValue, GraphSON,
                                                              gsonValue, parseEither)
import           Data.Greskell.Greskell                      (ToGreskell (GreskellReturn),
                                                              toGremlin)
import           Data.Monoid                                 (mempty)
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       (Connection, Host, Port,
                                                              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             (drain, slurp)


-- | A client that establishes a connection to the Gremlin Server. You
-- can send Gremlin expression for evaluation by 'submit' function.
data Client
  = Client
      { Client -> Options
clientOpts :: Options
      , Client -> Connection GValue
clientConn :: Connection GValue
      }

-- | Create a 'Client' to a Gremlin Server, with the default 'Options'.
connect :: Host -> Port -> IO Client
connect :: Host -> Port -> IO Client
connect = Options -> Host -> Port -> IO Client
connectWith Options
Opt.defOptions

-- | Create a 'Client' to a Gremlin Server.
connectWith :: Options -> Host -> Port -> IO Client
connectWith :: Options -> Host -> Port -> IO Client
connectWith Options
opts Host
host Port
port = do
  Connection GValue
conn <- forall s. Settings s -> Host -> Port -> IO (Connection s)
Conn.connect (Options -> Settings GValue
Opt.connectionSettings Options
opts) Host
host Port
port
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Client { $sel:clientOpts:Client :: Options
clientOpts = Options
opts,
                    $sel:clientConn:Client :: Connection GValue
clientConn = Connection GValue
conn
                  }

-- | Close the connection to the server and release other resources of
-- the 'Client'.
close :: Client -> IO ()
close :: Client -> IO ()
close Client
c = forall s. Connection s -> IO ()
Conn.close 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
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)

-- | A handle to receive the result of evaluation of a Gremlin script
-- from the server.
data ResultHandle v
  = ResultHandle
      { forall v. ResultHandle v -> ResponseHandle GValue
rhResHandle       :: ResponseHandle GValue
      , forall v. ResultHandle v -> GValue -> Either Host (Vector v)
rhParseGValue     :: GValue -> Either String (Vector v)
      , forall v. ResultHandle v -> TVar (Vector v)
rhResultCache     :: TVar (Vector v)
      , forall v. ResultHandle v -> TVar Port
rhNextResultIndex :: TVar Int
      , forall v. ResultHandle v -> TVar HandleState
rhState           :: TVar HandleState
      }

submitBase :: FromGraphSON r => Client -> Text -> Maybe Object -> IO (ResultHandle r)
submitBase :: forall r.
FromGraphSON r =>
Client -> Text -> Maybe Object -> IO (ResultHandle r)
submitBase Client
client Text
script Maybe Object
bindings = do
  ResponseHandle GValue
rh <- 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) <- (,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (TVar a)
newTVarIO forall a. Monoid a => a
mempty forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (TVar a)
newTVarIO Port
0 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (TVar a)
newTVarIO HandleState
HandleOpen
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ResultHandle { $sel:rhResHandle:ResultHandle :: ResponseHandle GValue
rhResHandle = ResponseHandle GValue
rh,
                          $sel:rhParseGValue:ResultHandle :: GValue -> Either Host (Vector r)
rhParseGValue = 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 = 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 a Gremlin script to the server. You can get its results by
-- 'ResultHandle'. The result type @v@ is determined by the script
-- type @g@.
--
-- Usually this function does not throw any exception. Exceptions
-- about sending requests are reported when you operate on
-- 'ResultHandle'.
submit :: (ToGreskell g, r ~ GreskellReturn g, AsIterator r, v ~ IteratorItem r, FromGraphSON v)
       => Client
       -> g -- ^ Gremlin script
       -> Maybe Object -- ^ bindings
       -> IO (ResultHandle v)
submit :: 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
client g
greskell Maybe Object
bindings = forall r.
FromGraphSON r =>
Client -> Text -> Maybe Object -> IO (ResultHandle r)
submitBase Client
client (forall a. ToGreskell a => a -> Text
toGremlin g
greskell) Maybe Object
bindings

-- | Submit a pair of Gremlin script and variable binding. It's just a
-- simple wrapper around 'submit'.
--
-- @since 0.1.2.0
submitPair :: (ToGreskell g, r ~ GreskellReturn g, AsIterator r, v ~ IteratorItem r, FromGraphSON v)
           => Client
           -> (g, Object)
           -> IO (ResultHandle v)
submitPair :: forall g r v.
(ToGreskell g, r ~ GreskellReturn g, AsIterator r,
 v ~ IteratorItem r, FromGraphSON v) =>
Client -> (g, Object) -> IO (ResultHandle v)
submitPair Client
c (g
g, Object
b) = 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 (forall a. a -> Maybe a
Just Object
b)

-- | Less type-safe version of 'submit'.
submitRaw :: Client
          -> Text -- ^ Gremlin script
          -> Maybe Object -- ^ bindings
          -> IO (ResultHandle GValue)
submitRaw :: Client -> Text -> Maybe Object -> IO (ResultHandle GValue)
submitRaw = forall r.
FromGraphSON r =>
Client -> Text -> Maybe Object -> IO (ResultHandle r)
submitBase

-- | Exception about 'submit' operation and getting its result.
data SubmitException
  = ResponseError (ResponseMessage GValue)
  -- ^ The server returns a 'ResponseMessage' with error 'ResponseCode'.
  | ParseError (ResponseMessage GValue) String
  -- ^ The client fails to parse the \"data\" field of the
  -- 'ResponseMessage'. The error message is kept in the 'String'
  -- field.
  deriving (Port -> SubmitException -> ShowS
[SubmitException] -> ShowS
SubmitException -> Host
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


-- | Get the next value from the 'ResultHandle'. If you have got all
-- values, it returns 'Nothing'.  This function may block for a new
-- response to come.
--
-- On error, it may throw all sorts of exceptions including
-- 'SubmitException' and 'Conn.RequestException'. For example, if the
-- submitted Gremlin script throws an exception, 'nextResult' throws
-- 'ResponseError' with 'ResponseCode' of 'Res.ScriptEvaluationError'.
nextResult :: ResultHandle v -> IO (Maybe v)
nextResult :: forall v. ResultHandle v -> IO (Maybe v)
nextResult = forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. ResultHandle v -> STM (Maybe v)
nextResultSTM

-- | 'STM' version of 'nextResult'.
nextResultSTM :: ResultHandle v -> STM (Maybe v)
nextResultSTM :: forall v. ResultHandle v -> STM (Maybe v)
nextResultSTM ResultHandle v
rh = do
  HandleState
cur_state <- forall a. TVar a -> STM a
readTVar forall a b. (a -> b) -> a -> b
$ forall v. ResultHandle v -> TVar HandleState
rhState ResultHandle v
rh
  case HandleState
cur_state of
   HandleError SomeException
err -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw SomeException
err
   HandleState
HandleClose     -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
   HandleState
HandleOpen      -> STM (Maybe v)
doNext 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 -> forall a. TVar a -> a -> STM ()
writeTVar (forall v. ResultHandle v -> TVar HandleState
rhState ResultHandle v
rh) HandleState
HandleClose
       Maybe v
_       -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      forall (m :: * -> *) a. Monad m => a -> m a
return Maybe v
mret
    getNext :: STM (Maybe v)
getNext = do
      Maybe v
mnext <- forall v. ResultHandle v -> STM (Maybe v)
getNextCachedResult ResultHandle v
rh
      case Maybe v
mnext of
       Just v
v  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just v
v
       Maybe v
Nothing -> forall v. ResultHandle v -> STM (Maybe v)
loadResponse ResultHandle v
rh
    -- 'withException' function is for MonadMask and STM is not a
    -- MonadMask. So we use catch-and-rethrow by hand.
    withExceptionSTM :: m a -> (e -> m a) -> m a
withExceptionSTM m a
main e -> m a
finish =
      m a
main forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\e
ex -> e -> m a
finish e
ex forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw e
ex)
    gotoError :: SomeException -> STM ()
gotoError SomeException
ex = forall a. TVar a -> a -> STM ()
writeTVar (forall v. ResultHandle v -> TVar HandleState
rhState ResultHandle v
rh) forall a b. (a -> b) -> a -> b
$ SomeException -> HandleState
HandleError SomeException
ex


getNextCachedResult :: ResultHandle v -> STM (Maybe v)
getNextCachedResult :: forall v. ResultHandle v -> STM (Maybe v)
getNextCachedResult ResultHandle v
rh = do
  (Vector v
cache, Port
index) <- (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. TVar a -> STM a
readTVar forall a b. (a -> b) -> a -> b
$ forall v. ResultHandle v -> TVar (Vector v)
rhResultCache ResultHandle v
rh) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. TVar a -> STM a
readTVar forall a b. (a -> b) -> a -> b
$ forall v. ResultHandle v -> TVar Port
rhNextResultIndex ResultHandle v
rh)
  if Port
index forall a. Ord a => a -> a -> Bool
< 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 forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
  where
    fromCache :: Vector v -> Port -> STM (Maybe v)
fromCache Vector v
cache Port
index = do
      forall a. TVar a -> a -> STM ()
writeTVar (forall v. ResultHandle v -> TVar Port
rhNextResultIndex ResultHandle v
rh) forall a b. (a -> b) -> a -> b
$ Port
index forall a. Num a => a -> a -> a
+ Port
1
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Vector v
cache forall a. Vector a -> Port -> a
! Port
index)

loadResponse :: ResultHandle v -> STM (Maybe v)
loadResponse :: forall v. ResultHandle v -> STM (Maybe v)
loadResponse ResultHandle v
rh = Maybe (ResponseMessage GValue) -> STM (Maybe v)
parseResponse forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall s. ResponseHandle s -> STM (Maybe (ResponseMessage s))
Conn.nextResponseSTM forall a b. (a -> b) -> a -> b
$ forall v. ResultHandle v -> ResponseHandle GValue
rhResHandle ResultHandle v
rh)
  where
    parseResponse :: Maybe (ResponseMessage GValue) -> STM (Maybe v)
parseResponse Maybe (ResponseMessage GValue)
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    parseResponse (Just ResponseMessage GValue
res) =
      case ResponseStatus -> ResponseCode
Res.code forall a b. (a -> b) -> a -> b
$ 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      -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
       ResponseCode
Res.PartialContent -> ResponseMessage GValue -> STM (Maybe v)
parseData ResponseMessage GValue
res
       ResponseCode
_                  -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw forall a b. (a -> b) -> a -> b
$ ResponseMessage GValue -> SubmitException
ResponseError ResponseMessage GValue
res -- TODO: handle Authenticate code
    parseData :: ResponseMessage GValue -> STM (Maybe v)
parseData ResponseMessage GValue
res =
      case forall v. ResultHandle v -> GValue -> Either Host (Vector v)
rhParseGValue ResultHandle v
rh forall a b. (a -> b) -> a -> b
$ forall s. ResponseResult s -> s
Res.resultData forall a b. (a -> b) -> a -> b
$ forall s. ResponseMessage s -> ResponseResult s
Res.result ResponseMessage GValue
res of
       Left Host
err -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw forall a b. (a -> b) -> a -> b
$ ResponseMessage GValue -> Host -> SubmitException
ParseError ResponseMessage GValue
res Host
err
       Right Vector v
parsed -> do
         forall a. TVar a -> a -> STM ()
writeTVar (forall v. ResultHandle v -> TVar (Vector v)
rhResultCache ResultHandle v
rh) Vector v
parsed
         if forall (t :: * -> *) a. Foldable t => t a -> Port
length Vector v
parsed forall a. Eq a => a -> a -> Bool
== Port
0
           then do
             forall a. TVar a -> a -> STM ()
writeTVar (forall v. ResultHandle v -> TVar Port
rhNextResultIndex ResultHandle v
rh) Port
0
             forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
           else do
             forall a. TVar a -> a -> STM ()
writeTVar (forall v. ResultHandle v -> TVar Port
rhNextResultIndex ResultHandle v
rh) Port
1
             forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Vector v
parsed forall a. Vector a -> Port -> a
! Port
0)

-- | Get all remaining results from 'ResultHandle'.
slurpResults :: ResultHandle v -> IO (Vector v)
slurpResults :: forall v. ResultHandle v -> IO (Vector v)
slurpResults ResultHandle v
h = forall (m :: * -> *) a. Monad m => m (Maybe a) -> m (Vector a)
slurp forall a b. (a -> b) -> a -> b
$ forall v. ResultHandle v -> IO (Maybe v)
nextResult ResultHandle v
h

-- | Similar to 'slurpResults', but this function discards the
-- results. Useful to execute a script whose side-effect is the only
-- thing you care.
--
-- @since 0.1.1.0
drainResults :: ResultHandle v -> IO ()
drainResults :: forall v. ResultHandle v -> IO ()
drainResults ResultHandle v
h = forall (m :: * -> *) a. Monad m => m (Maybe a) -> m ()
drain forall a b. (a -> b) -> a -> b
$ forall v. ResultHandle v -> IO (Maybe v)
nextResult ResultHandle v
h