Instances.hs

{-# 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 = genericToPs
  fromPs = genericFromPs


instance PackStream Routing where
  toPs NoRouting                          = PsDictionary H.empty
  toPs Routing                            = PsDictionary $ H.singleton "routing" $ PsDictionary H.empty
  toPs (RoutingSpec address query_params) = PsDictionary $ H.singleton "routing" $ PsDictionary $ H.union (H.singleton "address" (toPs address)) (H.map toPs query_params)
  toBinary routing = toBinary $ toPs routing
  fromPs ps = withDictionary "Routing" f ps
    where f :: H.HashMap T.Text Ps -> Result Routing
          f m | m == H.empty  = pure NoRouting
              | H.size m == 1 = pure Routing
              | otherwise     =
                  case H.lookup "address" m of
                    Nothing      -> Error "\"address\" not found in routing part"
                    Just address -> do
                      address2 <- fromPs address
                      remainder <- traverse fromPs $ H.delete "address" m
                      pure $ RoutingSpec address2 remainder


instance PackStream UserAgent where
  toPs (UserAgent name version) = toPs $ name <> "/" <> version
  toBinary (UserAgent name version) = putTextUtf8 $ name <> "/" <> version
  fromPs = withString "UserAgent" f
    where f text = case T.splitOn "/" text of
            (name : version : _) -> pure $ UserAgent name version
            _                    -> Error $ "Expected UserAgent in format \"name/version\", got: " <> text