{-# LANGUAGE CPP, ViewPatterns, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}

------------------------------------------------------------------------------
-- |
-- Module:      Database.PostgreSQL.Simple.HStore.Implementation
-- Copyright:   (c) 2013 Leon P Smith
-- License:     BSD3
-- Maintainer:  Leon P Smith <leon@melding-monads.com>
-- Stability:   experimental
--
-- This code has yet to be profiled and optimized.
--
------------------------------------------------------------------------------

module Database.PostgreSQL.Simple.HStore.Implementation where

import           Control.Applicative
import qualified Data.Attoparsec.ByteString as P
import qualified Data.Attoparsec.ByteString.Char8 as P (isSpace_w8)
import qualified Data.ByteString as BS
import           Data.ByteString.Builder (Builder, byteString, char8)
import qualified Data.ByteString.Builder as BU
import           Data.ByteString.Internal (c2w, w2c)
import qualified Data.ByteString.Lazy          as BL
#if !MIN_VERSION_bytestring(0,10,0)
import qualified Data.ByteString.Lazy.Internal as BL (foldrChunks)
#endif
import           Data.Map(Map)
import qualified Data.Map as Map
import           Data.Text(Text)
import qualified Data.Text               as TS
import qualified Data.Text.Encoding      as TS
import           Data.Text.Encoding.Error(UnicodeException)
import qualified Data.Text.Lazy          as TL
import           Data.Typeable
import           Data.Monoid(Monoid(..))
import           Data.Semigroup
import           Database.PostgreSQL.Simple.FromField
import           Database.PostgreSQL.Simple.ToField

class ToHStore a where
   toHStore :: a -> HStoreBuilder

-- | Represents valid hstore syntax.
data HStoreBuilder
   = Empty
   | Comma !Builder
     deriving (Typeable)

instance ToHStore HStoreBuilder where
   toHStore :: HStoreBuilder -> HStoreBuilder
toHStore = HStoreBuilder -> HStoreBuilder
forall a. a -> a
id

toBuilder :: HStoreBuilder -> Builder
toBuilder :: HStoreBuilder -> Builder
toBuilder HStoreBuilder
x = case HStoreBuilder
x of
                HStoreBuilder
Empty -> Builder
forall a. Monoid a => a
mempty
                Comma Builder
c -> Builder
c

toLazyByteString :: HStoreBuilder -> BL.ByteString
toLazyByteString :: HStoreBuilder -> ByteString
toLazyByteString HStoreBuilder
x = case HStoreBuilder
x of
                       HStoreBuilder
Empty -> ByteString
BL.empty
                       Comma Builder
c -> Builder -> ByteString
BU.toLazyByteString Builder
c

instance Semigroup HStoreBuilder where
    HStoreBuilder
Empty   <> :: HStoreBuilder -> HStoreBuilder -> HStoreBuilder
<> HStoreBuilder
x = HStoreBuilder
x
    Comma Builder
a <> HStoreBuilder
x
        = Builder -> HStoreBuilder
Comma (Builder
a Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` case HStoreBuilder
x of
                               HStoreBuilder
Empty   -> Builder
forall a. Monoid a => a
mempty
                               Comma Builder
b -> Char -> Builder
char8 Char
',' Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
b)

instance Monoid HStoreBuilder where
    mempty :: HStoreBuilder
mempty = HStoreBuilder
Empty
#if !(MIN_VERSION_base(4,11,0))
    mappend = (<>)
#endif

class ToHStoreText a where
  toHStoreText :: a -> HStoreText

-- | Represents escape text, ready to be the key or value to a hstore value
newtype HStoreText = HStoreText Builder deriving (Typeable, b -> HStoreText -> HStoreText
NonEmpty HStoreText -> HStoreText
HStoreText -> HStoreText -> HStoreText
(HStoreText -> HStoreText -> HStoreText)
-> (NonEmpty HStoreText -> HStoreText)
-> (forall b. Integral b => b -> HStoreText -> HStoreText)
-> Semigroup HStoreText
forall b. Integral b => b -> HStoreText -> HStoreText
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> HStoreText -> HStoreText
$cstimes :: forall b. Integral b => b -> HStoreText -> HStoreText
sconcat :: NonEmpty HStoreText -> HStoreText
$csconcat :: NonEmpty HStoreText -> HStoreText
<> :: HStoreText -> HStoreText -> HStoreText
$c<> :: HStoreText -> HStoreText -> HStoreText
Semigroup, Semigroup HStoreText
HStoreText
Semigroup HStoreText
-> HStoreText
-> (HStoreText -> HStoreText -> HStoreText)
-> ([HStoreText] -> HStoreText)
-> Monoid HStoreText
[HStoreText] -> HStoreText
HStoreText -> HStoreText -> HStoreText
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [HStoreText] -> HStoreText
$cmconcat :: [HStoreText] -> HStoreText
mappend :: HStoreText -> HStoreText -> HStoreText
$cmappend :: HStoreText -> HStoreText -> HStoreText
mempty :: HStoreText
$cmempty :: HStoreText
$cp1Monoid :: Semigroup HStoreText
Monoid)

instance ToHStoreText HStoreText where
  toHStoreText :: HStoreText -> HStoreText
toHStoreText = HStoreText -> HStoreText
forall a. a -> a
id

-- | Assumed to be UTF-8 encoded
instance ToHStoreText BS.ByteString where
  toHStoreText :: ByteString -> HStoreText
toHStoreText ByteString
str = Builder -> HStoreText
HStoreText (ByteString -> Builder -> Builder
escapeAppend ByteString
str Builder
forall a. Monoid a => a
mempty)

-- | Assumed to be UTF-8 encoded
instance ToHStoreText BL.ByteString where
  toHStoreText :: ByteString -> HStoreText
toHStoreText = Builder -> HStoreText
HStoreText (Builder -> HStoreText)
-> (ByteString -> Builder) -> ByteString -> HStoreText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Builder -> Builder)
-> Builder -> ByteString -> Builder
forall a. (ByteString -> a -> a) -> a -> ByteString -> a
BL.foldrChunks ByteString -> Builder -> Builder
escapeAppend Builder
forall a. Monoid a => a
mempty

instance ToHStoreText TS.Text where
  toHStoreText :: Text -> HStoreText
toHStoreText Text
str = Builder -> HStoreText
HStoreText (ByteString -> Builder -> Builder
escapeAppend (Text -> ByteString
TS.encodeUtf8 Text
str) Builder
forall a. Monoid a => a
mempty)

instance ToHStoreText TL.Text where
  toHStoreText :: Text -> HStoreText
toHStoreText = Builder -> HStoreText
HStoreText (Builder -> HStoreText) -> (Text -> Builder) -> Text -> HStoreText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Builder -> Builder) -> Builder -> Text -> Builder
forall a. (Text -> a -> a) -> a -> Text -> a
TL.foldrChunks (ByteString -> Builder -> Builder
escapeAppend (ByteString -> Builder -> Builder)
-> (Text -> ByteString) -> Text -> Builder -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TS.encodeUtf8) Builder
forall a. Monoid a => a
mempty

escapeAppend :: BS.ByteString -> Builder -> Builder
escapeAppend :: ByteString -> Builder -> Builder
escapeAppend = ByteString -> Builder -> Builder
loop
  where
    loop :: ByteString -> Builder -> Builder
loop ((Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
BS.break Word8 -> Bool
quoteNeeded -> (ByteString
a,ByteString
b)) Builder
rest
      = ByteString -> Builder
byteString ByteString
a Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend`
          case ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
b of
            Maybe (Word8, ByteString)
Nothing     ->  Builder
rest
            Just (Word8
c,ByteString
d)  ->  Word8 -> Builder
quoteChar Word8
c Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder -> Builder
loop ByteString
d Builder
rest

    quoteNeeded :: Word8 -> Bool
quoteNeeded Word8
c = Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'\"' Bool -> Bool -> Bool
|| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'\\'
    quoteChar :: Word8 -> Builder
quoteChar Word8
c
        | Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'\"' = ByteString -> Builder
byteString ByteString
"\\\""
        | Bool
otherwise     = ByteString -> Builder
byteString ByteString
"\\\\"

hstore :: (ToHStoreText a, ToHStoreText b) => a -> b -> HStoreBuilder
hstore :: a -> b -> HStoreBuilder
hstore (a -> HStoreText
forall a. ToHStoreText a => a -> HStoreText
toHStoreText -> (HStoreText Builder
key)) (b -> HStoreText
forall a. ToHStoreText a => a -> HStoreText
toHStoreText -> (HStoreText Builder
val)) =
    Builder -> HStoreBuilder
Comma (Char -> Builder
char8 Char
'"' Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
key Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
"\"=>\""
              Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
val Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Char -> Builder
char8 Char
'"')

instance ToField HStoreBuilder where
    toField :: HStoreBuilder -> Action
toField  HStoreBuilder
Empty    = ByteString -> Action
forall a. ToField a => a -> Action
toField (ByteString
BS.empty)
    toField (Comma Builder
x) = ByteString -> Action
forall a. ToField a => a -> Action
toField (Builder -> ByteString
BU.toLazyByteString Builder
x)

newtype HStoreList = HStoreList {HStoreList -> [(Text, Text)]
fromHStoreList :: [(Text,Text)]} deriving (Typeable, Int -> HStoreList -> ShowS
[HStoreList] -> ShowS
HStoreList -> String
(Int -> HStoreList -> ShowS)
-> (HStoreList -> String)
-> ([HStoreList] -> ShowS)
-> Show HStoreList
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HStoreList] -> ShowS
$cshowList :: [HStoreList] -> ShowS
show :: HStoreList -> String
$cshow :: HStoreList -> String
showsPrec :: Int -> HStoreList -> ShowS
$cshowsPrec :: Int -> HStoreList -> ShowS
Show)

-- | hstore
instance ToHStore HStoreList where
    toHStore :: HStoreList -> HStoreBuilder
toHStore (HStoreList [(Text, Text)]
xs) = [HStoreBuilder] -> HStoreBuilder
forall a. Monoid a => [a] -> a
mconcat (((Text, Text) -> HStoreBuilder)
-> [(Text, Text)] -> [HStoreBuilder]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Text -> HStoreBuilder) -> (Text, Text) -> HStoreBuilder
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Text -> HStoreBuilder
forall a b.
(ToHStoreText a, ToHStoreText b) =>
a -> b -> HStoreBuilder
hstore) [(Text, Text)]
xs)

