{-# 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, fromList, empty, (!))
import           Data.Text                      (Text)

instance ToStructure Request where
  toStructure :: Request -> Structure
toStructure RequestInit{Text
AuthToken
token :: Request -> AuthToken
agent :: Request -> Text
token :: AuthToken
agent :: Text
..} = Word8 -> [Value] -> Structure
Structure Word8
sigInit [Text -> Value
T Text
agent, Map Text Value -> Value
M (Map Text Value -> Value) -> Map Text Value -> Value
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 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 []

instance FromStructure Response where
  fromStructure :: Structure -> m Response
fromStructure Structure{[Value]
Word8
fields :: Structure -> [Value]
signature :: Structure -> Word8
fields :: [Value]
signature :: Word8
..}
    | Word8
signature Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
sigSucc = Map Text Value -> Response
ResponseSuccess (Map Text Value -> Response) -> m (Map Text Value) -> m Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> m (Map Text Value)
forall (m :: * -> *).
MonadError UnpackError m =>
Value -> m (Map Text Value)
extractMap ([Value] -> Value
forall a. [a] -> a
head [Value]
fields)
    | Word8
signature Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
sigRecs = Response -> m Response
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response -> m Response) -> Response -> m Response
forall a b. (a -> b) -> a -> b
$ [Value] -> Response
ResponseRecord ([Value] -> [Value]
removeExtList [Value]
fields)
    | Word8
signature Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
sigIgn  = Map Text Value -> Response
ResponseIgnored (Map Text Value -> Response) -> m (Map Text Value) -> m Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> m (Map Text Value)
forall (m :: * -> *).
MonadError UnpackError m =>
Value -> m (Map Text Value)
extractMap ([Value] -> Value
forall a. [a] -> a
head [Value]
fields)
    | Word8
signature Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
sigFail = Map Text Value -> Response
ResponseFailure (Map Text Value -> Response) -> m (Map Text Value) -> m Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> m (Map Text Value)
forall (m :: * -> *).
MonadError UnpackError m =>
Value -> m (Map Text Value)
extractMap ([Value] -> Value
forall a. [a] -> a
head [Value]
fields)
    | Bool
otherwise            = UnpackError -> m Response
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (UnpackError -> m Response) -> UnpackError -> m Response
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]
_     = [Char] -> [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
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
port :: Int
host :: [Char]
socketTimeout :: Int
maxChunkSize :: Word16
userAgent :: Text
version :: Word32
magic :: Word32
..} = Text -> AuthToken -> Request
RequestInit Text
userAgent
                                     AuthToken :: Text -> Text -> Text -> AuthToken
AuthToken { scheme :: Text
scheme      = Text
"basic"
                                               , principal :: Text
principal   = Text
user
                                               , credentials :: Text
credentials = Text
password
                                               }

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


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

extractMap :: MonadError UnpackError m => Value -> m (Map Text Value)
extractMap :: Value -> m (Map Text Value)
extractMap (M Map Text Value
mp) = Map Text Value -> m (Map Text Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Text Value
mp
extractMap Value
_      = UnpackError -> m (Map Text 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 Map Text Value -> Text -> Value
forall k a. Ord k => Map k a -> k -> a
! Text
"code"
      (T Text
msg)  = Map Text Value
failMap Map Text Value -> Text -> Value
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