{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}

module Database.Bolt.Connection.Instances where

import           Database.Bolt.Connection.Type
import           Database.Bolt.Value.Helpers
import           Database.Bolt.Value.Type

import           Control.Monad.Except           (MonadError (..))
import           Data.Map.Strict                (Map, insert, fromList, empty, (!))
import           Data.Text                      (Text)
import           GHC.Stack                      (HasCallStack)

instance ToStructure Request where
  toStructure :: Request -> Structure
toStructure RequestInit{Bool
Text
AuthToken
isHello :: Request -> Bool
token :: Request -> AuthToken
agent :: Request -> Text
isHello :: Bool
token :: AuthToken
agent :: Text
..}           = Word8 -> [Value] -> Structure
Structure Word8
sigInit forall a b. (a -> b) -> a -> b
$ if Bool
isHello then [Map Text Value -> Value
M forall a b. (a -> b) -> a -> b
$ Text -> AuthToken -> Map Text Value
helloMap Text
agent AuthToken
token]
                                                                         else [Text -> Value
T Text
agent, Map Text Value -> Value
M forall a b. (a -> b) -> a -> b
$ AuthToken -> Map Text Value
tokenMap AuthToken
token]
  toStructure RequestRun{Map Text Value
Text
parameters :: Request -> Map Text Value
statement :: Request -> Text
parameters :: Map Text Value
statement :: Text
..}            = Word8 -> [Value] -> Structure
Structure Word8
sigRun [Text -> Value
T Text
statement, Map Text Value -> Value
M Map Text Value
parameters]
  toStructure RequestRunV3{Map Text Value
Text
extra :: Request -> Map Text Value
extra :: Map Text Value
parameters :: Map Text Value
statement :: Text
parameters :: Request -> Map Text Value
statement :: Request -> Text
..}          = Word8 -> [Value] -> Structure
Structure Word8
sigRun [Text -> Value
T Text
statement, Map Text Value -> Value
M Map Text Value
parameters, Map Text Value -> Value
M Map Text Value
extra]
  toStructure Request
RequestReset              = Word8 -> [Value] -> Structure
Structure Word8
sigReset []
  toStructure Request
RequestAckFailure         = Word8 -> [Value] -> Structure
Structure Word8
sigAFail []
  toStructure Request
RequestPullAll            = Word8 -> [Value] -> Structure
Structure Word8
sigPAll []
  toStructure Request
RequestDiscardAll         = Word8 -> [Value] -> Structure
Structure Word8
sigDAll []
  toStructure Request
RequestGoodbye            = Word8 -> [Value] -> Structure
Structure Word8
sigGBye []
  toStructure RequestBegin{Map Text Value
extra :: Map Text Value
extra :: Request -> Map Text Value
..}          = Word8 -> [Value] -> Structure
Structure Word8
sigBegin [Map Text Value -> Value
M Map Text Value
extra]
  toStructure Request
RequestCommit             = Word8 -> [Value] -> Structure
Structure Word8
sigCommit []
  toStructure Request
RequestRollback           = Word8 -> [Value] -> Structure
Structure Word8
sigRollback []

instance FromStructure Response where
  fromStructure :: forall (m :: * -> *).
(HasCallStack, MonadError UnpackError m) =>
Structure -> m Response
fromStructure Structure{[Value]
Word8
fields :: Structure -> [Value]
signature :: Structure -> Word8
fields :: [Value]
signature :: Word8
..}
    | Word8
signature forall a. Eq a => a -> a -> Bool
== Word8
sigSucc = Map Text Value -> Response
ResponseSuccess forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadError UnpackError m =>
[Value] -> m (Map Text Value)
extractMap [Value]
fields
    | Word8
signature forall a. Eq a => a -> a -> Bool
== Word8
sigRecs = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Value] -> Response
ResponseRecord (HasCallStack => [Value] -> [Value]
removeExtList [Value]
fields)
    | Word8
signature forall a. Eq a => a -> a -> Bool
== Word8
sigIgn  = forall (f :: * -> *) a. Applicative f => a -> f a
pure Response
ResponseIgnored
    | Word8
signature forall a. Eq a => a -> a -> Bool
== Word8
sigFail = Map Text Value -> Response
ResponseFailure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadError UnpackError m =>
[Value] -> m (Map Text Value)
extractMap [Value]
fields
    | Bool
