8000 Some refactoring · postgres-haskell/postgres-wire@ea45394 · GitHub
[go: up one dir, main page]
Skip to content

Commit ea45394

Browse files
VyacheslavHashovVyacheslavHashov
committed
Some refactoring
1 parent cbf6613 commit ea45394

File tree

4 files changed

+61
-60
lines changed

4 files changed

+61
-60
lines changed

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

Lines changed: 43 additions & 32 deletions
Original file line numberDiff line numberDiff line change
@@ -1,25 +1,59 @@
1-
module Database.PostgreSQL.Driver.Error where
2-
3-
import Control.Exception
1+
module Database.PostgreSQL.Driver.Error
2+
(
3+
-- * Errors
4+
Error(..)
5+
, AuthError(..)
6+
-- * Exceptions
7+
, ReceiverException(..)
8+
, IncorrectUsage
9+
, ProtocolException
10+
-- * helpers
11+
, throwIncorrectUsage
12+
, throwProtocolEx
13+
, eitherToProtocolEx
14+
, throwErrorInIO
15+
, throwAuthErrorInIO
16+
) where
17+
18+
import Control.Exception (throwIO, Exception(..), SomeException)
419
import Data.ByteString (ByteString)
5-
import qualified Data.ByteString.Char8 as BS
620
import System.Socket (AddressInfoException)
21+
import qualified Data.ByteString.Char8 as BS
722

823
import Database.PostgreSQL.Protocol.Types (ErrorDesc)
924

10-
-- All possible exceptions:
11-
-- SocketException
12-
-- PeekException.
13-
-- ProtocolException
14-
-- IncorrectUsage.
25+
-- All possible errors.
26+
data Error
27+
-- Error sended by PostgreSQL, not application error.
28+
= PostgresError ErrorDesc
29+
| AuthError AuthError
30+
-- Receiver errors that may occur in receiver thread.
31+
-- When such error occurs it means that receiver thread died.
32+
| ReceiverError ReceiverException
33+
deriving (Show)
34+
35+
-- | Unexcepted exception in the ReceiverThread.
36+
newtype ReceiverException = ReceiverException SomeException
37+
deriving (Show)
38+
39+
-- Errors that might occur at authorization phase.
40+
-- Non-recoverable.
41+
data AuthError
42+
= AuthNotSupported ByteString
43+
| AuthInvalidAddress
44+
| AuthAddressException AddressInfoException
45+
deriving (Show)
1546

47+
-- | Exception throwing when `readNextData` or `waitReadyForQuery`
48+
-- used incorrectly.
1649
newtype IncorrectUsage = IncorrectUsage ByteString
1750
deriving (Show)
1851

1952
instance Exception IncorrectUsage where
2053
displayException (IncorrectUsage msg) =
2154
"Incorrect usage: " ++ BS.unpack msg
2255

56+
-- | Exception in high-level parsing protocol messages.
2357
newtype ProtocolException = ProtocolException ByteString
2458
deriving (Show)
2559

@@ -36,29 +70,6 @@ throwProtocolEx = throwIO . ProtocolException
3670
eitherToProtocolEx :: Either ByteString a -> IO a
3771
eitherToProtocolEx = either throwProtocolEx pure
3872

39-
-- All possible errors.
40-
data Error
41-
-- Error sended by PostgreSQL, not application error.
42-
= PostgresError ErrorDesc
43-
| AuthError AuthError
44-
-- Receiver errors that may occur in receiver thread. When such error occur
45-
-- it means that receiver thread died.
46-
| ReceiverError ReceiverException
47-
deriving (Show)
48-
49-
newtype ReceiverException = ReceiverException SomeException
50-
deriving (Show)
51-
52-
-- Errors that might occur at authorization phase.
53-
-- Non-recoverable.
54-
data AuthError
55-
= AuthNotSupported ByteString
56-
| AuthInvalidAddress
57-
| AuthAddressException AddressInfoException
58-
deriving (Show)
59-
60-
-- Helpers
61-
6273
throwErrorInIO :: Error -> IO (Either Error a)
6374
throwErrorInIO = pure . Left
6475

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

Lines changed: 12 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -3,7 +3,7 @@
33
module Database.PostgreSQL.Protocol.Decoders
44
(
55
-- * High-lever decoder
6-
decodeNextServerMessage
6+
decodeNextServerMessage
77
-- * Decoders
88
, decodeAuthResponse
99
, decodeHeader
@@ -14,26 +14,18 @@ module Database.PostgreSQL.Protocol.Decoders
1414
, parseErrorDesc
1515
) where
1616

17-
import Control.Applicative
18-
import Control.Monad
1917
import Data.Monoid ((<>))
2018
import Data.Maybe (fromMaybe)
2119
import Data.Char (chr)
22-
import Data.Word
23-
import Foreign
20+
import Data.Word (Word8, Word16, Word32)
2421
import Text.Read (readMaybe)
2522
import qualified Data.Vector as V
2623
import qualified Data.ByteString as B
27-
import qualified Data.ByteString.Unsafe as B
28-
import qualified Data.ByteString.Lazy as BL
29-
import qualified Data.ByteString.Lazy.Internal as BL
3024
import Data.ByteString.Char8 as BS(readInteger, readInt, unpack, pack)
3125
import qualified Data.HashMap.Strict as HM
3226