instance ToField HStoreList where
    toField :: HStoreList -> Action
toField HStoreList
xs = HStoreBuilder -> Action
forall a. ToField a => a -> Action
toField (HStoreList -> HStoreBuilder
forall a. ToHStore a => a -> HStoreBuilder
toHStore HStoreList
xs)

-- | hstore
instance FromField HStoreList where
    fromField :: FieldParser HStoreList
fromField Field
f Maybe ByteString
mdat = do
      ByteString
typ <- Field -> Conversion ByteString
typename Field
f
      if ByteString
typ ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"hstore"
        then (String -> Maybe Oid -> String -> String -> String -> ResultError)
-> Field -> String -> Conversion HStoreList
forall a err.
(Typeable a, Exception err) =>
(String -> Maybe Oid -> String -> String -> String -> err)
-> Field -> String -> Conversion a
returnError String -> Maybe Oid -> String -> String -> String -> ResultError
Incompatible Field
f String
""
        else case Maybe ByteString
mdat of
               Maybe ByteString
Nothing  -> (String -> Maybe Oid -> String -> String -> String -> ResultError)
-> Field -> String -> Conversion HStoreList
forall a err.
(Typeable a, Exception err) =>
(String -> Maybe Oid -> String -> String -> String -> err)
-> Field -> String -> Conversion a
returnError String -> Maybe Oid -> String -> String -> String -> ResultError
UnexpectedNull Field
f String
""
               Just ByteString
