Skip to content

Commit 0f1eaad

Browse files
VyacheslavHashovVyacheslavHashov
committed
Encoders demo
1 parent c79237e commit 0f1eaad

File tree

4 files changed

+206
-73
lines changed

4 files changed

+206
-73
lines changed

‎postgres-wire-highlevel.cabal

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -13,10 +13,14 @@ cabal-version: >=1.10
1313

1414
library
1515
hs-source-dirs: src
16-
exposed-modules: Database.PostgreSQL.Session
16+
exposed-modules:
17+
-- Database.PostgreSQL.Session
18+
Database.PostgreSQL.Query
19+
, Database.PostgreSQL.Other
1720
build-depends: base >= 4.7 && < 5
1821
, bytestring
1922
, vector
23+
, unordered-containers
2024
default-language: Haskell2010
2125
default-extensions:
2226
BangPatterns

‎src/Database/PostgreSQL/Other.hs

Lines changed: 14 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,14 @@
1+
module Database.PostgreSQL.Other where
2+
3+
data Encode = Encode String
4+
deriving (Show)
5+
6+
data Decode a = Decode
7+
deriving (Show)
8+
9+
data Oid = Oid Int
10+
deriving (Show)
11+
12+
data Query = Query [(Oid, Encode)]
13+
deriving (Show)
14+

‎src/Database/PostgreSQL/Query.hs

