{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}

module Database.Bolt.Connection
  ( BoltActionT
  , BoltError (..)
  , UnpackError (..)
  , at
  , run, runE
  , queryP, query
  , queryP', query'
  , queryP_, query_
  ) where

import           Database.Bolt.Connection.Pipe
import           Database.Bolt.Connection.Instances
import           Database.Bolt.Connection.Type
import           Database.Bolt.Value.Type
import           Database.Bolt.Record

import           Control.Exception             (throwIO)
import           Control.Monad                 (void)
import           Control.Monad.Except          (MonadError (..), runExceptT)
import           Control.Monad.Reader          (MonadReader (..), runReaderT)
import           Control.Monad.Trans           (MonadIO (..))
import           Data.Map.Strict               (Map, empty, fromList)
import           Data.Text                     (Text)
import           GHC.Stack                     (HasCallStack)

import           System.IO.Unsafe              (unsafeInterleaveIO)

-- |Runs BOLT action on selected pipe
runE :: MonadIO m => HasCallStack => Pipe -> BoltActionT m a -> m (Either BoltError a)
runE :: Pipe -> BoltActionT m a -> m (Either BoltError a)
runE Pipe
pipe BoltActionT m a
action = ExceptT BoltError m a -> m (Either BoltError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ReaderT Pipe (ExceptT BoltError m) a
-> Pipe -> ExceptT BoltError m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (BoltActionT m a -> ReaderT Pipe (ExceptT BoltError m) a
forall (m :: * -> *) a.
BoltActionT m a -> ReaderT Pipe (ExceptT BoltError m) a
runBoltActionT BoltActionT m a
action) Pipe
pipe)

-- |Runs BOLT action on selected pipe (with errors throw)
run :: MonadIO m => HasCallStack => Pipe -> BoltActionT m a -> m a
run :: Pipe -> BoltActionT m a -> m a
run Pipe
pipe BoltActionT m a
action = do Either BoltError a
result <- Pipe -> BoltActionT m a -> m (Either BoltError a)
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
Pipe -> BoltActionT m a -> m (Either BoltError a)
runE Pipe
pipe BoltActionT m a
action
                     case Either BoltError a
result of
                       Right a
x -> a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
                       Left BoltError
r  -> IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ BoltError -> IO a
forall e a. Exception e => e -> IO a
throwIO BoltError
r

-- |Runs Cypher query with parameters and returns list of obtained 'Record's. Lazy version
queryP :: MonadIO m => HasCallStack => Text -> Map Text Value -> BoltActionT m [Record]
queryP :: Text -> Map Text Value -> BoltActionT m [Map Text Value]
queryP = Bool -> Text -> Map Text Value -> BoltActionT m [Map Text Value]
forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Bool -> Text -> Map Text Value -> BoltActionT m [Map Text Value]
querySL Bool
False

-- |Runs Cypher query and returns list of obtained 'Record's. Lazy version
query :: MonadIO m => HasCallStack => Text -> BoltActionT m [Record]
query :: Text -> BoltActionT m [Map Text Value]
query Text
cypher = Text -> Map Text Value -> BoltActionT m [Map Text Value]
forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Text -> Map Text Value -> BoltActionT m [Map Text Value]
queryP Text
cypher Map Text Value
forall k a. Map k a
empty

-- |Runs Cypher query with parameters and returns list of obtained 'Record's. Strict version
queryP' :: MonadIO m => HasCallStack => Text -> Map Text Value -> BoltActionT m [Record]
queryP' :: Text -> Map Text Value -> BoltActionT m [Map Text Value]
queryP' = Bool -> Text -> Map Text Value -> BoltActionT m [Map Text Value]
forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Bool -> Text -> Map Text Value -> BoltActionT m [Map Text Value]
querySL Bool
True

-- |Runs Cypher query and returns list of obtained 'Record's. Strict version
query' :: MonadIO m => HasCallStack => Text -> BoltActionT m [Record]
query' :: Text -> BoltActionT m [Map Text Value]
query' Text
cypher = Text -> Map Text Value -> BoltActionT m [Map Text Value]
forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Text -> Map Text Value -> BoltActionT m [Map Text Value]
queryP' Text
cypher Map Text Value
forall k a. Map k a
empty

-- |Runs Cypher query with parameters and ignores response
queryP_ :: MonadIO m => HasCallStack => Text -> Map Text Value -> BoltActionT m ()
queryP_ :: Text -> Map Text Value -> BoltActionT m ()
queryP_ Text
cypher Map Text Value
params = do BoltActionT m Response -> BoltActionT m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (BoltActionT m Response -> BoltActionT m ())
-> BoltActionT m Response -> BoltActionT m ()
forall a b. (a -> b) -> a -> b
$ Text -> Map Text Value -> BoltActionT m Response
forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Text -> Map Text Value -> BoltActionT m Response
sendRequest Text
cypher Map Text Value
params
                           BoltActionT m Pipe