dat ->
                   case Parser (Either UnicodeException HStoreList)
-> ByteString -> Either String (Either UnicodeException HStoreList)
forall a. Parser a -> ByteString -> Either String a
P.parseOnly (Parser (Either UnicodeException HStoreList)
parseHStore Parser (Either UnicodeException HStoreList)
-> Parser ByteString ()
-> Parser (Either UnicodeException HStoreList)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
P.endOfInput) ByteString
dat of
                     Left String
err ->
                         (String -> Maybe Oid -> String -> String -> String -> ResultError)
-> Field -> String -> Conversion HStoreList
forall a err.
(Typeable a, Exception err) =>
(String -> Maybe Oid -> String -> String -> String -> err)
-> Field -> String -> Conversion a
returnError String -> Maybe Oid -> String -> String -> String -> ResultError
ConversionFailed Field
f String
err
                     Right (Left UnicodeException
err) ->
                         (String -> Maybe Oid -> String -> String -> String -> ResultError)
-> Field -> String -> Conversion HStoreList
forall a err.
(Typeable a, Exception err) =>
(String -> Maybe Oid -> String -> String -> String -> err)
-> Field -> String -> Conversion a
returnError String -> Maybe Oid -> String -> String -> String -> ResultError
ConversionFailed Field
f String
"unicode exception" Conversion HStoreList
-> Conversion HStoreList -> Conversion HStoreList
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                           UnicodeException -> Conversion HStoreList
forall err a. Exception err => err -> Conversion a
conversionError UnicodeException
err
                     Right (Right HStoreList
val) ->
                         HStoreList -> Conversion HStoreList
