{-# 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)

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 []

instance FromStructure Response where
  fromStructure :: forall (m :: * -> *).
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 (forall a. [a] -> a
head [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 ([Value] -> [Value]
removeExtList [Value]
fields)
    | Word8
signature forall a. Eq a => a -> a -> Bool
== Word8
sigIgn  = Map Text Value -> Response
ResponseIgnored forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadError UnpackError m =>
Value -> m (Map Text Value)
extractMap (forall a. [a] -> a
head [Value]
fields)
    | 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 (forall a. [a] -> a
head [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 :: [Value] -> [Value]
          removeExtList :: [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 (ResponseIgnored Map Text Value
_) = 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