forall r (m :: * -> *). MonadReader r m => m r
ask BoltActionT m Pipe
-> (Pipe -> BoltActionT m ()) -> BoltActionT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ExceptT BoltError m () -> BoltActionT m ()
forall (m :: * -> *) a.
Monad m =>
ExceptT BoltError m a -> BoltActionT m a
liftE (ExceptT BoltError m () -> BoltActionT m ())
-> (Pipe -> ExceptT BoltError m ()) -> Pipe -> BoltActionT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pipe -> ExceptT BoltError m ()
forall (m :: * -> *). (MonadPipe m, HasCallStack) => Pipe -> m ()
discardAll

-- |Runs Cypher query and ignores response
query_ :: MonadIO m => HasCallStack => Text -> BoltActionT m ()
query_ :: Text -> BoltActionT m ()
query_ Text
cypher = Text -> Map Text Value -> BoltActionT m ()
forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Text -> Map Text Value -> BoltActionT m ()
queryP_ Text
cypher Map Text Value
forall k a. Map k a
empty

-- Helper functions

querySL :: MonadIO m => HasCallStack => Bool -> Text -> Map Text Value -> BoltActionT m [Record]
querySL :: Bool -> Text -> Map Text Value -> BoltActionT m [Map Text Value]
querySL Bool
strict Text
cypher Map Text Value
params = do [Text]
keys <- Text -> Map Text Value -> BoltActionT m [Text]
forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Text -> Map Text Value -> BoltActionT m [Text]
pullKeys Text
cypher Map Text Value
params
                                  Bool -> [Text] -> BoltActionT m [Map Text Value]
forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Bool -> [Text] -> BoltActionT m [Map Text Value]
pullRecords Bool
strict [Text]
keys

pullKeys :: MonadIO m => HasCallStack => Text -> Map Text Value -> BoltActionT m [Text]
pullKeys :: Text -> Map Text Value -> BoltActionT m [Text]
pullKeys Text
cypher Map Text Value
params = do Pipe
pipe <- BoltActionT m Pipe
forall r (m :: * -> *). MonadReader r m => m r
ask
                            Response
status <- Text -> Map Text Value -> BoltActionT m Response
forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Text -> Map Text Value -> BoltActionT m Response
sendRequest Text
cypher Map Text Value
params
                            ExceptT BoltError m () -> BoltActionT m ()
forall (m :: * -> *) a.
Monad m =>
ExceptT BoltError m a -> BoltActionT m a
liftE (ExceptT BoltError m () -> BoltActionT m ())
-> ExceptT BoltError m () -> BoltActionT m ()
forall a b. (a -> b) -> a -> b
$ Pipe -> Request -> ExceptT BoltError m ()
forall (m :: * -> *).
(MonadPipe m, HasCallStack) =>
Pipe -> Request -> m ()
flush Pipe
pipe Request
RequestPullAll
                            Response -> BoltActionT m [Text]
forall (m :: * -> *). MonadIO m => Response -> BoltActionT m [Text]
mkKeys Response
status
  where
    mkKeys :: MonadIO m => Response -> BoltActionT m [Text]
    mkKeys :: Response -> BoltActionT m [Text]