Lines changed: 139 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,139 @@
1+
{-# language DataKinds #-}
2+
{-# language PolyKinds #-}
3+
{-# language KindSignatures #-}
4+
module Database.PostgreSQL.Query where
5+
6+
import qualified Data.ByteString as B
7+
import qualified Data.Vector as V
8+
import qualified Data.HashMap.Strict as HM
9+
import qualified Data.HashSet as HS
10+
import Data.Word
11+
import Data.Proxy
12+
import Data.Monoid
13+
14+
-- import Database.PostgreSQL.Session
15+
import Database.PostgreSQL.Other
16+
17+
---------------
18+
-- Result Parser
19+
---------------
20+
21+
data ResultParser
22+
= OneResurtParser
23+
| MaybeResultParser
24+
| ManyParser
25+
26+
data ResultParserError
27+
= ResultNoRows
28+
| ResultToManyRows
29+
30+
---------------------
31+
-- Row parser
32+
---------------------
33+
data RowParserError = RowParserError
34+
data RowParser s a = RowParser (s -> Either RowParserError (s, a))
35+
36+
--------------------
37+
-- Encoders
38+
--------------------
39+
data EncodeResult
40+
= PrimEncode (Oid, Maybe B.ByteString)
41+
| ArrayEncode EncodeResult
42+
| CompositeEncode [EncodeResult]
43+
44+
runEncodeResult :: EncodeResult -> (Oid, Maybe B.ByteString)
45+
runEncodeResult = undefined
46+
47+
type Name = B.ByteString
48+
type NameSet = HS.HashSet Name
49+
type NameMap = HM.HashMap Name Oid
50+
51+
data QueryM a = QueryM NameSet (NameMap -> a)
52+
53+
instance Functor QueryM where
54+
fmap f (QueryM s g) = QueryM s (g . f)
55+
56+
instance Applicative QueryM where
57+
pure = QueryM HS.empty . const
58+
(QueryM s1 f) <*> (QueryM s2 x) = QueryM (s1 `HS.union` s2) (f <*> g)
59+
60+
type Encoder a = a -> QueryM EncodeResult
61+
62+
builtinEncoder :: (a -> (Oid, Maybe B.ByteString)) -> Encoder a
63+
builtinEncoder = undefined
64+
65+
enumEncoder :: Name -> (a -> String) -> Encoder a
66+
enumEncoder name f = undefined
67+
68+
arrayEncoder :: Encoder a -> Encoder [a]
69+
arrayEncoder _ = undefined
70+
71+
composite :: Name -> (a -> [QueryM EncodeResult]) -> Encoder a
72+
composite name xs = undefined
73+
74+
class ToPostgres a where
75+
toPostgres :: Encoder a
76+
77+
-- Params
78+
79+
class IsParams a where
80+
params :: a -> [QueryM EncodeResult]
81+
82+
instance (ToPostgres a, ToPostgres b) => IsParams (a, b) where
83+
params (a, b) = [toPostgres a, toPostgres b]
84+
85+
type Context = [QueryM EncodeResult]
86+
87+
class ToParams a where
88+
type ParamType a :: *
89+
90+
derive :: Proxy a -> Context -> ParamType a
91+
92+
instance IsParams a => ToParams a where
93+
type ParamType a = a -> [QueryM EncodeResult]
94+
95+
derive p ctx = ctx <> params
96+
97+
instance (ToPostgres x, ToParams xs) => ToParams (x ': xs) where
98+
type ParamType (x ': xs) = x -> ParamType xs
99+
100+
derive p ctx v = derive (Proxy :: Proxy xs) (toPostgres v : ctx)
101+
102+
instance ToParams '[] where
103+
type ParamType a = [QueryM EncodeResult]
104+
105+
derive p ctx = ctx
106+
107+
getParams :: ToParams a => SessionQuery a b -> ParamType a
108+
getParams _ = derive (Proxy :: Proxy a) []
109+
110+
111+
buildSession :: SessionQuery a b -> [QueryM EncoderResult] -> Session b
112+
buildSession = undefined
113+
-- makeQuery . runEncodeResult <$> sequence params
114+
-- where
115+
-- makeQuery values = Query
116+
117+
----------------------
118+
-- Results
119+
-------------------
120+
data ResultType a
121+
= SingleRow a
122+
| MaybeRow a
123+
| ManyRows a
124+
125+
data SessionQuery a (b :: ResultType *) = SessionQuery { sqStatement :: B.ByteString }
126+
deriving (Show)
127+
128+
type family Result a where
129+
Result (SingleRow a) = a
130+
Result (MaybeRow a) = Maybe a
131+
Result (ManyRows a) = V.Vector a
132+
133+
query :: (ToParams a, FromRows b) => SessionQuery a b -> a -> Session (Result b)
134+
query = undefined
135+
136+
137+
tq :: SessionQuery '[Int, Char, Word] b
138+
tq = undefined
139+

‎src/Database/PostgreSQL/Session.hs

Lines changed: 48 additions & 72 deletions
Original file line numberDiff line numberDiff line change
@@ -14,12 +14,7 @@ import Data.ByteString (ByteString)
1414
import Data.Either
1515
import qualified Data.Vector as V
1616

17-
import PostgreSQL.Binary.Encoder (int8_int64, run)
18-
import qualified PostgreSQL.Binary.Decoder as D(int, run)
19-
20-
import Database.PostgreSQL.Protocol.Types
21-
import Database.PostgreSQL.Connection
22-
import Database.PostgreSQL.Settings
17+
import Database.PostgreSQL.Other
2318

2419
data Count = One | Many
2520
deriving (Eq, Show)
@@ -66,70 +61,51 @@ instance Monad Session where
6661

6762
(>>) = (*>)
6863

69-
class Encode a where
70-
encode :: a -> ByteString
71-
getOid :: a -> Oid
72-
73-
class Decode a where
74-
decode :: ByteString -> a
75-
76-
instance Encode Int64 where
77-
encode = run int8_int64
78-
getOid _ = Oid 20
79-
80-
instance Decode Int64 where
81-
decode = fromRight . D.run D.int
82-
where
83-
fromRight (Right v) = v
84-
fromRight _ = error "bad fromRight"
85-
86-
data SessionQuery a b = SessionQuery { sqStatement :: ByteString }
87-
deriving (Show)
88-
89-
query :: (Encode a, Decode b) => SessionQuery a b -> a -> Session b
90-
query sq val =
91-
let q = Query { qStatement = sqStatement sq
92-
, qOids = [getOid val]
93-
, qValues = [encode val]
94-
, qParamsFormat = Binary
95-
, qResultFormat = Binary }
96-
in Send One [q] $ Receive Done
97-
98-
runSession :: Show a => Connection -> Session a -> IO (Either Error a)
99-
runSession conn = go 0
100-
where
101-
go n (Done x) = do
102-
putStrLn $ "Return " ++ show x
103-
when (n > 0) $ void $ sendSync conn >> readReadyForQuery conn
104-
pure $ Right x
105-
go n (Receive f) = do
106-
putStrLn "Receiving"
107-
r <- readNextData conn
108-
case r of
109-
Left e -> pure $ Left e
110-
Right (DataMessage rows) -> go n (f $ decode $ V.head $ head rows)
111-
go n (Send _ qs c) = do
112-
putStrLn "Sending requests "
113-
sendBatch conn qs
114-
sendFlush conn
115-
go (n + 1) c
116-
117-
q1 :: SessionQuery Int64 Int64
118-
q1 = SessionQuery "SELECT $1"
119-
120-
q2 :: SessionQuery Int64 Int64
121-
q2 = SessionQuery "SELECT count(*) from a where v < $1"
122-
123-
q3 :: SessionQuery Int64 Int64
124-
q3 = SessionQuery "SELECT 5 + $1"
125-
126-
testSession :: IO ()
127-
testSession = do
128-
c <- connect defaultConnectionSettings
129-
r <- runSession c $ do
130-
b <- query q1 10
131-
a <- query q2 b
132-
query q3 a
133-
print r
134-
close c
64+
65+
-- query :: (Encode a, Decode b) => SessionQuery a b -> a -> Session b
66+
-- query sq val =
67+
-- let q = Query { qStatement = sqStatement sq
68+
-- , qOids = [getOid val]
69+
-- , qValues = [encode val]
70+
-- , qParamsFormat = Binary
71+
-- , qResultFormat = Binary }
72+
-- in Send One [q] $ Receive Done
73+
74+
-- runSession :: Show a => Connection -> Session a -> IO (Either Error a)
75+
-- runSession conn = go 0
76+
-- where
77+
-- go n (Done x) = do
78+
-- putStrLn $ "Return " ++ show x
79+
-- when (n > 0) $ void $ sendSync conn >> readReadyForQuery conn
80+
-- pure $ Right x
81+
-- go n (Receive f) = do
82+
-- putStrLn "Receiving"
83+
-- r <- readNextData conn
84+
-- case r of
85+
-- Left e -> pure $ Left e
86+
-- Right (DataMessage rows) -> go n (f $ decode $ V.head $ head rows)
87+
-- go n (Send _ qs c) = do
88+
-- putStrLn "Sending requests "
89+
-- sendBatch conn qs
90+
-- sendFlush conn
91+
-- go (n + 1) c
92+
93+
-- q1 :: SessionQuery Int64 Int64
94+
-- q1 = SessionQuery "SELECT $1"
95+
96+
-- q2 :: SessionQuery Int64 Int64
97+
-- q2 = SessionQuery "SELECT count(*) from a where v < $1"
98+
99+
-- q3 :: SessionQuery Int64 Int64
100+
-- q3 = SessionQuery "SELECT 5 + $1"
101+
102+
-- testSession :: IO ()
103+
-- testSession = do
104+
-- c <- connect defaultConnectionSettings
105+
-- r <- runSession c $ do
106+
-- b <- query q1 10
107+
-- a <- query q2 b
108+
-- query q3 a
109+
-- print r
110+
-- close c
135111

0 commit comments

Comments
 (0)