Permalink
Browse files

Support password-based authentication.

  • Loading branch information...
1 parent b266e10 commit 7ebdb14cdd2a6d4a9e728b43d66a5074f98a4640 @chrisdone committed Oct 5, 2011
Showing with 35 additions and 18 deletions.
  1. +32 −18 Database/PostgreSQL/Base.hs
  2. +3 −0 Database/PostgreSQL/Base/Types.hs
@@ -34,7 +34,7 @@ import Data.Binary.Put
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
-import qualified Data.ByteString.Lazy.UTF8 as L (toString)
+import qualified Data.ByteString.Lazy.UTF8 as L (toString,fromString)
import Data.ByteString.UTF8 (toString,fromString)
import Data.Int
import Data.List
@@ -191,7 +191,7 @@ authenticate :: Connection -> ConnectInfo -> IO ()
authenticate conn@Connection{..} connectInfo = do
withConnection conn $ \h -> do
sendStartUp h connectInfo
- getConnectInfoResponse h
+ getConnectInfoResponse h connectInfo
objects <- objectIds h
modifyMVar_ connectionObjects (\_ -> return objects)
@@ -205,16 +205,39 @@ sendStartUp h ConnectInfo{..} = do
zero
-- | Wait for and process the connectInfoentication response from the server.
-getConnectInfoResponse :: Handle -> IO ()
-getConnectInfoResponse h = do
+getConnectInfoResponse :: Handle -> ConnectInfo -> IO ()
+getConnectInfoResponse h conninfo = do
(typ,block) <- getMessage h
-- TODO: Handle connectInfo failure. Handle information messages that are
-- sent, maybe store in the connection value for later
-- inspection.
case typ of
- AuthenticationOk | param == 0 -> waitForReady h
+ AuthenticationOk
+ | param == 0 -> waitForReady h
+ | param == 3 -> sendPassClearText h conninfo
+-- | param == 5 -> sendPassMd5 h conninfo salt
+ | otherwise -> E.throw $ UnsupportedAuthenticationMethod param (show block)
where param = decode block :: Int32
- _ -> E.throw $ AuthenticationFailed (show block)
+ _salt = flip runGet block $ do
+ _ <- getInt32
+ getWord8
+
+ els -> E.throw $ AuthenticationFailed (show (els,block))
+
+-- | Send the pass as clear text and wait for connect response.
+sendPassClearText :: Handle -> ConnectInfo -> IO ()
+sendPassClearText h conninfo@ConnectInfo{..} = do
+ sendMessage h PasswordMessage $
+ string (fromString connectPassword)
+ getConnectInfoResponse h conninfo
+
+-- -- | Send the pass as salted MD5 and wait for connect response.
+-- sendPassMd5 :: Handle -> ConnectInfo -> Word8 -> IO ()
+-- sendPassMd5 h conninfo@ConnectInfo{..} salt = do
+-- -- TODO: Need md5 library with salt support.
+-- sendMessage h PasswordMessage $
+-- string (fromString connectPassword)
+-- getConnectInfoResponse h conninfo
--------------------------------------------------------------------------------
-- Initialization
@@ -255,24 +278,13 @@ sendQuery types h sql = do
setStatus
RowDescription -> getRowDesc types block
DataRow -> getDataRow block
- -- NoticeResponse -> getNotice block
_ -> return ()
continue
where emptyResponse = Result [] Nothing Nothing [] UnknownMessageType Nothing
listener m = execStateT (fix m) emptyResponse
--- parseErr ::
--- parseErr = loop where
--- loop = do
--- errtype <- get
--- if (errtype == (0 :: Word8))
--- then return []
--- else let x = (errtype)
--- in do xs <- loop
--- return (x : xs)
-
-- | CommandComplete returns a ‘tag’ which indicates how many rows were
-- affected, or returned, as a result of the command.
-- See http://developer.postgresql.org/pgdocs/postgres/protocol-message-formats.html
@@ -433,14 +445,16 @@ types = [('C',CommandComplete)
,('Z',ReadyForQuery)
,('N',NoticeResponse)
,('R',AuthenticationOk)
- ,('Q',Query)]
+ ,('Q',Query)
+ ,('p',PasswordMessage)]
-- | Blocks until receives ReadyForQuery.
waitForReady :: Handle -> IO ()
waitForReady h = loop where
loop = do
(typ,block) <- getMessage h
case typ of
+ ErrorResponse -> E.throw $ GeneralError $ show block
ReadyForQuery | decode block == 'I' -> return ()
_ -> loop
@@ -32,6 +32,8 @@ data ConnectionError =
| AuthenticationFailed String -- ^ Connecting failed due to authentication problem.
| InitializationError String -- ^ Initialization (e.g. getting data types) failed.
| ConnectionLost -- ^ Connection was lost when using withConnection.
+ | UnsupportedAuthenticationMethod Int32 String -- ^ Unsupported method of authentication (e.g. md5).
+ | GeneralError String
deriving (Typeable,Show)
instance Exception ConnectionError where
@@ -73,6 +75,7 @@ data MessageType =
| NoticeResponse
| AuthenticationOk
| Query
+ | PasswordMessage
| UnknownMessageType
deriving (Show,Eq)

0 comments on commit 7ebdb14

Please sign in to comment.