{-# OPTIONS_GHC -Wno-orphans #-}

-- | Internal module. Not part of the public API.
module Database.Bolty.Connection.Instances
  ( -- instances only
  ) where

import qualified Data.HashMap.Lazy               as H
import qualified Data.Text                       as T

import           Data.PackStream.Generic        (genericToPs, genericFromPs)
import           Data.PackStream.Ps
import           Data.PackStream.Result
import           Database.Bolty.Connection.Type
import           Database.Bolty.Util             (putTextUtf8)


instance PackStream Scheme where
  toPs :: Scheme -> Ps
toPs = Scheme -> Ps
forall a. (Generic a, GPackStream (Rep a)) => a -> Ps
genericToPs
  fromPs :: Ps -> Result Scheme
fromPs = Ps -> Result Scheme
forall a. (Generic a, GPackStream (Rep a)) => Ps -> Result a
genericFromPs


instance PackStream Routing where
  toPs :: Routing -> Ps
toPs Routing
NoRouting                          = HashMap Principal Ps -> Ps
PsDictionary HashMap Principal Ps
forall k v. HashMap k v
H.empty
  toPs Routing
Routing                            = HashMap Principal Ps -> Ps
PsDictionary (HashMap Principal Ps -> Ps) -> HashMap Principal Ps -> Ps
forall a b. (a -> b) -> a -> b
$ Principal -> Ps -> HashMap Principal Ps
forall k v. Hashable k => k -> v -> HashMap k v
H.singleton Principal
"routing" (Ps -> HashMap Principal Ps) -> Ps -> HashMap Principal Ps
forall a b. (a -> b) -> a -> b
$ HashMap Principal Ps -> Ps
PsDictionary HashMap Principal Ps
forall k v. HashMap k v
H.empty
  toPs (RoutingSpec Principal
address HashMap Principal Principal
query_params) = HashMap Principal Ps -> Ps
PsDictionary (HashMap Principal Ps -> Ps) -> HashMap Principal Ps -> Ps
forall a b. (a -> b) -> a -> b
$ Principal -> Ps -> HashMap Principal Ps
forall k v. Hashable k => k -> v -> HashMap k v
H.singleton Principal
"routing" (Ps -> HashMap Principal Ps) -> Ps -> HashMap Principal Ps
forall a b. (a -> b) -> a -> b
$ HashMap Principal Ps -> Ps
PsDictionary (HashMap Principal Ps -> Ps) -> HashMap Principal Ps -> Ps
forall a b. (a -> b) -> a -> b
$ HashMap Principal Ps
-> HashMap Principal Ps -> HashMap Principal Ps
forall k v. Eq k => HashMap k v -> HashMap k v -> HashMap k v
H.union (Principal -> Ps -> HashMap Principal Ps
forall k v. Hashable k => k -> v -> HashMap k v
H.singleton Principal
"address" (Principal -> Ps
forall a. PackStream a => a -> Ps
toPs Principal
address)) ((Principal -> Ps)
-> HashMap Principal Principal -> HashMap Principal Ps
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
H.map Principal -> Ps
forall a. PackStream a => a -> Ps
toPs HashMap Principal Principal
query_params)
  toBinary :: Routing -> Put
toBinary Routing
routing = Ps -> Put
forall a. PackStream a => a -> Put
toBinary (Ps -> Put) -> Ps -> Put
forall a b. (a -> b) -> a -> b
$ Routing -> Ps
forall a. PackStream a => a -> Ps
toPs Routing
routing
  fromPs :: Ps -> Result Routing
fromPs Ps
ps = Principal
-> (HashMap Principal Ps -> Result Routing) -> Ps -> Result Routing
forall a.
Principal -> (HashMap Principal Ps -> Result a) -> Ps -> Result a
withDictionary Principal
"Routing" HashMap Principal Ps -> Result Routing
f Ps
ps
    where f :: H.HashMap T.Text Ps -> Result Routing
          f :: HashMap Principal Ps -> Result Routing
f HashMap Principal Ps
m | HashMap Principal Ps
m HashMap Principal Ps -> HashMap Principal Ps -> Bool
forall a. Eq a => a -> a -> Bool
== HashMap Principal Ps
forall k v. HashMap k v
H.empty  = Routing -> Result Routing
forall a. a -> Result a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Routing
NoRouting
              | HashMap Principal Ps -> Int
forall k v. HashMap k v -> Int
H.size HashMap Principal Ps
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Routing -> Result Routing
forall a. a -> Result a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Routing
Routing
              | Bool
otherwise     =
                  case Principal -> HashMap Principal Ps -> Maybe Ps
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Principal
"address" HashMap Principal Ps
m of
                    Maybe Ps
Nothing      -> Principal -> Result Routing
forall a. Principal -> Result a
Error Principal
"\"address\" not found in routing part"
                    Just Ps
address -> do
                      address2 <- Ps -> Result Principal
forall a. PackStream a => Ps -> Result a
fromPs Ps
address
                      remainder <- traverse fromPs $ H.delete "address" m
                      pure $ RoutingSpec address2 remainder


instance PackStream UserAgent where
  toPs :: UserAgent -> Ps
toPs (UserAgent Principal
name Principal
version) = Principal -> Ps
forall a. PackStream a => a -> Ps
toPs (Principal -> Ps) -> Principal -> Ps
forall a b. (a -> b) -> a -> b
$ Principal
name Principal -> Principal -> Principal
forall a. Semigroup a => a -> a -> a
<> Principal
"/" Principal -> Principal -> Principal
forall a. Semigroup a => a -> a -> a
<> Principal
version
  toBinary :: UserAgent -> Put
toBinary (UserAgent Principal
name Principal
version) = Principal -> Put
putTextUtf8 (Principal -> Put) -> Principal -> Put
forall a b. (a -> b) -> a -> b
$ Principal
name Principal -> Principal -> Principal
forall a. Semigroup a => a -> a -> a
<> Principal
"/" Principal -> Principal -> Principal
forall a. Semigroup a => a -> a -> a
<> Principal
version
  fromPs :: Ps -> Result UserAgent
fromPs = Principal
-> (Principal -> Result UserAgent) -> Ps -> Result UserAgent
forall a. Principal -> (Principal -> Result a) -> Ps -> Result a
withString Principal
"UserAgent" Principal -> Result UserAgent
f
    where f :: Principal -> Result UserAgent
f Principal
text = case HasCallStack => Principal -> Principal -> [Principal]
Principal -> Principal -> [Principal]
T.splitOn Principal
"/" Principal
text of
            (Principal
name : Principal
version : [Principal]
_) -> UserAgent -> Result UserAgent
forall a. a -> Result a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UserAgent -> Result UserAgent) -> UserAgent -> Result UserAgent
forall a b. (a -> b) -> a -> b
$ Principal -> Principal -> UserAgent
UserAgent Principal
name Principal
version
            [Principal]
_                    -> Principal -> Result UserAgent
forall a. Principal -> Result a
Error (Principal -> Result UserAgent) -> Principal -> Result UserAgent
forall a b. (a -> b) -> a -> b
$ Principal
"Expected UserAgent in format \"name/version\", got: " Principal -> Principal -> Principal
forall a. Semigroup a => a -> a -> a
<> Principal
text