mkKeys (ResponseSuccess Map Text Value
response) = Map Text Value
response Map Text Value -> Text -> BoltActionT m [Text]
forall (m :: * -> *) a.
(Monad m, RecordValue a) =>
Map Text Value -> Text -> BoltActionT m a
`at` Text
"fields" BoltActionT m [Text]
-> (BoltError -> BoltActionT m [Text]) -> BoltActionT m [Text]
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \(RecordHasNoKey Text
_) -> [Text] -> BoltActionT m [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    mkKeys Response
x                          = BoltError -> BoltActionT m [Text]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (BoltError -> BoltActionT m [Text])
-> BoltError -> BoltActionT m [Text]
forall a b. (a -> b) -> a -> b
$ ResponseError -> BoltError
ResponseError (Response -> ResponseError
mkFailure Response
x)

pullRecords :: MonadIO m => HasCallStack => Bool -> [Text] -> BoltActionT m [Record]
pullRecords :: Bool -> [Text] -> BoltActionT m [Map Text Value]
pullRecords Bool
strict [Text]
keys = do Pipe
pipe <- BoltActionT m Pipe
forall r (m :: * -> *). MonadReader r m => m r
ask
                             Response
resp <- ExceptT BoltError m Response -> BoltActionT m Response
forall (m :: * -> *) a.
Monad m =>
ExceptT BoltError m a -> BoltActionT m a
liftE (ExceptT BoltError m Response -> BoltActionT m Response)
-> ExceptT BoltError m Response -> BoltActionT m Response
forall a b. (a -> b) -> a -> b
$ Pipe -> ExceptT BoltError m Response
forall (m :: * -> *).
(MonadPipe m, HasCallStack) =>
Pipe -> m Response
fetch Pipe
pipe
                             Response -> BoltActionT m [Map Text Value]
forall (m :: * -> *).
MonadIO m =>
Response -> BoltActionT m [Map Text Value]
cases Response
resp
  where
    cases :: MonadIO m => Response -> BoltActionT m [Record]
    cases :: Response -> BoltActionT m [Map Text Value]
cases Response
resp | Response -> Bool
isSuccess Response
resp = [Map Text Value] -> BoltActionT m [Map Text Value]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
               | Response -> Bool
isFailure Response
resp = do BoltActionT m Pipe
forall r (m :: * -> *). MonadReader r m => m r
ask BoltActionT m Pipe
-> (Pipe -> BoltActionT m ()) -> BoltActionT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Pipe -> BoltActionT m ()
forall (m :: * -> *). (MonadPipe m, HasCallStack) => Pipe -> m ()
ackFailure
                                     BoltError -> BoltActionT m [Map Text Value]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (BoltError -> BoltActionT m [Map Text Value])
-> BoltError -> BoltActionT m [Map Text Value]
forall a b. (a -> b) -> a -> b
$ ResponseError -> BoltError
ResponseError (Response -> ResponseError
mkFailure Response
resp)
               | Bool
otherwise      = Response -> BoltActionT m [Map Text Value]
forall (m :: * -> *).
MonadIO m =>
Response -> BoltActionT m [Map Text Value]
parseRecord Response
resp

    parseRecord :: MonadIO m => Response -> BoltActionT m [Record]
    parseRecord :: Response -> BoltActionT m [Map Text Value]
parseRecord Response
resp = do
        Pipe
pipe <- BoltActionT m Pipe
forall r (m :: * -> *). MonadReader r m => m r
ask
        let record :: Map Text Value
record = [(Text, Value)] -> Map Text Value
forall k a. Ord k => [(k, a)] -> Map k a
fromList ([(Text, Value)] -> Map Text Value)
-> ([Value] -> [(Text, Value)]) -> [Value] -> Map Text Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Value] -> [(Text, Value)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
keys ([Value] -> Map Text Value) -> [Value] -> Map Text Value
forall a b. (a -> b) -> a -> b
$ Response -> [Value]
recsList Response
resp
        let pull :: IO [Map Text Value]
pull = Pipe -> BoltActionT IO [Map Text Value] -> IO [Map Text Value]
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
Pipe -> BoltActionT m a -> m a
run Pipe
pipe (Bool -> [Text] -> BoltActionT IO [Map Text Value]
forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Bool -> [Text] -> BoltActionT m [Map Text Value]
pullRecords Bool
strict [Text]
keys)
        [Map Text Value]
rest <- IO [Map Text Value] -> BoltActionT m [Map Text Value]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Map Text Value] -> BoltActionT m [Map Text Value])
-> IO [Map Text Value] -> BoltActionT m [Map Text Value]
forall a b. (a -> b) -> a -> b
$ if Bool
strict then IO [Map Text Value]
pull
                                   else IO [Map Text Value] -> IO [Map Text Value]
forall a. IO a -> IO a
unsafeInterleaveIO IO [Map Text Value]
pull
        [Map Text Value] -> BoltActionT m [Map Text Value]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Text Value
recordMap Text Value -> [Map Text Value] -> [Map Text Value]
forall a. a -> [a] -> [a]
:[Map Text Value]
rest)

-- |Sends request to database and makes an action
sendRequest :: MonadIO m => HasCallStack => Text -> Map Text Value -> BoltActionT m Response
sendRequest :: Text -> Map Text Value -> BoltActionT m Response
sendRequest Text
cypher Map Text Value
params =
  do Pipe
pipe <- BoltActionT m Pipe
forall r (m :: * -> *). MonadReader r m => m r
ask
     ExceptT BoltError m Response -> BoltActionT m Response
forall (m :: * -> *) a.
Monad m =>
ExceptT BoltError m a -> BoltActionT m a
liftE (ExceptT BoltError m Response -> BoltActionT m Response)
-> ExceptT BoltError m Response -> BoltActionT m Response
forall a b. (a -> b) -> a -> b
$ do
         Pipe -> Request -> ExceptT BoltError m ()
forall (m :: * -> *).
(MonadPipe m, HasCallStack) =>
Pipe -> Request -> m ()
flush Pipe
pipe (Request -> ExceptT BoltError m ())
-> Request -> ExceptT BoltError m ()
forall a b. (a -> b) -> a -> b
$ Text -> Map Text Value -> Request
RequestRun Text
cypher Map Text Value
params
         Response
status <- Pipe -> ExceptT BoltError m Response
forall (m :: * -> *).
(MonadPipe m, HasCallStack) =>
Pipe -> m Response
fetch Pipe
pipe
         if Response -> Bool
isSuccess Response
status
           then Response -> ExceptT BoltError m Response
forall (f :: * -> *) a. Applicative f => a -> f a
pure Response
status
           else do Pipe -> ExceptT BoltError m ()
forall (m :: * -> *). (MonadPipe m, HasCallStack) => Pipe -> m ()
ackFailure Pipe
pipe
                   BoltError -> ExceptT BoltError m Response
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (BoltError -> ExceptT BoltError m Response)
-> BoltError -> ExceptT BoltError m Response
forall a b. (a -> b) -> a -> b
$ ResponseError -> BoltError
ResponseError (Response -> ResponseError
mkFailure Response
status)