8000 Password and md5 authorization · postgres-haskell/postgres-wire@45c3e25 · GitHub
[go: up one dir, main page]
Skip to content

Commit 45c3e25

Browse files
VyacheslavHashovVyacheslavHashov
committed
Password and md5 authorization
1 parent c8fe1a5 commit 45c3e25

File tree

4 files changed

+64
-20
lines changed

4 files changed

+64
-20
lines changed

‎postgres-wire.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -38,6 +38,7 @@ library
3838
, unix
3939
, postgresql-binary
4040
, tls
41+
, cryptonite
4142
default-language: Haskell2010
4243
default-extensions:
4344
OverloadedStrings

‎src/Database/PostgreSQL/Connection.hs

Lines changed: 61 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -28,8 +28,8 @@ import System.Socket.Family.Inet
2828
import System.Socket.Type.Stream
2929
import System.Socket.Protocol.TCP
3030
import System.Socket.Family.Unix
31-
import Data.Time.Clock.POSIX
3231
import Control.Concurrent.Chan.Unagi
32+
import Crypto.Hash (hash, Digest, MD5)
3333

3434
import Database.PostgreSQL.Protocol.Encoders
3535
import Database.PostgreSQL.Protocol.Decoders
@@ -62,6 +62,10 @@ data Error
6262
| ImpossibleError
6363
deriving (Show)
6464

65+
data AuthError
66+
= AuthPostgresError ErrorDesc
67+
| AuthNotSupported B.ByteString
68+
6569
data DataMessage = DataMessage [V.Vector B.ByteString]
6670
deriving (Show)
6771

@@ -118,11 +122,13 @@ connect :: ConnectionSettings -> IO Connection
118122
connect settings = do
119123
rawConn <- createRawConnection settings
120124
when (settingsTls settings == RequiredTls) $ handshakeTls rawConn
121-
authorize rawConn settings
125+
authResult <- authorize rawConn settings
126+
-- TODO should close connection on error
127+
connParams <- either (error "invalid connection") pure authResult
122128

123129
(inDataChan, outDataChan) <- newChan
124-
(inAllChan, outAllChan) <- newChan
125-
storage <- newStatementStorage
130+
(inAllChan, outAllChan) <- newChan
131+
storage <- newStatementStorage
126132

127133
tid <- forkIO $ receiverThread rawConn inDataChan inAllChan
128134
pure Connection
@@ -131,18 +137,62 @@ connect settings = do
131137
, connOutDataChan = outDataChan
132138
, connOutAllChan = outAllChan
133139
, connStatementStorage = storage
134-
, connParameters = ConnectionParameters
135-
{ paramServerVersion = ServerVersion 1 1 1
136-
, paramServerEncoding = ""
137-
, paramIntegerDatetimes = True
138-
}
140+
, connParameters = connParams
139141
}
140142

141-
authorize :: RawConnection -> ConnectionSettings -> IO ()
143+
authorize
144+
:: RawConnection
145+
-> ConnectionSettings
146+
-> IO (Either AuthError ConnectionParameters)
142147
authorize rawConn settings = do
143148
sendStartMessage rawConn $ consStartupMessage settings
149+
-- 4096 should be enough for the whole response from a server at
150+
-- startup phase.
144151
r <- rReceive rawConn 4096
145-
readAuthMessage r
152+
case pushChunk (runGetIncremental decodeAuthResponse) r of
153+
BG.Done rest _ r -> case r of
154+
AuthenticationOk -> do
155+
putStrLn "Auth ok"
156+
-- TODO parse parameters
157+
pure $ Right $ parseParameters rest
158+
AuthenticationCleartextPassword ->
159+
performPasswordAuth $ PasswordPlain $ settingsPassword settings
160+
AuthenticationMD5Password (MD5Salt salt) ->
161+
let pass = "md5" <> md5Hash (md5Hash (settingsPassword settings
162+
<> settingsUser settings) <> salt)
163+
in performPasswordAuth $ PasswordMD5 pass
164+
AuthenticationGSS -> pure $ Left $ AuthNotSupported "GSS"
165+
AuthenticationSSPI -> pure $ Left $ AuthNotSupported "SSPI"
166+
AuthenticationGSSContinue _ -> pure $ Left $ AuthNotSupported "GSS"
167+
AuthErrorResponse desc -> pure $ Left $ AuthPostgresError desc
168+
-- TODO handle this case
169+
f -> error "athorize"
170+
where
171+
performPasswordAuth
172+
:: PasswordText -> IO (Either AuthError ConnectionParameters)
173+
performPasswordAuth password = do
174+
putStrLn $ "sending password" ++ show password
175+
sendMessage rawConn $ PasswordMessage password
176+
r <- rReceive rawConn 4096
177+
case pushChunk (runGetIncremental decodeAuthResponse) r of
178+
BG.Done rest _ r -> case r of
179+
AuthenticationOk -> do
180+
putStrLn "Auth ok"
181+
pure $ Right $ parseParameters rest
182+
AuthErrorResponse desc ->
183+
pure $ Left $ AuthPostgresError desc
184+
_ -> error "Impossible happened"
185+
-- TODO handle this case
186+
f -> error "authorize"
187+
-- TODO right parsing
188+
parseParameters :: B.ByteString -> ConnectionParameters
189+
parseParameters str = ConnectionParameters
190+
{ paramServerVersion = ServerVersion 1 1 1
191+
, paramIntegerDatetimes = False
192+
, paramServerEncoding = ""
193+
}
194+
md5Hash :: B.ByteString -> B.ByteString
195+
md5Hash bs = BS.pack $ show (hash bs :: Digest MD5)
146196

147197
handshakeTls :: RawConnection -> IO ()
148198
handshakeTls _ = pure ()
@@ -166,13 +216,6 @@ sendMessage rawConn msg = void $ do
166216
let smsg = toStrict . toLazyByteString $ encodeClientMessage msg
167217
rSend rawConn smsg
168218

169-
readAuthMessage :: B.ByteString -> IO ()
170-
readAuthMessage s =
171-
case pushChunk (runGetIncremental decodeAuthResponse) s of
172-
BG.Done _ _ r -> case r of
173-
AuthenticationOk -> putStrLn "Auth ok"
174-
_ -> error "Invalid auth"
175-
f -> error $ show s
176219

177220
receiverThread
178221
:: RawConnection

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -21,11 +21,11 @@ import Database.PostgreSQL.Protocol.Types
2121
decodeAuthResponse :: Get AuthResponse
2222
decodeAuthResponse = do
2323
c <- getWord8
24+
len <- getInt32be
2425
case chr $ fromIntegral c of
2526
'E' -> AuthErrorResponse <$>
2627
(getByteString (fromIntegral $ len - 4) >>= decodeErrorDesc)
2728
'R' -> do
28-
len <- getInt32be
2929
rType <- getInt32be
3030
case rType of
3131
0 -> pure AuthenticationOk

‎src/Database/PostgreSQL/Settings.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -30,7 +30,7 @@ defaultConnectionSettings = ConnectionSettings
3030
, settingsPort = 5432
3131
, settingsDatabase = "testdb"
3232
, settingsUser = "v"
33-
, settingsPassword = ""
33+
, settingsPassword = "123"
3434
, settingsTls = RequiredTls
3535
}
3636

0 commit comments

Comments
 (0)
0