forall (m :: * -> *) a. Monad m => a -> m a
return HStoreList
val

newtype HStoreMap  = HStoreMap {HStoreMap -> Map Text Text
fromHStoreMap :: Map Text Text} deriving (HStoreMap -> HStoreMap -> Bool
(HStoreMap -> HStoreMap -> Bool)
-> (HStoreMap -> HStoreMap -> Bool) -> Eq HStoreMap
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HStoreMap -> HStoreMap -> Bool
$c/= :: HStoreMap -> HStoreMap -> Bool
== :: HStoreMap -> HStoreMap -> Bool
$c== :: HStoreMap -> HStoreMap -> Bool
Eq, Eq HStoreMap
Eq HStoreMap
-> (HStoreMap -> HStoreMap -> Ordering)
-> (HStoreMap -> HStoreMap -> Bool)
-> (HStoreMap -> HStoreMap -> Bool)
-> (HStoreMap -> HStoreMap -> Bool)
-> (HStoreMap -> HStoreMap -> Bool)
-> (HStoreMap -> HStoreMap -> HStoreMap)
-> (HStoreMap -> HStoreMap -> HStoreMap)
-> Ord HStoreMap
HStoreMap -> HStoreMap -> Bool
HStoreMap -> HStoreMap -> Ordering
HStoreMap -> HStoreMap -> HStoreMap
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: HStoreMap -> HStoreMap -> HStoreMap
$cmin :: HStoreMap -> HStoreMap -> HStoreMap
max :: HStoreMap -> HStoreMap -> HStoreMap
$cmax :: HStoreMap -> HStoreMap -> HStoreMap
>= :: HStoreMap -> HStoreMap -> Bool
$c>= :: HStoreMap -> HStoreMap -> Bool
> :: HStoreMap -> HStoreMap -> Bool
$c> :: HStoreMap -> HStoreMap -> Bool
<= :: HStoreMap -> HStoreMap -> Bool
$c<= :: HStoreMap -> HStoreMap -> Bool
< :: HStoreMap -> HStoreMap -> Bool
$c< :: HStoreMap -> HStoreMap -> Bool
compare :: HStoreMap -> HStoreMap -> Ordering
$ccompare :: HStoreMap -> HStoreMap -> Ordering
$cp1Ord :: Eq HStoreMap
Ord, Typeable, Int -> HStoreMap -> ShowS
[HStoreMap] -> ShowS
HStoreMap -> String
(Int -> HStoreMap -> ShowS)
-> (HStoreMap -> String)
-> ([HStoreMap] -> ShowS)
-> Show HStoreMap
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HStoreMap] -> ShowS
$cshowList :: [HStoreMap] -> ShowS
show :: HStoreMap -> String
$cshow :: HStoreMap -> String
showsPrec :: Int -> HStoreMap -> ShowS
$cshowsPrec :: Int -> HStoreMap -> ShowS
Show)

instance ToHStore HStoreMap where
    toHStore :: HStoreMap -> HStoreBuilder
toHStore (HStoreMap Map Text Text
xs) = (Text -> Text -> HStoreBuilder -> HStoreBuilder)
-> HStoreBuilder -> Map Text Text -> HStoreBuilder
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey Text -> Text -> HStoreBuilder -> HStoreBuilder
forall a b.
(ToHStoreText a, ToHStoreText b) =>
a -> b -> HStoreBuilder -> HStoreBuilder
f HStoreBuilder
forall a. Monoid a => a
mempty Map Text Text
xs
      where f :: a -> b -> HStoreBuilder -> HStoreBuilder
f a
k b
v HStoreBuilder
xs' = a -> b -> HStoreBuilder
forall a b.
(ToHStoreText a, ToHStoreText b) =>
a -> b -> HStoreBuilder
hstore a
k b
v HStoreBuilder -> HStoreBuilder -> HStoreBuilder
forall a. Monoid a => a -> a -> a
`mappend` HStoreBuilder
xs'

instance ToField HStoreMap where
    toField :: HStoreMap -> Action
