{-# 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 = forall a. a -> a
id

toBuilder :: HStoreBuilder -> Builder
toBuilder :: HStoreBuilder -> Builder
toBuilder HStoreBuilder
x = case HStoreBuilder
x of
                HStoreBuilder
Empty -> 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 forall a. Monoid a => a -> a -> a
`mappend` case HStoreBuilder
x of
                               HStoreBuilder
Empty   -> forall a. Monoid a => a
mempty
                               Comma Builder
b -> Char -> Builder
char8 Char
',' 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, NonEmpty HStoreText -> HStoreText
HStoreText -> HStoreText -> 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 :: forall b. Integral b => 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
[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
Monoid)

instance ToHStoreText HStoreText where
  toHStoreText :: HStoreText -> HStoreText
toHStoreText = 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 forall a. Monoid a => a
mempty)

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

instance ToHStoreText TL.Text where
  toHStoreText :: Text -> HStoreText
toHStoreText = Builder -> HStoreText
HStoreText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Text -> a -> a) -> a -> Text -> a
TL.foldrChunks (ByteString -> Builder -> Builder
escapeAppend forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TS.encodeUtf8) 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 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 forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder -> Builder
loop ByteString
d Builder
rest

    quoteNeeded :: Word8 -> Bool
quoteNeeded Word8
c = Word8
c forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'\"' Bool -> Bool -> Bool
|| Word8
c forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'\\'
    quoteChar :: Word8 -> Builder
quoteChar Word8
c
        | Word8
c 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 :: forall a b.
(ToHStoreText a, ToHStoreText b) =>
a -> b -> HStoreBuilder
hstore (forall a. ToHStoreText a => a -> HStoreText
toHStoreText -> (HStoreText Builder
key)) (forall a. ToHStoreText a => a -> HStoreText
toHStoreText -> (HStoreText Builder
val)) =
    Builder -> HStoreBuilder
Comma (Char -> Builder
char8 Char
'"' forall a. Monoid a => a -> a -> a
`mappend` Builder
key forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
byteString ByteString
"\"=>\""
              forall a. Monoid a => a -> a -> a
`mappend` Builder
val forall a. Monoid a => a -> a -> a
`mappend` Char -> Builder
char8 Char
'"')

instance ToField HStoreBuilder where
    toField :: HStoreBuilder -> Action
toField  HStoreBuilder
Empty    = forall a. ToField a => a -> Action
toField (ByteString
BS.empty)
    toField (Comma Builder
x) = 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
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) = forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b.
(ToHStoreText a, ToHStoreText b) =>
a -> b -> HStoreBuilder
hstore) [(Text, Text)]
xs)

instance ToField HStoreList where
    toField :: HStoreList -> Action
toField HStoreList
xs = forall a. ToField a => a -> Action
toField (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 forall a. Eq a => a -> a -> Bool
/= ByteString
"hstore"
        then 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  -> 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 forall a. Parser a -> ByteString -> Either String a
P.parseOnly (Parser ByteString (Either UnicodeException HStoreList)
parseHStore forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall t. Chunk t => Parser t ()
P.endOfInput) ByteString
dat of
                     Left String
err ->
                         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) ->
                         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" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                           forall err a. Exception err => err -> Conversion a
conversionError UnicodeException
err
                     Right (Right HStoreList
val) ->
                         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
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
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
Ord, Typeable, Int -> HStoreMap -> ShowS
[HStoreMap] -> ShowS
HStoreMap -> String
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) = forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey forall {a} {b}.
(ToHStoreText a, ToHStoreText b) =>
a -> b -> HStoreBuilder -> HStoreBuilder
f forall a. Monoid a => a
mempty Map Text Text
xs
      where f :: a -> b -> HStoreBuilder -> HStoreBuilder
f a
k b
v HStoreBuilder
xs' = forall a b.
(ToHStoreText a, ToHStoreText b) =>
a -> b -> HStoreBuilder
hstore a
k b
v forall a. Monoid a => a -> a -> a
`mappend` HStoreBuilder
xs'

instance ToField HStoreMap where
    toField :: HStoreMap -> Action
toField HStoreMap
xs = forall a. ToField a => a -> Action
toField (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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 (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 forall a. Parser a -> ByteString -> Either String a
P.parseOnly (Parser ByteString (Either UnicodeException HStoreList)
parseHStore forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall t. Chunk t => Parser t ()
P.endOfInput) ByteString
dat of
      Left String
err          -> forall a b. a -> Either a b
Left (forall a. Show a => a -> String
show String
err)
      Right (Left UnicodeException
err)  -> forall a b. a -> Either a b
Left (forall a. Show a => a -> String
show UnicodeException
err)
      Right (Right HStoreList
val) -> forall a b. b -> Either a b
Right HStoreList
val

parseHStore :: P.Parser (Either UnicodeException HStoreList)
parseHStore :: Parser ByteString (Either UnicodeException HStoreList)
parseHStore = do
    [Either UnicodeException (Text, Text)]
kvs <- forall (m :: * -> *) a s. MonadPlus m => m a -> m s -> m [a]
P.sepBy' (Parser ()
skipWhiteSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString (Either UnicodeException (Text, Text))
parseHStoreKeyVal)
                    (Parser ()
skipWhiteSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Word8 -> Parser ByteString Word8
P.word8 (Char -> Word8
c2w Char
','))
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [(Text, Text)] -> HStoreList
HStoreList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left UnicodeException
err)
    Right Text
key -> do
      Parser ()
skipWhiteSpace
      ByteString
_ <- ByteString -> Parser ByteString
P.string ByteString
"=>"
      Parser ()
skipWhiteSpace
      Either UnicodeException Text
mval <- Parser (Either UnicodeException Text)
parseHStoreText
      case Either UnicodeException Text
mval of
        Left  UnicodeException
err -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left UnicodeException
err)
        Right Text
val -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (Text
key,Text
val))


skipWhiteSpace :: P.Parser ()
skipWhiteSpace :: Parser ()
skipWhiteSpace = (Word8 -> Bool) -> Parser ()
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 forall a. a -> a
id
  case Either UnicodeException [Text]
mtexts of
    Left  UnicodeException
err   -> forall (m :: * -> *) a. Monad m => a -> m a
return (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
'"')
                     forall (m :: * -> *) a. Monad m => a -> m a
return (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' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word8 -> Bool) -> Parser ByteString
P.takeWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Bool
isSpecialChar)
  case Either UnicodeException Text
mchunk of
    Left UnicodeException
err    -> forall (m :: * -> *) a. Monad m => a -> m a
return (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Char
w2c 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
chunkforall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
cforall a. a -> [a] -> [a]
:))
        ) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right ([Text] -> [Text]
acc [Text
chunk]))
 where
   isSpecialChar :: Word8 -> Bool
isSpecialChar Word8
c = Word8
c forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'\\' Bool -> Bool -> Bool
|| Word8
c forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'"'