8000 High-lever prototype for decoders · postgres-haskell/postgres-wire@3afc091 · GitHub
[go: up one dir, main page]
Skip to content

Commit 3afc091

Browse files
VyacheslavHashovVyacheslavHashov
committed
High-lever prototype for decoders
1 parent 7427f65 commit 3afc091

File tree

7 files changed

+282
-25
lines changed

7 files changed

+282
-25
lines changed

‎bench/Bench.hs

Lines changed: 59 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -47,7 +47,6 @@ import Criterion.Main
4747
-- INSERT INTO _bytes_300_of_100(b)
4848
-- (SELECT repeat('a', 100)::bytea FROM generate_series(1, 300));
4949

50-
-- main = benchMultiPw
5150
main = defaultMain
5251
-- [ bgroup "Requests"
5352
-- [
@@ -56,13 +55,34 @@ main = defaultMain
5655
-- ]
5756
-- ]
5857
[ bgroup "Decoder"
59-
[ bench "datarow" $ nf benchDataRowDecoder bs
60-
]
58+
[ env (pure dec) $ \p -> bench "datarow" $ nf (benchDataRowDecoder p) bs]
6159
]
6260
-- main = benchMultiPw
63-
64-
benchDataRowDecoder bs = decodeManyRows decodeDataRow $
65-
DataRows (DataChunk 350 bs) Empty
61+
dec :: Decode (Maybe B.ByteString, Maybe Int32, Maybe Int32,
62+
Maybe Int16, Maybe Bool, Maybe B.ByteString,
63+
Maybe Bool, Maybe Bool, Maybe B.ByteString,
64+
Maybe Int32, Maybe Int32, Maybe Int32)
65+
dec = rowDecoder
66+
67+
parser = skipDataRowHeader *> p
68+
where
69+
p = (,,,,,,,,,,,)
70+
<$> fn getByteString
71+
<*> fn int4
72+
<*> fn int4
73+
<*> fn int2
74+
<*> fn bool
75+
<*> fn getByteString
76+
<*> fn bool
77+
<*> fn bool
78+
<*> fn getByteString
79+
<*> fn int4
80+
<*> fn int4
81+
<*> fn int4
82+
fn = getNullable
83+
84+
benchDataRowDecoder d bs = decodeManyRows d $
85+
DataRows (DataChunk A3E2 380 bs) Empty
6686
where
6787
decodeDataRow = do
6888
(Header _ len) <- decodeHeader
@@ -99,7 +119,7 @@ benchLoop = do
99119
benchRequests :: IO c -> (c -> IO a) -> IO ()
100120
benchRequests connectAction queryAction = do
101121
rs <- replicateM 8 newThread
102-
threadDelay 10000000
122+
threadDelay $ 2 *1000000
103123
traverse (\(_,_, tid) -> killThread tid) rs
104124
s <- sum <$> traverse (\(ref, _, _) -> readIORef ref) rs
105125
latency_total <- sum <$> traverse (\(_, ref, _) -> readIORef ref) rs
@@ -112,7 +132,8 @@ benchRequests connectAction queryAction = do
112132
c <- connectAction
113133
tid <- forkIO $ forever $ do
114134
t1 <- getTime Monotonic
115-
queryAction c
135+
r <- queryAction c
136+
r `seq` pure ()
116137
t2 <- getTime Monotonic
117138
modifyIORef' ref_latency (+ (getDifference t2 t1))
118139
modifyIORef' ref_count (+1)
@@ -132,11 +153,22 @@ requestAction c = replicateM_ 100 $ do
132153
benchMultiPw :: IO ()
133154
benchMultiPw = benchRequests createConnection $ \c -> do
134155
sendBatchAndSync c [q]
135-
readNextData c
156+
d <- readNextData c
136157
waitReadyForQuery c
158+
-- case d of
159+
-- Left _ -> undefined
160+
-- Right rows -> pure $ decodeManyRows dec rows
137161
where
138162
q = Query largeStmt V.empty Binary Binary AlwaysCache
139163
largeStmt = "SELECT * from _bytes_300_of_100"
164+
-- largeStmt = "select typname, typnamespace, typowner, typlen, typbyval,"
165+
-- <> "typcategory, typispreferred, typisdefined, typdelim,"
166+
-- <> "typrelid, typelem, typarray from pg_type"
167+
dec :: Decode (Maybe B.ByteString, Maybe Int32, Maybe Int32,
168+
Maybe Int16, Maybe Bool, Maybe B.ByteString,
169+
Maybe Bool, Maybe Bool, Maybe B.ByteString,
170+
Maybe Int32, Maybe Int32, Maybe Int32)
171+
dec = rowDecoder
140172