otherwise            = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> UnpackError
Not Text
"Response"
    where removeExtList :: HasCallStack => [Value] -> [Value]
          removeExtList :: HasCallStack => [Value] -> [Value]
removeExtList [L [Value]
x] = [Value]
x
          removeExtList [Value]
_     = forall a. HasCallStack => [Char] -> a
error [Char]
"Record must contain only a singleton list"

-- Response check functions

isSuccess :: Response -> Bool
isSuccess :: Response -> Bool
isSuccess (ResponseSuccess Map Text Value
_) = Bool
True
isSuccess Response
_                   = Bool
False

isFailure :: Response -> Bool
isFailure :: Response -> Bool
isFailure (ResponseFailure Map Text Value
_) = Bool
True
isFailure Response
_                   = Bool
False

isIgnored :: Response -> Bool
isIgnored :: Response -> Bool
isIgnored Response
ResponseIgnored = Bool
True
isIgnored Response
_               = Bool
False

isRecord :: Response -> Bool
isRecord :: Response -> Bool
isRecord (ResponseRecord [Value]
_) = Bool
True
isRecord Response
_                  = Bool
False

-- Helper functions

createInit :: BoltCfg -> Request
createInit :: BoltCfg -> Request
createInit BoltCfg{Bool
Int
[Char]
Word16
Word32
Text
secure :: BoltCfg -> Bool
password :: BoltCfg -> Text
user :: BoltCfg -> Text
authType :: BoltCfg -> Text
port :: BoltCfg -> Int
host :: BoltCfg -> [Char]
socketTimeout :: BoltCfg -> Int
maxChunkSize :: BoltCfg -> Word16
userAgent :: BoltCfg -> Text
version :: BoltCfg -> Word32
magic :: BoltCfg -> Word32
secure :: Bool
password :: Text
user :: Text
authType :: Text
port :: Int
host :: [Char]
socketTimeout :: Int
maxChunkSize :: Word16
userAgent :: Text
version :: Word32
magic :: Word32
..} = Text -> AuthToken -> Bool -> Request
RequestInit Text
userAgent
                                     AuthToken { scheme :: Text
scheme      = Text
authType
                                               , principal :: Text
principal   = Text
user
                                               , credentials :: Text
credentials = Text
password
                                               }
                                     (Word32 -> Bool
isNewVersion Word32
version)

createRun :: Text -> Request
createRun :: Text -> Request
createRun Text
stmt = Text -> Map Text Value -> Request
RequestRun Text
stmt forall k a. Map k a
empty


helloMap :: Text -> AuthToken  -> Map Text Value
helloMap :: Text -> AuthToken -> Map Text Value
helloMap Text
a = forall k a. Ord k => k -> a -> Map k a -> Map k a
insert Text
"user_agent" (Text -> Value
T Text
a) forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthToken -> Map Text Value
tokenMap

tokenMap :: AuthToken -> Map Text Value
tokenMap :: AuthToken -> Map Text Value
tokenMap AuthToken
at = forall k a. Ord k => [(k, a)] -> Map k a
fromList [ Text
"scheme"     forall a. IsValue a => Text -> a -> (Text, Value)
=: AuthToken -> Text
scheme AuthToken
at
                       , Text
"principal"   forall a. IsValue a => Text -> a -> (Text, Value)
=: AuthToken -> Text
principal AuthToken
at
                       , Text
"credentials" forall a. IsValue a => Text -> a -> (Text, Value)
=: AuthToken -> Text
credentials AuthToken
at
                       ]

extractMap :: MonadError UnpackError m => [Value] -> m (Map Text Value)
extractMap :: forall (m :: * -> *).
MonadError UnpackError m =>
[Value] -> m (Map Text Value)
extractMap [M Map Text Value
mp] = forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Text Value
mp
extractMap [Value]
_      = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError UnpackError
NotDict

mkFailure :: Response -> ResponseError
mkFailure :: Response -> ResponseError
mkFailure ResponseFailure{Map Text Value
failMap :: Response -> Map Text Value
failMap :: Map Text Value
..} =
  let (T Text
code) = Map Text Value
failMap forall k a. Ord k => Map k a -> k -> a
! Text
"code"
      (T Text
msg)  = Map Text Value
failMap forall k a. Ord k => Map k a -> k -> a
! Text
"message"
  in  Text -> Text -> ResponseError
KnownResponseFailure Text
code Text
msg
mkFailure Response
_ = ResponseError
UnknownResponseFailure