@@ -0,0 +1,187 @@
1+{-# LANGUAGE ViewPatterns, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
3+------------------------------------------------------------------------------
5+-- Module: Database.PostgreSQL.Simple.HStore.Implementation
6+-- Copyright: (c) 2013 Leon P Smith
8+-- Maintainer: Leon P Smith <leon@melding-monads.com>
9+-- Stability: experimental
10+-- Portability: portable
12+-- This code has yet to be profiled and optimized.
14+------------------------------------------------------------------------------
16+module Database.PostgreSQL.Simple.HStore.Implementation where
18+import Control.Applicative
19+import Blaze.ByteString.Builder
20+ ( Builder, toLazyByteString, copyByteString )
21+import Blaze.ByteString.Builder.Char8 (fromChar)
22+import qualified Data.Attoparsec.ByteString as P
23+import qualified Data.Attoparsec.ByteString.Char8 as P (isSpace_w8)
24+import qualified Data.ByteString as BS
25+import Data.ByteString.Internal (c2w, w2c)
26+import qualified Data.ByteString.Lazy as BL
27+import qualified Data.ByteString.Lazy.Internal as BL
29+import qualified Data.Map as Map
30+import Data.Text(Text)
31+import qualified Data.Text as TS
32+import qualified Data.Text.Encoding as TS
33+import Data.Text.Encoding.Error(UnicodeException)
34+import qualified Data.Text.Lazy as TL
36+import Data.Monoid(Monoid(..))
37+import Database.PostgreSQL.Simple.FromField
38+import Database.PostgreSQL.Simple.ToField
45+instance Monoid HStoreBuilder where
49+ = Comma (a `mappend` case x of
51+ Comma b -> fromChar ',' `mappend` b)
53+class ToHStoreText a where
54+ toHStoreText :: a -> HStoreText
56+-- | Represents escape text, ready to be the key or value to a hstore value
57+newtype HStoreText = HStoreText Builder deriving (Typeable, Monoid)
59+instance ToHStoreText HStoreText where
62+-- | Assumed to be UTF-8 encoded
63+instance ToHStoreText BS.ByteString where
64+ toHStoreText str = HStoreText (escapeAppend str mempty)
66+-- | Assumed to be UTF-8 encoded
67+instance ToHStoreText BL.ByteString where
68+ toHStoreText = HStoreText . BL.foldrChunks escapeAppend mempty
70+instance ToHStoreText TS.Text where
71+ toHStoreText str = HStoreText (escapeAppend (TS.encodeUtf8 str) mempty)
73+instance ToHStoreText TL.Text where
74+ toHStoreText = HStoreText . TL.foldrChunks (escapeAppend . TS.encodeUtf8) mempty
76+escapeAppend :: BS.ByteString -> Builder -> Builder
79+ loop (BS.break quoteNeeded -> (a,b)) rest
80+ = copyByteString a `mappend`
83+ Just (c,d) -> quoteChar c `mappend` loop d rest
85+ quoteNeeded c = c == c2w '\"' || c == c2w '\\'
87+ | c == c2w '\"' = copyByteString "\\\""
88+ | otherwise = copyByteString "\\\\"
90+hstore :: (ToHStoreText a, ToHStoreText b) => a -> b -> HStoreBuilder
91+hstore (toHStoreText -> (HStoreText key)) (toHStoreText -> (HStoreText val)) =
92+ Comma (fromChar '"' `mappend` key `mappend` copyByteString "\"=>\""
93+ `mappend` val `mappend` fromChar '"')
95+instance ToField HStoreBuilder where
96+ toField Empty = toField (BS.empty)
97+ toField (Comma x) = toField (toLazyByteString x)
99+newtype HStoreList = HStoreList [(Text,Text)] deriving (Typeable, Show)
101+instance ToField HStoreList where
102+ toField (HStoreList xs) = toField (mconcat (map (uncurry hstore) xs))
104+instance FromField HStoreList where
105+ fromField f mdat = do
108+ then returnError Incompatible f ""
110+ Nothing -> returnError UnexpectedNull f ""
112+ case P.parseOnly parseHStore dat of
114+ returnError ConversionFailed f err
116+ returnError ConversionFailed f "unicode exception" <|>
118+ Right (Right val) ->
121+newtype HStoreMap = HStoreMap (Map Text Text) deriving (Eq, Ord, Typeable, Show)
123+instance ToField HStoreMap where
124+ toField (HStoreMap xs) = toField (Map.foldWithKey f mempty xs)
125+ where f k v xs = hstore k v `mappend` xs
127+instance FromField HStoreMap where
128+ fromField f mdat = convert <$> fromField f mdat
129+ where convert (HStoreList xs) = HStoreMap (Map.fromList xs)
131+parseHStore :: P.Parser (Either UnicodeException HStoreList)
132+parseHStore = skipWhiteSpace >> loop id
135+ mkv <- parseHStoreKeyVal
137+ Left err -> return (Left err)
141+ _ <- P.word8 (c2w ',')
144+ ) <|> return (Right (HStoreList (acc [kv])))
146+parseHStoreKeyVal :: P.Parser (Either UnicodeException (Text,Text))
147+parseHStoreKeyVal = do
148+ mkey <- parseHStoreText
150+ Left err -> return (Left err)
155+ mval <- parseHStoreText
157+ Left err -> return (Left err)
158+ Right val -> return (Right (key,val))
161+skipWhiteSpace :: P.Parser ()
162+skipWhiteSpace = P.skipWhile P.isSpace_w8
164+parseHStoreText :: P.Parser (Either UnicodeException Text)
166+ _ <- P.word8 (c2w '"')
167+ mtexts <- parseHStoreTexts id
169+ Left err -> return (Left err)
171+ _ <- P.word8 (c2w '"')
172+ return (Right (TS.concat texts))
174+parseHStoreTexts :: ([Text] -> [Text])
175+ -> P.Parser (Either UnicodeException [Text])
176+parseHStoreTexts acc = do
177+ mchunk <- TS.decodeUtf8' <$> P.takeWhile (not . isSpecialChar)
179+ Left err -> return (Left err)
182+ _ <- P.word8 (c2w '\\')
183+ c <- TS.singleton . w2c <$> P.satisfy isSpecialChar
184+ parseHStoreTexts (acc . (chunk:) . (c:))
185+ ) <|> return (Right (acc [chunk]))
187+ isSpecialChar c = c == c2w '\\' || c == c2w '"'