141173
benchLibpq :: IO ()
142174
benchLibpq = benchRequests libpqConnection $ \c -> do
@@ -176,3 +208,21 @@ instance NFData (AbsConnection a) where
176208
instance NFData Error where
177209
rnf _ = ()
178210

211+
instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7, NFData a8, NFData a9, NFData a10, NFData a11, NFData a12) =>
212+
NFData (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12) where
213+
rnf (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12) =
214+
rnf x1 `seq`
215+
rnf x2 `seq`
216+
rnf x3 `seq`
217+
rnf x4 `seq`
218+
rnf x5 `seq`
219+
rnf x6 `seq`
220+
rnf x7 `seq`
221+
rnf x8 `seq`
222+
rnf x9 `seq`
223+
rnf x10 `seq`
224+
rnf x11 `seq`
225+
rnf x12
226+
227+
instance NFData (Decode a) where
228+
rnf !d = ()

‎postgres-wire.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -38,6 +38,7 @@ library
3838
, bytestring
3939
, socket
4040
, socket-unix
41+
, free
4142
, vector
4243
, safe
4344
, time

‎src/Database/PostgreSQL/Driver/RawConnection.hs

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,7 @@ import System.Socket (socket, AddressInfo(..), getAddressInfo, socketAddress,
1414
import System.Socket.Family.Inet (Inet)
1515
import System.Socket.Type.Stream (Stream, sendAll)
1616
import System.Socket.Protocol.TCP (TCP)
17+
import System.Socket.Protocol.Default (Default)
1718
import System.Socket.Family.Unix (Unix, socketAddressUnixPath)
1819
import qualified Data.ByteString as B
1920
import qualified Data.ByteString.Char8 as BS(pack)
@@ -51,7 +52,7 @@ createRawConnection settings
5152

5253
unixConnection dirPath = do
5354
let mAddress = socketAddressUnixPath $ makeUnixPath dirPath
54-
createAndConnect mAddress (socket :: IO (Socket Unix Stream Unix))
55+
createAndConnect mAddress (socket :: IO (Socket Unix Stream Default))
5556

5657
tcpConnection = fmap excToError . try $ do
5758
mAddress <- fmap socketAddress . headMay <$>

‎src/Database/PostgreSQL/Protocol/Codecs/Decoders.hs

Lines changed: 177 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -1,55 +1,219 @@
1+
{-# language GADTs #-}
2+
{-# language TypeFamilies #-}
3+
{-# language DataKinds #-}
4+
{-# language KindSignatures #-}
5+
{-# language ScopedTypeVariables #-}
6+
{-# language FlexibleInstances #-}
7+
{-# language FlexibleContexts #-}
8+
{-# language UndecidableInstances #-}
9+
{-# language ConstrainedClassMethods #-}
110
module Database.PostgreSQL.Protocol.Codecs.Decoders where
211

3-
import Data.Bool
12+
-- import Data.Bool
413
import Data.Word
514
import Data.Int
615
import Data.Char
716
import Control.Monad
817
import qualified Data.ByteString as B
918
import qualified Data.Vector as V
1019

20+
import Control.Monad
21+
import Control.Applicative.Free
22+
import Data.Proxy
23+
import Prelude hiding (bool)
24+
1125
import Database.PostgreSQL.Protocol.Store.Decode
1226
import Database.PostgreSQL.Protocol.Store.Encode
1327
import Database.PostgreSQL.Protocol.Types
1428

29+
{-# INLINE skipDataRowHeader #-}
1530
skipDataRowHeader :: Decode ()
1631
skipDataRowHeader = skipBytes 7
1732

33+
{-# INLINE fieldLength #-}
1834
fieldLength :: Decode Int
1935
fieldLength = fromIntegral <$> getInt32BE
2036

37+
{-# INLINE getNonNullable #-}
2138
getNonNullable :: FieldDecoder a -> Decode a
22-
getNonNullable dec = fieldLength >>= runFieldDecoder dec
39+
getNonNullable fdec = fieldLength >>= fdec
2340

41+
{-# INLINE getNullable #-}
2442
getNullable :: FieldDecoder a -> Decode (Maybe a)
25-
getNullable dec = do
43+
getNullable fdec = do
2644
len <- fieldLength
2745
if len == -1
2846
then pure Nothing
29-
else Just <$!> runFieldDecoder dec len
47+
else Just <$!> fdec len
3048

3149
-- Field in composites Oid before value
32-
compositeValue :: Decode a -> Decode a
33-
compositeValue dec = skipBytes 4 >> dec
50+
compositeValue :: Decode ()
51+
compositeValue = skipBytes 4
3452

53+
-- Skips length of elements in composite
3554
compositeHeader :: Decode ()
3655
compositeHeader = skipBytes 4
3756

38-
arrayData :: Int -> Decode a -> Decode (V.Vector a)
39-
arrayData len dec = undefined
57+
-- Dimensions, HasNull, Oid
58+
arrayHeader :: Decode ()
59+
arrayHeader = skipBytes 12
60+
61+
arrayDimensions :: Int -> Decode (V.Vector Int)
62+
arrayDimensions depth = V.reverse <$> V.replicateM depth arrayDimSize
63+
where
64+
arrayDimSize = (fromIntegral <$> getInt32BE) <* getInt32BE
65+
66+
67+
arrayFieldDecoder :: Int -> (V.Vector Int -> Decode a) -> FieldDecoder a
68+
arrayFieldDecoder dims f _ = arrayHeader *> arrayDimensions dims >>= f
4069

4170
-- Public decoders
4271
-- | Decodes only content of a field.
43-
newtype FieldDecoder a = FieldDecoder { runFieldDecoder :: Int -> Decode a }
72+
type FieldDecoder a = Int -> Decode a
4473

74+
{-# INLINE int2 #-}
4575
int2 :: FieldDecoder Int16
46-
int2 = FieldDecoder $ \ _ -> getInt16BE
76+
int2 _ = getInt16BE
4777

78+
{-# INLINE int4 #-}
4879
int4 :: FieldDecoder Int32
49-
int4 = FieldDecoder $ \ _ -> getInt32BE
80+
int4 _ = getInt32BE
5081

82+
{-# INLINE int8 #-}
5183
int8 :: FieldDecoder Int64
52-
int8 = FieldDecoder $ \ _ -> getInt64BE
84+
int8 _ = getInt64BE
5385

86+
{-# INLINE bool #-}
5487
bool :: FieldDecoder Bool
55-
bool = FieldDecoder $ \ _ -> (== 1) <$> getWord8
88+
bool _ = (== 1) <$> getWord8
89+
90+
data FieldF r a
91+
= Single !(FieldDecoder a)
92+
| Row !(r a)
93+
94+
{-# INLINE getFieldDec #-}
95+
getFieldDec :: FieldF CompositeValue a -> FieldDecoder a
96+
getFieldDec (Single fd) = fd
97+
getFieldDec (Row r) = composite r
98+
99+
-- High level
100+
--
101+
102+
class PrimField a where
103+
104+
primField :: RowDecoder r => FieldF r a
105+
106+
{-# INLINE field #-}
107+
field :: RowDecoder r => r a
108+
field = getRowNonNullValue $ getFieldDec primField
109+
110+
type IsArrayField a :: Bool
111+
type IsArrayField a = 'False
112+
113+
type IsNullableField a :: Bool
114+
type IsNullableField a = 'False
115+
116+
arrayDim :: Proxy a -> Int
117+
arrayDim _ = 0
118+
119+
asArrayData :: V.Vector Int -> Decode a
120+
asArrayData _ = runRowDecoder (field :: RowValue a)
121+
122+
instance PrimField Int16 where
123+
primField = Single int2
124+
125+
instance PrimField Int32 where
126+
primField = Single int4
127+
128+
instance PrimField Int64 where
129+
primField = Single int8
130+
131+
instance PrimField Bool where
132+
primField = Single bool
133+
134+
instance PrimField B.ByteString where
135+
primField = Single getByteString
136+
137+
instance PrimField a => PrimField (Maybe a) where
138+
primField = undefined
139+
140+
type IsNullableField (Maybe a) = 'True
141+
type IsArrayField (Maybe a) = IsArrayField a
142+
{-# INLINE field #-}
143+
field = getRowNullValue $ getFieldDec primField
144+
145+
instance (IsAllowedArray (IsNullableField a) (IsArrayField a) ~ 'True,
146+
PrimField a)
147+
=> PrimField (V.Vector a) where
148+
primField = Single $ arrayFieldDecoder
149+
(arrayDim (Proxy :: Proxy (V.Vector a)))
150+
asArrayData
151+
152+
type IsArrayField (V.Vector a) = 'True
153+
arrayDim _ = arrayDim (Proxy :: Proxy a) + 1
154+
155+
asArrayData vec = V.replicateM (vec V.! arrayDim (Proxy :: Proxy a))
156+
$ asArrayData vec
157+
158+
type family IsAllowedArray (n :: Bool) (a :: Bool) :: Bool where
159+
IsAllowedArray 'True 'True = 'False
160+
IsAllowedArray _ _ = 'True
161+
162+
163+
-- TODO add array value
164+
newtype RowValue a = RowValue { unRowValue :: Decode a }
165+
deriving (Functor, Applicative, Monad)
166+
newtype CompositeValue a = CompositeValue { unCompositeValue :: Decode a }
167+
deriving (Functor, Applicative, Monad)
168+
169+
class (Functor r, Applicative r, Monad r) => RowDecoder r where
170+
getRowNonNullValue :: FieldDecoder a -> r a
171+
getRowNullValue :: FieldDecoder a -> r (Maybe a)
172+
runRowDecoder :: r a -> Decode a
173+
174+
instance RowDecoder RowValue where
175+
{-# INLINE getRowNonNullValue #-}
176+
getRowNonNullValue = RowValue . getNonNullable
177+
{-# INLINE getRowNullValue #-}
178+
getRowNullValue = RowValue . getNullable
179+
{-# INLINE runRowDecoder #-}
180+
runRowDecoder = unRowValue
181+
182+
instance RowDecoder CompositeValue where
183+
{-# INLINE getRowNonNullValue #-}
184+
getRowNonNullValue = CompositeValue
185+
. fmap (compositeValue *>) getNonNullable
186+
{-# INLINE getRowNullValue #-}
187+
getRowNullValue = CompositeValue
188+
. fmap (compositeValue *>) getNullable
189+
{-# INLINE runRowDecoder #-}
190+
runRowDecoder = unCompositeValue
191+
192+
instance (PrimField a1, PrimField a2, PrimField a3)
193+
=> PrimField (a1, a2, a3) where
194+
195+
{-# INLINE primField #-}
196+
primField = Row $ (,,) <$> field <*> field <*> field
197+
198+
instance (PrimField a1, PrimField a2, PrimField a3, PrimField a4,
199+
PrimField a5, PrimField a6, PrimField a7, PrimField a8,
200+
PrimField a9, PrimField a10, PrimField a11, PrimField a12)
201+
=> PrimField (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12)
202+
where
203+
{-# INLINE primField #-}
204+
primField = Row $ (,,,,,,,,,,,) <$> field <*> field <*> field <*> field
205+
<*> field <*> field <*> field <*> field
206+
<*> field <*> field <*> field <*> field
207+
208+
209+
composite :: CompositeValue a -> FieldDecoder a
210+
composite dec _ = compositeHeader *> runRowDecoder dec
211+
212+
{-# INLINE rowDecoder #-}
213+
rowDecoder :: forall a. PrimField a => Decode a
214+
rowDecoder = case primField of
215+
Single f -> skipDataRowHeader *> runRowDecoder
216+
(getRowNonNullValue f :: RowValue a)
217+
Row r -> skipDataRowHeader *> runRowDecoder (r :: RowValue a)
218+
219+

‎src/Database/PostgreSQL/Protocol/DataRows.hs

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -136,10 +136,12 @@ loopExtractDataRows readMoreAction callback = go "" Empty
136136
-----
137137

138138
-- It is better that Decode throws exception on invalid input
139+
{-# INLINABLE decodeOneRow #-}
139140
decodeOneRow :: Decode a -> DataRows -> a
140141
decodeOneRow dec Empty = snd $ runDecode dec ""
141142
decodeOneRow dec (DataRows (DataChunk _ bs) _) = snd $ runDecode dec bs
142143

144+
{-# INLINABLE decodeManyRows #-}
143145
decodeManyRows :: Decode a -> DataRows -> V.Vector a
144146
decodeManyRows dec dr = unsafePerformIO $ do
145147
vec <- MV.unsafeNew . fromIntegral $ countDataRows dr

‎stack.yaml

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -7,7 +7,8 @@ packages:
77
# Dependency packages to be pulled from upstream that are not in the resolver
88
# (e.g., acme-missiles-0.3)
99
extra-deps:
10-
- socket-unix-0.1.0.0
10+
- socket-0.8.0.0
11+
- socket-unix-0.2.0.0
1112
- store-core-0.3
1213

1314
# Override default flag values for local packages and extra-deps

0 commit comments

Comments
 (0)
0