3327
import Database.PostgreSQL.Protocol.Types
3428
import Database.PostgreSQL.Protocol.Store.Decode
35-
import Database.PostgreSQL.Protocol.Utils
36-
3729

3830
-- | Parses and dispatches all server messages except `DataRow`.
3931
decodeNextServerMessage
@@ -46,7 +38,7 @@ decodeNextServerMessage bs readMoreAction = go Nothing bs
4638
where
4739
-- Parse header
4840
go Nothing bs
49-
| B.length bs < 5 = readMoreAndGo Nothing bs
41+
| B.length bs < headerSize = readMoreAndGo Nothing bs
5042
| otherwise = let (rest, h) = runDecode decodeHeader bs
5143
in go (Just h) rest
5244
-- Parse body
@@ -57,13 +49,15 @@ decodeNextServerMessage bs readMoreAction = go Nothing bs
5749
{-# INLINE readMoreAndGo #-}
5850
readMoreAndGo h = (go h =<<) . readMoreAction
5951

52+
--------------------------------
53+
-- Protocol decoders
54+
6055
decodeAuthResponse :: Decode AuthResponse
6156
decodeAuthResponse = do
62-
c <- getWord8
63-
len <- getInt32BE
57+
Header c len <- decodeHeader
6458
case chr $ fromIntegral c of
6559
'E' -> AuthErrorResponse <$>
66-
(getByteString (fromIntegral $ len - 4) >>=
60+
(getByteString len >>=
6761
eitherToDecode .parseErrorDesc)
6862
'R' -> do
6963
rType <- getInt32BE
@@ -73,8 +67,7 @@ decodeAuthResponse = do
7367
5 -> AuthenticationMD5Password . MD5Salt <$> getByteString 4
7468
7 -> pure AuthenticationGSS
7569
9 -> pure AuthenticationSSPI
76-
8 -> AuthenticationGSSContinue <$>
77-
getByteString (fromIntegral $ len -8)
70+
8 -> AuthenticationGSSContinue <$> getByteString (len - 4)
7871
_ -> fail "Unknown authentication response"
7972
_ -> fail "Invalid auth response"
8073

@@ -115,14 +108,6 @@ decodeServerMessage (Header c len) = case chr $ fromIntegral c of
115108
rowsCount <- fromIntegral <$> getInt16BE
116109
RowDescription <$> V.replicateM rowsCount decodeFieldDescription
117110

118-
-- | Decodes a single data value. Length `-1` indicates a NULL column value.
119-
-- No value bytes follow in the NULL case.
120-
decodeValue :: Decode (Maybe B.ByteString)
121-
decodeValue = getInt32BE >>= \n ->
122-
if n == -1
123-
then pure Nothing
124-
else Just <$> getByteString (fromIntegral n)
125-
126111
decodeTransactionStatus :: Decode TransactionStatus
127112
decodeTransactionStatus = getWord8 >>= \t ->
128113
case chr $ fromIntegral t of
@@ -154,7 +139,8 @@ decodeFormat = getInt16BE >>= \f ->
154139
1 -> pure Binary
155140
_ -> fail "Unknown field format"
156141

157-
-- Parser that just work with B.ByteString, not Decode type
142+
-----------------------------
143+
-- Helper parsers that work with B.ByteString, not Decode type
158144

159145
-- Helper to parse, not used by decoder itself
160146
parseServerVersion :: B.ByteString -> Either B.ByteString ServerVersion
@@ -288,6 +274,7 @@ parseNoticeDesc s = do
288274
"is not presented in NoticeResponse message")
289275
Right . HM.lookup c
290276

277+
-- | Helper to lift Either in Decode
291278
eitherToDecode :: Either B.ByteString a -> Decode a
292279
eitherToDecode = either (fail . BS.unpack) pure
293280

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

Lines changed: 2 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -27,8 +27,7 @@ loopExtractDataRows readMoreAction callback = go "" ""
2727
where
2828
go :: B.ByteString -> BL.ByteString -> IO ()
2929
go bs acc
30-
-- 5 - header size, defined by PostgreSQL
31-
| B.length bs < 5 = readMoreAndGo bs acc
30+
| B.length bs < headerSize = readMoreAndGo bs acc
3231
| otherwise = do
3332
ScanRowResult ch rest r <- scanDataRows bs
3433
-- We should force accumulator
@@ -45,7 +44,7 @@ loopExtractDataRows readMoreAction callback = go "" ""
4544
-- that there are enough bytes to read header.
4645
2 -> do
4746
Header mt len <- parseHeader rest
48-
dispatchHeader mt len (B.drop 5 rest) newAcc
47+
dispatchHeader mt len (B.drop headerSize rest) newAcc
4948

5049
{-# INLINE dispatchHeader #-}
5150
dispatchHeader :: Word8 -> Int -> B.ByteString -> BL.ByteString -> IO ()

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

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -154,6 +154,10 @@ data CancelRequest = CancelRequest !ServerProcessId !ServerSecretKey
154154
data Header = Header {-# UNPACK #-} !Word8 {-# UNPACK #-} !Int
155155
deriving (Show)
156156

157+
-- | Server message's header size.
158+
headerSize :: Int
159+
headerSize = 5
160+
157161
-- | All possible responses from a server in usual query phase.
158162
data ServerMessage
159163
= BackendKeyData !ServerProcessId !ServerSecretKey

0 commit comments

Comments
 (0)
0