{-# 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.Helpers
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 :: forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
Pipe -> BoltActionT m a -> m (Either BoltError a)
runE Pipe
pipe BoltActionT m a
action = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (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 :: forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
Pipe -> BoltActionT m a -> m a
run Pipe
pipe BoltActionT m a
action = do Either BoltError a
result <- 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
                       Left BoltError
r  -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 :: forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Text -> Map Text Value -> BoltActionT m [Map Text Value]
queryP = 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 :: forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Text -> BoltActionT m [Map Text Value]
query Text
cypher = forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Text -> Map Text Value -> BoltActionT m [Map Text Value]
queryP Text
cypher 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' :: forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Text -> Map Text Value -> BoltActionT m [Map Text Value]
queryP' = 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' :: forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Text -> BoltActionT m [Map Text Value]
query' Text
cypher = forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Text -> Map Text Value -> BoltActionT m [Map Text Value]
queryP' Text
cypher 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_ :: forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Text -> Map Text Value -> BoltActionT m ()
queryP_ Text
cypher Map Text Value
params = do forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Text -> Map Text Value -> Map Text Value -> BoltActionT m Response
sendRequest Text
cypher Map Text Value
params forall k a. Map k a
empty
                           forall r (m :: * -> *). MonadReader r m => m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a.
Monad m =>
ExceptT BoltError m a -> BoltActionT m a
liftE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). (MonadPipe m, HasCallStack) => Pipe -> m ()
discardAll

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

-- Helper functions

querySL :: MonadIO m => HasCallStack => Bool -> Text -> Map Text Value -> BoltActionT m [Record]
querySL :: forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Bool -> Text -> Map Text Value -> BoltActionT m [Map Text Value]
querySL Bool
strict Text
cypher Map Text Value
params = do [Text]
keys <- forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Text -> Map Text Value -> Map Text Value -> BoltActionT m [Text]
pullKeys Text
cypher Map Text Value
params forall k a. Map k a
empty
                                  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 -> Map Text Value -> BoltActionT m [Text]
pullKeys :: forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Text -> Map Text Value -> Map Text Value -> BoltActionT m [Text]
pullKeys Text
cypher Map Text Value
params Map Text Value
ext = do Pipe
pipe <- forall r (m :: * -> *). MonadReader r m => m r
ask
                                Response
status <- forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Text -> Map Text Value -> Map Text Value -> BoltActionT m Response
sendRequest Text
cypher Map Text Value
params Map Text Value
ext
                                forall (m :: * -> *) a.
Monad m =>
ExceptT BoltError m a -> BoltActionT m a
liftE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadPipe m, HasCallStack) =>
Pipe -> Request -> m ()
flush Pipe
pipe Request
RequestPullAll
                                forall (m :: * -> *). MonadIO m => Response -> BoltActionT m [Text]
mkKeys Response
status
  where
    mkKeys :: MonadIO m => Response -> BoltActionT m [Text]
    mkKeys :: forall (m :: * -> *). MonadIO m => Response -> BoltActionT m [Text]
mkKeys (ResponseSuccess Map Text Value
response) = Map Text Value
response forall (m :: * -> *) a.
(Monad m, RecordValue a) =>
Map Text Value -> Text -> BoltActionT m a
`at` Text
"fields" forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \(RecordHasNoKey Text
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    mkKeys Response
x                          = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError 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 :: forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Bool -> [Text] -> BoltActionT m [Map Text Value]
pullRecords Bool
strict [Text]
keys = do Pipe
pipe <- forall r (m :: * -> *). MonadReader r m => m r
ask
                             Response
resp <- forall (m :: * -> *) a.
Monad m =>
ExceptT BoltError m a -> BoltActionT m a
liftE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadPipe m, HasCallStack) =>
Pipe -> m Response
fetch Pipe
pipe
                             forall (m :: * -> *).
MonadIO m =>
Response -> BoltActionT m [Map Text Value]
cases Response
resp
  where
    cases :: MonadIO m => Response -> BoltActionT m [Record]
    cases :: forall (m :: * -> *).
MonadIO m =>
Response -> BoltActionT m [Map Text Value]
cases Response
resp | Response -> Bool
isSuccess Response
resp = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
               | Response -> Bool
isFailure Response
resp = do forall r (m :: * -> *). MonadReader r m => m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). (MonadIO m, HasCallStack) => Pipe -> m ()
processError
                                     forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ ResponseError -> BoltError
ResponseError (Response -> ResponseError
mkFailure Response
resp)
               | Bool
otherwise      = forall (m :: * -> *).
MonadIO m =>
Response -> BoltActionT m [Map Text Value]
parseRecord Response
resp

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

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