module PostgreSQL.Binary.Decoder
(
Decoder,
run,
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,
ArrayDecoder,
array,
arrayDimension,
arrayValue,
arrayNonNullValue,
CompositeDecoder,
composite,
compositeValue,
compositeNonNullValue,
hstore,
enum,
)
where
import PostgreSQL.Binary.Prelude hiding (take, bool, drop, state, fail, failure)
import BinaryParser
import qualified PostgreSQL.Binary.Data as Data
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 Decoder =
BinaryParser
intOfSize :: (Integral a, Bits a) => Int -> Decoder a
intOfSize x =
fmap Integral.pack (bytesOfSize x)
onContent :: Decoder a -> Decoder ( Maybe a )
onContent decoder =
size >>=
\case
(1) -> pure Nothing
n -> fmap Just (sized (fromIntegral n) decoder)
where
size =
intOfSize 4 :: Decoder Int32
content :: Decoder (Maybe ByteString)
content =
intOfSize 4 >>= \case
(1) -> pure Nothing
n -> fmap Just (bytesOfSize n)
nonNull :: Maybe a -> Decoder a
nonNull =
maybe (failure "Unexpected NULL") return
fn :: (ByteString -> Either Text a) -> Decoder a
fn fn =
BinaryParser.remainders >>= either BinaryParser.failure return . fn
int :: (Integral a, Bits a) => Decoder a
int =
fmap Integral.pack remainders
float4 :: Decoder Float
float4 =
unsafeCoerce (int :: Decoder Int32)
float8 :: Decoder Double
float8 =
unsafeCoerce (int :: Decoder Int64)
bool :: Decoder Bool
bool =
fmap (== 1) byte
numeric :: Decoder 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 :: Decoder UUID
uuid =
UUID.fromWords <$> intOfSize 4 <*> intOfSize 4 <*> intOfSize 4 <*> intOfSize 4
ip4 :: Decoder IPAddr.IP4
ip4 =
IPAddr.ip4FromOctets <$> intOfSize 1 <*> intOfSize 1 <*> intOfSize 1 <*> intOfSize 1
ip6 :: Decoder IPAddr.IP6
ip6 =
IPAddr.ip6FromWords <$> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2 <*> intOfSize 2
inet :: Decoder (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 :: Decoder Aeson.Value
json_ast =
bytea_strict >>= either (BinaryParser.failure . fromString) pure . Aeson.eitherDecodeStrict'
json_bytes :: (ByteString -> Either Text a) -> Decoder a
json_bytes cont =
getAllBytes >>= parseJSON
where
getAllBytes =
BinaryParser.remainders
parseJSON =
either BinaryParser.failure return . cont
jsonb_ast :: Decoder Aeson.Value
jsonb_ast =
jsonb_bytes $ mapLeft fromString . Aeson.eitherDecodeStrict'
jsonb_bytes :: (ByteString -> Either Text a) -> Decoder 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 :: Decoder Char
char =
fmap Text.uncons text_strict >>= \case
Just (c, "") -> return c
Nothing -> failure "Empty input"
_ -> failure "Consumed too much"
text_strict :: Decoder 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 :: Decoder 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 :: Decoder ByteString
bytea_strict =
remainders
bytea_lazy :: Decoder LazyByteString
bytea_lazy =
fmap LazyByteString.fromStrict remainders
date :: Decoder Day
date =
fmap (Time.postgresJulianToDay . fromIntegral) (int :: Decoder Int32)
time_int :: Decoder TimeOfDay
time_int =
fmap Time.microsToTimeOfDay int
time_float :: Decoder TimeOfDay
time_float =
fmap Time.secsToTimeOfDay float8
timetz_int :: Decoder (TimeOfDay, TimeZone)
timetz_int =
(,) <$> sized 8 time_int <*> tz
timetz_float :: Decoder (TimeOfDay, TimeZone)
timetz_float =
(,) <$> sized 8 time_float <*> tz
tz :: Decoder TimeZone
tz =
fmap (minutesToTimeZone . negate . (flip div 60) . fromIntegral) (int :: Decoder Int32)
timestamp_int :: Decoder LocalTime
timestamp_int =
fmap Time.microsToLocalTime int
timestamp_float :: Decoder LocalTime
timestamp_float =
fmap Time.secsToLocalTime float8
timestamptz_int :: Decoder UTCTime
timestamptz_int =
fmap Time.microsToUTC int
timestamptz_float :: Decoder UTCTime
timestamptz_float =
fmap Time.secsToUTC float8
interval_int :: Decoder DiffTime
interval_int =
do
u <- sized 8 int
d <- sized 4 int
m <- int
return $ Interval.toDiffTime $ Interval.Interval u d m
interval_float :: Decoder 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
arrayRep :: Decoder Data.Array
arrayRep =
do
dimensionsAmount <- intOfSize 4
nullsValue <- nulls
oid <- intOfSize 4
dimensions <- Vector.replicateM dimensionsAmount dimension
let valuesAmount = (Vector.product . Vector.map fst) dimensions
values <- Vector.replicateM (fromIntegral valuesAmount) content
return (dimensions, values, nullsValue, oid)
where
dimension =
(,) <$> intOfSize 4 <*> intOfSize 4
nulls =
intOfSize 4 >>= \(x :: Word32) -> case x of
0 -> return False
1 -> return True
w -> failure $ "Invalid value: " <> (fromString . show) w
compositeRep :: Decoder Data.Composite
compositeRep =
do
componentsAmount <- intOfSize 4
Vector.replicateM componentsAmount component
where
component =
(,) <$> intOfSize 4 <*> content
hstore :: ( forall m. Monad m => Int -> m ( k , Maybe v ) -> m r ) -> Decoder k -> Decoder v -> Decoder r
hstore replicateM keyContent valueContent =
do
componentsAmount <- intOfSize 4
replicateM componentsAmount component
where
component =
(,) <$> key <*> value
where
key =
onContent keyContent >>= nonNull
value =
onContent valueContent
hstoreRep :: Decoder Data.HStore
hstoreRep =
do
componentsAmount <- intOfSize 4
Vector.replicateM componentsAmount component
where
component =
(,) <$> key <*> content
where
key =
intOfSize 4 >>= bytesOfSize
newtype CompositeDecoder a =
CompositeDecoder ( Decoder a )
deriving ( Functor , Applicative , Monad )
composite :: CompositeDecoder a -> Decoder a
composite (CompositeDecoder decoder) =
numOfComponents *> decoder
where
numOfComponents =
unitOfSize 4
compositeValue :: Decoder a -> CompositeDecoder ( Maybe a )
compositeValue valueDecoder =
CompositeDecoder (skipOid *> onContent valueDecoder)
where
skipOid =
unitOfSize 4
compositeNonNullValue :: Decoder a -> CompositeDecoder a
compositeNonNullValue valueDecoder =
CompositeDecoder (skipOid *> onContent valueDecoder >>= maybe (failure "Unexpected NULL") return)
where
skipOid =
unitOfSize 4
newtype ArrayDecoder a =
ArrayDecoder ( [ Word32 ] -> Decoder a )
deriving ( Functor )
array :: ArrayDecoder a -> Decoder a
array (ArrayDecoder 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
arrayDimension :: ( forall m. Monad m => Int -> m a -> m b ) -> ArrayDecoder a -> ArrayDecoder b
arrayDimension replicateM (ArrayDecoder component) =
ArrayDecoder $ \case
head : tail -> replicateM (fromIntegral head) (component tail)
_ -> failure "A missing dimension length"
arrayValue :: Decoder a -> ArrayDecoder ( Maybe a )
arrayValue =
ArrayDecoder . const . onContent
arrayNonNullValue :: Decoder a -> ArrayDecoder a
arrayNonNullValue =
ArrayDecoder . const . join . fmap (maybe (failure "Unexpected NULL") return) . onContent
enum :: (Text -> Maybe a) -> Decoder a
enum mapping =
text_strict >>= onText
where
onText text =
maybe onNothing onJust (mapping text)
where
onNothing =
failure ("No mapping for text \"" <> text <> "\"")
onJust =
pure