toField HStoreMap
xs = HStoreBuilder -> Action
forall a. ToField a => a -> Action
toField (HStoreMap -> HStoreBuilder
forall a. ToHStore a => a -> HStoreBuilder
toHStore HStoreMap
xs)

instance FromField HStoreMap where
    fromField :: FieldParser HStoreMap
fromField Field
f Maybe ByteString
mdat = HStoreList -> HStoreMap
convert (HStoreList -> HStoreMap)
-> Conversion HStoreList -> Conversion HStoreMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldParser HStoreList
forall a. FromField a => FieldParser a
fromField Field
f Maybe ByteString
mdat
      where convert :: HStoreList -> HStoreMap
convert (HStoreList [(Text, Text)]
xs) = Map Text Text -> HStoreMap
HStoreMap ([(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, Text)]
xs)

parseHStoreList :: BS.ByteString -> Either String HStoreList
parseHStoreList :: ByteString -> Either String HStoreList
parseHStoreList ByteString
dat =
    case Parser (Either UnicodeException HStoreList)
-> ByteString -> Either String (Either UnicodeException HStoreList)
forall a. Parser a -> ByteString -> Either String a
P.parseOnly (Parser (Either UnicodeException HStoreList)
parseHStore Parser (Either UnicodeException HStoreList)
-> Parser ByteString ()
-> Parser (Either UnicodeException HStoreList)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
P.endOfInput) ByteString
dat of
      Left String
err          -> String -> Either String HStoreList
forall a b. a -> Either a b
Left (ShowS
forall a. Show a => a -> String
show String
err)
      Right (Left UnicodeException
err)  -> String -> Either String HStoreList
forall a b. a -> Either a b
Left (UnicodeException -> String
forall a. Show a => a -> String
show UnicodeException
err)
      Right (Right HStoreList
val) -> HStoreList -> Either String HStoreList
forall a b. b -> Either a b
Right HStoreList
val

parseHStore :: P.Parser (Either UnicodeException HStoreList)
parseHStore :: Parser (Either UnicodeException HStoreList)
parseHStore = do
    [Either UnicodeException (Text, Text)]
kvs <- Parser ByteString (Either UnicodeException (Text, Text))
-> Parser ByteString Word8
-> Parser ByteString [Either UnicodeException (Text, Text)]
forall (m :: * -> *) a s. MonadPlus m => m a -> m s -> m [a]
P.sepBy' (Parser ByteString ()
skipWhiteSpace Parser ByteString ()
-> Parser ByteString (Either UnicodeException (Text, Text))
-> Parser ByteString (Either UnicodeException (Text, Text))
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString (Either UnicodeException (Text, Text))
parseHStoreKeyVal)
                    (Parser ByteString ()
skipWhiteSpace Parser ByteString ()
-> Parser ByteString Word8 -> Parser ByteString Word8
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Word8 -> Parser ByteString Word8
P.word8 (Char -> Word8
c2w Char
','))
    Either UnicodeException HStoreList
-> Parser (Either UnicodeException HStoreList)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either UnicodeException HStoreList
 -> Parser (Either UnicodeException HStoreList))
-> Either UnicodeException HStoreList
-> Parser (Either UnicodeException HStoreList)
forall a b. (a -> b) -> a -> b
$ [(Text, Text)] -> HStoreList
HStoreList ([(Text, Text)] -> HStoreList)
-> Either UnicodeException [(Text, Text)]
-> Either UnicodeException HStoreList
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Either UnicodeException (Text, Text)]
-> Either UnicodeException [(Text, Text)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Either UnicodeException (Text, Text)]
kvs

parseHStoreKeyVal :: P.Parser (Either UnicodeException (Text,Text))
parseHStoreKeyVal :: Parser ByteString (Either UnicodeException (Text, Text))
parseHStoreKeyVal = do
  Either UnicodeException Text
mkey <- Parser (Either UnicodeException Text)
parseHStoreText
  case Either UnicodeException Text
mkey of
    Left UnicodeException
err -> Either UnicodeException (Text, Text)
-> Parser ByteString (Either UnicodeException (Text, Text))
forall (m :: * -> *) a. Monad m => a -> m a
return (UnicodeException -> Either UnicodeException (Text, Text)
forall a b. a -> Either a b
Left UnicodeException
err)
    Right Text
key -> do
      Parser ByteString ()
skipWhiteSpace
      ByteString
