module PostgreSQL.Binary.Decoding
(
valueParser,
Value,
int,
float4,
float8,
bool,
bytea_strict,
bytea_lazy,
text_strict,
text_lazy,
char,
fn,
numeric,
uuid,
inet,
json_ast,
json_bytes,
jsonb_ast,
jsonb_bytes,
date,
time_int,
time_float,
timetz_int,
timetz_float,
timestamp_int,
timestamp_float,
timestamptz_int,
timestamptz_float,
interval_int,
interval_float,
Array,
array,
valueArray,
nullableValueArray,
dimensionArray,
Composite,
composite,
valueComposite,
nullableValueComposite,
hstore,
enum,
)
where
import PostgreSQL.Binary.Prelude hiding (take, bool, drop, state, fail, failure)
import BinaryParser
import qualified PostgreSQL.Binary.Integral as Integral
import qualified PostgreSQL.Binary.Interval as Interval
import qualified PostgreSQL.Binary.Numeric as Numeric
import qualified PostgreSQL.Binary.Time as Time
import qualified PostgreSQL.Binary.Inet as Inet
import qualified Data.Vector as Vector
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Lazy as LazyByteString
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.Text.Encoding.Error as Text
import qualified Data.Text.Lazy.Encoding as LazyText
import qualified Data.UUID as UUID
import qualified Data.Aeson as Aeson
import qualified Network.IP.Addr as IPAddr
type Value =
BinaryParser
valueParser :: Value a -> ByteString -> Either Text a
valueParser =
BinaryParser.run
intOfSize :: (Integral a, Bits a) => Int -> Value a
intOfSize x =
fmap Integral.pack (bytesOfSize x)
onContent :: Value a -> Value ( Maybe a )
onContent decoder =
size >>=
\case
(1) -> pure Nothing
n -> fmap Just (sized (fromIntegral n) decoder)
where
size =
intOfSize 4 :: Value Int32
content :: Value (Maybe ByteString)
content =
intOfSize 4 >>= \case
(1) -> pure Nothing
n -> fmap Just (bytesOfSize n)
nonNull :: Maybe a -> Value a
nonNull =
maybe (failure "Unexpected NULL") return
fn :: (ByteString -> Either Text a) -> Value a
fn fn =
BinaryParser.remainders >>= either BinaryParser.failure return . fn
int :: (Integral a, Bits a) => Value a
int =
fmap Integral.pack remainders
float4 :: Value Float
float4 =
unsafeCoerce (int :: Value Int32)
float8 :: Value Double
float8 =
unsafeCoerce (int :: Value Int64)
bool :: Value Bool
bool =
fmap (== 1) byte
numeric :: Value Scientific
numeric =
do
componentsAmount <- intOfSize 2
pointIndex <- intOfSize 2
signCode <- intOfSize 2
unitOfSize 2
components <- Vector.replicateM componentsAmount (intOfSize 2)
either failure return (Numeric.scientific pointIndex signCode components)
uuid :: Value UUID
uuid =
UUID.fromWords <$> intOfSize 4 <*> intOfSize 4 <*> intOfSize 4 <*> intOfSize 4
ip4 :: Value IPAddr.IP4
ip4 =
IPAddr.ip4FromOctets <$> intOfSize 1 <*> intOfSize 1 <*> intOfSize 1 <*> intOfSize 1
ip6 :: Value IPAddr.IP6
ip6 =
IPAddr.ip6FromWords <$> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2
inet :: Value (IPAddr.NetAddr IPAddr.IP)
inet = do
af <- intOfSize 1
netmask <- intOfSize 1
isCidr <- intOfSize 1
ipSize <- intOfSize 1
if | af == Inet.inetAddressFamily ->
do ip <- ip4
return $ inetFromBytes af netmask isCidr ipSize (IPAddr.IPv4 ip)
| af == Inet.inet6AddressFamily ->
do ip <- ip6
return $ inetFromBytes af netmask isCidr ipSize (IPAddr.IPv6 ip)
| otherwise -> BinaryParser.failure ("Unknown address family: " <> fromString (show af))
where
inetFromBytes :: Word8 -> Word8 -> Word8 -> Int8 -> IPAddr.IP -> IPAddr.NetAddr IPAddr.IP
inetFromBytes _ netmask _ _ ip = IPAddr.netAddr ip netmask
json_ast :: Value Aeson.Value
json_ast =
bytea_strict >>= either (BinaryParser.failure . fromString) pure . Aeson.eitherDecodeStrict'
json_bytes :: (ByteString -> Either Text a) -> Value a
json_bytes cont =
getAllBytes >>= parseJSON
where
getAllBytes =
BinaryParser.remainders
parseJSON =
either BinaryParser.failure return . cont
jsonb_ast :: Value Aeson.Value
jsonb_ast =
jsonb_bytes $ mapLeft fromString . Aeson.eitherDecodeStrict'
jsonb_bytes :: (ByteString -> Either Text a) -> Value a
jsonb_bytes cont =
getAllBytes >>= trimBytes >>= parseJSON
where
getAllBytes =
BinaryParser.remainders
trimBytes =
maybe (BinaryParser.failure "Empty input") return .
fmap snd . ByteString.uncons
parseJSON =
either BinaryParser.failure return . cont
char :: Value Char
char =
fmap Text.uncons text_strict >>= \case
Just (c, "") -> return c
Nothing -> failure "Empty input"
_ -> failure "Consumed too much"
text_strict :: Value Text
text_strict =
remainders >>= either (failure . exception) return . Text.decodeUtf8'
where
exception =
\case
Text.DecodeError message byte -> fromString message
_ -> $bug "Unexpected unicode exception"
text_lazy :: Value LazyText
text_lazy =
bytea_lazy >>= either (failure . exception) return . LazyText.decodeUtf8'
where
exception =
\case
Text.DecodeError message byte -> fromString message
_ -> $bug "Unexpected unicode exception"
bytea_strict :: Value ByteString
bytea_strict =
remainders
bytea_lazy :: Value LazyByteString
bytea_lazy =
fmap LazyByteString.fromStrict remainders
date :: Value Day
date =
fmap (Time.postgresJulianToDay . fromIntegral) (int :: Value Int32)
time_int :: Value TimeOfDay
time_int =
fmap Time.microsToTimeOfDay int
time_float :: Value TimeOfDay
time_float =
fmap Time.secsToTimeOfDay float8
timetz_int :: Value (TimeOfDay, TimeZone)
timetz_int =
(,) <$> sized 8 time_int <*> tz
timetz_float :: Value (TimeOfDay, TimeZone)
timetz_float =
(,) <$> sized 8 time_float <*> tz
tz :: Value TimeZone
tz =
fmap (minutesToTimeZone . negate . (flip div 60) . fromIntegral) (int :: Value Int32)
timestamp_int :: Value LocalTime
timestamp_int =
fmap Time.microsToLocalTime int
timestamp_float :: Value LocalTime
timestamp_float =
fmap Time.secsToLocalTime float8
timestamptz_int :: Value UTCTime
timestamptz_int =
fmap Time.microsToUTC int
timestamptz_float :: Value UTCTime
timestamptz_float =
fmap Time.secsToUTC float8
interval_int :: Value DiffTime
interval_int =
do
u <- sized 8 int
d <- sized 4 int
m <- int
return $ Interval.toDiffTime $ Interval.Interval u d m
interval_float :: Value DiffTime
interval_float =
do
u <- sized 8 (fmap (round . (*(10^6)) . toRational) float8)
d <- sized 4 int
m <- int
return $ Interval.toDiffTime $ Interval.Interval u d m
hstore :: ( forall m. Monad m => Int -> m ( k , Maybe v ) -> m r ) -> Value k -> Value v -> Value r
hstore replicateM keyContent valueContent =
do
componentsAmount <- intOfSize 4
replicateM componentsAmount component
where
component =
(,) <$> key <*> value
where
key =
onContent keyContent >>= nonNull
value =
onContent valueContent
newtype Composite a =
Composite ( Value a )
deriving ( Functor , Applicative , Monad )
composite :: Composite a -> Value a
composite (Composite decoder) =
numOfComponents *> decoder
where
numOfComponents =
unitOfSize 4
nullableValueComposite :: Value a -> Composite ( Maybe a )
nullableValueComposite valueValue =
Composite (skipOid *> onContent valueValue)
where
skipOid =
unitOfSize 4
valueComposite :: Value a -> Composite a
valueComposite valueValue =
Composite (skipOid *> onContent valueValue >>= maybe (failure "Unexpected NULL") return)
where
skipOid =
unitOfSize 4
newtype Array a =
Array ( [ Word32 ] -> Value a )
deriving ( Functor )
array :: Array a -> Value a
array (Array decoder) =
do
dimensionsAmount <- intOfSize 4
if dimensionsAmount /= 0
then do
unitOfSize (4 + 4)
dimensionSizes <- replicateM dimensionsAmount dimensionSize
decoder dimensionSizes
else decoder [0]
where
dimensionSize =
intOfSize 4 <* unitOfSize 4
dimensionArray :: ( forall m. Monad m => Int -> m a -> m b ) -> Array a -> Array b
dimensionArray replicateM (Array component) =
Array $ \case
head : tail -> replicateM (fromIntegral head) (component tail)
_ -> failure "A missing dimension length"
nullableValueArray :: Value a -> Array ( Maybe a )
nullableValueArray =
Array . const . onContent
valueArray :: Value a -> Array a
valueArray =
Array . const . join . fmap (maybe (failure "Unexpected NULL") return) . onContent
enum :: (Text -> Maybe a) -> Value a
enum mapping =
text_strict >>= onText
where
onText text =
maybe onNothing onJust (mapping text)
where
onNothing =
failure ("No mapping for text \"" <> text <> "\"")
onJust =
pure