_ <- ByteString -> Parser ByteString
P.string ByteString
"=>"
      Parser ByteString ()
skipWhiteSpace
      Either UnicodeException Text
mval <- Parser (Either UnicodeException Text)
parseHStoreText
      case Either UnicodeException Text
mval of
        Left  UnicodeException
err -> Either UnicodeException (Text, Text)
-> Parser ByteString (Either UnicodeException (Text, Text))
forall (m :: * -> *) a. Monad m => a -> m a
return (UnicodeException -> Either UnicodeException (Text, Text)
forall a b. a -> Either a b
Left UnicodeException
err)
        Right Text
val -> Either UnicodeException (Text, Text)
-> Parser ByteString (Either UnicodeException (Text, Text))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Text, Text) -> Either UnicodeException (Text, Text)
forall a b. b -> Either a b
Right (Text
key,Text
val))


skipWhiteSpace :: P.Parser ()
skipWhiteSpace :: Parser ByteString ()
skipWhiteSpace = (Word8 -> Bool) -> Parser ByteString ()
P.skipWhile Word8 -> Bool
P.isSpace_w8

parseHStoreText :: P.Parser (Either UnicodeException Text)
parseHStoreText :: Parser (Either UnicodeException Text)
parseHStoreText = do
  Word8
_ <- Word8 -> Parser ByteString Word8
P.word8 (Char -> Word8
c2w Char
'"')
  Either UnicodeException [Text]
mtexts <- ([Text] -> [Text]) -> Parser (Either UnicodeException [Text])
parseHStoreTexts [Text] -> [Text]
forall a. a -> a
id
  case Either UnicodeException [Text]
mtexts of
    Left  UnicodeException
err   -> Either UnicodeException Text
-> Parser (Either UnicodeException Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (UnicodeException -> Either UnicodeException Text
forall a b. a -> Either a b
Left UnicodeException
err)
    Right [Text]
texts -> do
                     Word8
_ <- Word8 -> Parser ByteString Word8
P.word8 (Char -> Word8
c2w Char
'"')
                     Either UnicodeException Text
-> Parser (Either UnicodeException Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Either UnicodeException Text
forall a b. b -> Either a b
Right ([Text] -> Text
TS.concat [Text]
texts))

parseHStoreTexts :: ([Text] -> [Text])
                 -> P.Parser (Either UnicodeException [Text])
parseHStoreTexts :: ([Text] -> [Text]) -> Parser (Either UnicodeException [Text])
parseHStoreTexts [Text] -> [Text]
acc = do
  Either UnicodeException Text
mchunk <- ByteString -> Either UnicodeException Text
TS.decodeUtf8' (ByteString -> Either UnicodeException Text)
-> Parser ByteString -> Parser (Either UnicodeException Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word8 -> Bool) -> Parser ByteString
P.takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Word8 -> Bool) -> Word8 -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Bool
isSpecialChar)
  case Either UnicodeException Text
mchunk of
    Left UnicodeException
err    -> Either UnicodeException [Text]
-> Parser (Either UnicodeException [Text])
forall (m :: * -> *) a. Monad m => a -> m a
return (UnicodeException -> Either UnicodeException [Text]
forall a b. a -> Either a b
Left UnicodeException
err)
    Right Text
chunk ->
        (do
          Word8
_ <- Word8 -> Parser ByteString Word8
P.word8 (Char -> Word8
c2w Char
'\\')
          Text
c <- Char -> Text
TS.singleton (Char -> Text) -> (Word8 -> Char) -> Word8 -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Char
w2c (Word8 -> Text)
-> Parser ByteString Word8 -> Parser ByteString Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word8 -> Bool) -> Parser ByteString Word8
P.satisfy Word8 -> Bool
isSpecialChar
          ([Text] -> [Text]) -> Parser (Either UnicodeException [Text])
parseHStoreTexts ([Text] -> [Text]
acc ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
chunkText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:) ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
cText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:))
        ) Parser (Either UnicodeException [Text])
-> Parser (Either UnicodeException [Text])
-> Parser (Either UnicodeException [Text])
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Either UnicodeException [Text]
-> Parser (Either UnicodeException [Text])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Text] -> Either UnicodeException [Text]
forall a b. b -> Either a b
Right ([Text] -> [Text]
acc [Text
chunk]))
 where
   isSpecialChar :: Word8 -> Bool
isSpecialChar Word8
c = Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'\\' Bool -> Bool -> Bool
|| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'"'