packages feed

hasql 0.20.0.1 → 0.20.1

raw patch · 21 files changed

+403/−510 lines, 21 filesdep +bufferdep +ptrdep −binary-parserdep −scannerdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: buffer, ptr

Dependencies removed: binary-parser, scanner

Dependency ranges changed: base

API changes (from Hackage documentation)

+ Hasql.DecodePrimitive: int4 :: DecodePrimitive Int32

Files

benchmarks/Main.hs view
@@ -52,42 +52,42 @@ -- * Sessions ------------------------- -singleLargeResultInVectorSession :: F.Session (Vector (Int64, Int64))+singleLargeResultInVectorSession :: F.Session (Vector (Int32, Int32)) singleLargeResultInVectorSession =   F.batch (manyRowsBatch B.vector) -singleLargeResultInRevListSession :: F.Session [(Int64, Int64)]+singleLargeResultInRevListSession :: F.Session [(Int32, Int32)] singleLargeResultInRevListSession =   F.batch (manyRowsBatch B.revList) -manyLargeResultsInVectorSession :: F.Session [Vector (Int64, Int64)]+manyLargeResultsInVectorSession :: F.Session [Vector (Int32, Int32)] manyLargeResultsInVectorSession =   replicateM 1000 (F.batch (manyRowsBatch B.vector)) -manyLargeResultsInVectorInBatchSession :: F.Session [Vector (Int64, Int64)]+manyLargeResultsInVectorInBatchSession :: F.Session [Vector (Int32, Int32)] manyLargeResultsInVectorInBatchSession =   F.batch (replicateM 1000 (manyRowsBatch B.vector)) -manySmallResultsSession :: F.Session [(Int64, Int64)]+manySmallResultsSession :: F.Session [(Int32, Int32)] manySmallResultsSession =   replicateM 1000 (F.batch singleRowBatch) -manySmallResultsInBatchSession :: F.Session [(Int64, Int64)]+manySmallResultsInBatchSession :: F.Session [(Int32, Int32)] manySmallResultsInBatchSession =   F.batch (replicateM 1000 singleRowBatch)  -- * Queries ------------------------- -singleRowBatch :: J.Batch (Int64, Int64)+singleRowBatch :: J.Batch (Int32, Int32) singleRowBatch =   J.statement (G.prepared "select 1, 2" conquer decode) ()   where     decode =-      B.head ((,) <$> C.primitive D.int8 <*> C.primitive D.int8)+      B.head ((,) <$> C.primitive D.int4 <*> C.primitive D.int4)  {-# INLINE manyRowsBatch #-}-manyRowsBatch :: (C.DecodeRow (Int64, Int64) -> B.DecodeResult result) -> J.Batch result+manyRowsBatch :: (C.DecodeRow (Int32, Int32) -> B.DecodeResult result) -> J.Batch result manyRowsBatch decodeResult =   J.statement (G.prepared template mempty decode) ()   where@@ -95,7 +95,7 @@       "SELECT generate_series(0,1000) as a, generate_series(1000,2000) as b"     decode =       decodeResult $-      tuple <$> C.primitive D.int8 <*> C.primitive D.int8+      tuple <$> C.primitive D.int4 <*> C.primitive D.int4         where         tuple !a !b =           (a, b)
hasql.cabal view
@@ -1,7 +1,7 @@ name:   hasql version:-  0.20.0.1+  0.20.1 category:   Hasql, Database, PostgreSQL synopsis:@@ -78,7 +78,6 @@     Hasql.Core.MessageTypePredicates     Hasql.Core.NoticeFieldTypes     Hasql.Core.MessageTypeNames-    Hasql.Core.Scanner     Hasql.Core.Loops.Serializer     Hasql.Core.Loops.Receiver     Hasql.Core.Loops.Sender@@ -87,8 +86,11 @@     Hasql.Core.OID.Array     Hasql.Core.OID.Primitive     Hasql.Core.PreparedStatementRegistry-    Hasql.Core.Protocol.Decoding     Hasql.Core.Protocol.Encoding+    Hasql.Core.Protocol.Parse.Primitives+    Hasql.Core.Protocol.Parse.Responses+    Hasql.Core.Protocol.Parse.Values+    Hasql.Core.Protocol.Peek     Hasql.Core.Protocol.Model   build-depends:     -- concurrency:@@ -99,11 +101,12 @@     -- template-haskell:     template-haskell == 2.*,     -- parsing:-    scanner == 0.2.*,-    binary-parser >= 0.5.5 && < 0.6,     attoparsec >= 0.10 && < 0.14,     -- database:     postgresql-binary == 0.12.*,+    -- IO:+    ptr >= 0.15.2 && < 0.16,+    buffer >= 0.5 && < 0.6,     -- data:     bytestring-strict-builder >= 0.4.5 && < 0.5,     vector-builder == 0.3.*,
library/Hasql/Core/DecodePrimitive.hs view
@@ -2,12 +2,12 @@  import Hasql.Prelude hiding (bool) import Hasql.Core.Model-import qualified BinaryParser as A-import qualified PostgreSQL.Binary.Decoding as B+import qualified Ptr.Parse as A+import qualified Hasql.Core.Protocol.Parse.Values as B   newtype DecodePrimitive primitive =-  DecodePrimitive (ReaderT Bool A.BinaryParser primitive)+  DecodePrimitive (ReaderT Bool A.Parse primitive)   deriving (Functor)  @@ -15,12 +15,12 @@ -------------------------  {-# INLINE nonDateTime #-}-nonDateTime :: A.BinaryParser primitive -> DecodePrimitive primitive+nonDateTime :: A.Parse primitive -> DecodePrimitive primitive nonDateTime parser =   DecodePrimitive (ReaderT (const parser))  {-# INLINE dateTime #-}-dateTime :: A.BinaryParser primitive -> A.BinaryParser primitive -> DecodePrimitive primitive+dateTime :: A.Parse primitive -> A.Parse primitive -> DecodePrimitive primitive dateTime intParser floatParser =   DecodePrimitive (ReaderT (\case False -> floatParser; True -> intParser)) @@ -32,10 +32,15 @@ bool =   nonDateTime B.bool +{-# INLINE int4 #-}+int4 :: DecodePrimitive Int32+int4 =+  nonDateTime B.int4+ {-# INLINE int8 #-} int8 :: DecodePrimitive Int64 int8 =-  nonDateTime B.int+  nonDateTime B.int8  -- * Blobs -------------------------@@ -43,12 +48,12 @@ {-# INLINE text #-} text :: DecodePrimitive Text text =-  nonDateTime B.text_strict+  nonDateTime B.text  {-# INLINE bytea #-} bytea :: DecodePrimitive ByteString bytea =-  nonDateTime B.bytea_strict+  nonDateTime B.bytea  -- * Time -------------------------@@ -56,4 +61,4 @@ {-# INLINE timestamptz #-} timestamptz :: DecodePrimitive UTCTime timestamptz =-  dateTime B.timestamptz_int B.timestamptz_float+  dateTime B.intTimestamptz B.floatTimestamptz
library/Hasql/Core/Dispatcher.hs view
@@ -3,8 +3,6 @@ import Hasql.Prelude import Hasql.Core.Model import qualified Hasql.Core.Socket as A-import qualified ByteString.StrictBuilder as B-import qualified BinaryParser as D import qualified Hasql.Core.Request as C import qualified Hasql.Core.UnauthenticatedSession as G import qualified Hasql.Core.Loops.Serializer as H
library/Hasql/Core/InterpretResponses.hs view
@@ -6,6 +6,9 @@ import qualified Hasql.Core.MessageTypeNames as H import qualified Hasql.Core.ParseDataRow as A import qualified Data.Vector as B+import qualified Hasql.Core.Protocol.Parse.Responses as E+import qualified Ptr.Parse as C+import qualified Ptr.ByteString as D   newtype InterpretResponses result =@@ -57,7 +60,7 @@                 processResponse response  foldRows :: FoldM IO row result -> A.ParseDataRow row -> InterpretResponses (result, Int)-foldRows (FoldM foldStep foldStart foldEnd) (A.ParseDataRow rowLength vectorFn) =+foldRows (FoldM foldStep foldStart foldEnd) pdr =   InterpretResponses def   where     def fetchResponse discardResponse =@@ -67,19 +70,16 @@       where         processResponse !state response =           case response of-            DataRowResponse values ->-              if B.length values == rowLength-                then case vectorFn values 0 of-                  Left error -> return (Left (DecodingError error))-                  Right row -> do+            DataRowResponse bytes ->+              D.parse bytes+                (do+                  row <- E.dataRowBody pdr+                  return $ do                     nextState <- foldStep state row                     nextResponse <- fetchResponse-                    processResponse nextState nextResponse-                else return (Left (DecodingError (fromString-                  (showString "Invalid amount of columns: "-                    (shows (B.length values)-                      (showString ", expecting "-                        (show rowLength)))))))+                    processResponse nextState nextResponse)+                (\ n -> return (Left (ProtocolError ("Missing " <> (fromString . show) n <> " bytes"))))+                (return . Left . ProtocolError)             CommandCompleteResponse amount ->               do                 result <- foldEnd state@@ -97,7 +97,7 @@                 processResponse state nextResponse  singleRow :: A.ParseDataRow row -> InterpretResponses row-singleRow (A.ParseDataRow rowLength vectorFn) =+singleRow pdr =   InterpretResponses def   where     def fetchResponse discardResponse =@@ -105,18 +105,15 @@       where         processResponseWithoutRow response =           case response of-            DataRowResponse values ->-              if B.length values == rowLength-                then case vectorFn values 0 of-                  Left error -> return (Left (DecodingError error))-                  Right row -> do+            DataRowResponse bytes ->+              D.parse bytes+                (do+                  row <- E.dataRowBody pdr+                  return $ do                     nextResponse <- fetchResponse-                    processResponseWithRow row nextResponse-                else return (Left (DecodingError (fromString-                  (showString "Invalid amount of columns: "-                    (shows (B.length values)-                      (showString ", expecting "-                        (show rowLength)))))))+                    processResponseWithRow row nextResponse)+                (\ n -> return (Left (ProtocolError ("Missing " <> (fromString . show) n <> " bytes"))))+                (return . Left . ProtocolError)             CommandCompleteResponse _ ->               return (Left (DecodingError "Not a single row"))             ErrorResponse state message ->
library/Hasql/Core/Loops/Interpreter.hs view
@@ -12,6 +12,7 @@  loop :: IO Response -> IO (Maybe ResultProcessor) -> (Notification -> IO ()) -> IO () loop fetchResponse fetchResultProcessor sendNotification =+  {-# SCC "loop" #-}    forever $ do     response <- fetchResponse     fetchResult <- fetchResultProcessor@@ -34,6 +35,7 @@ -} backtrackFetch :: a -> IO a -> IO (IO a) backtrackFetch element fetch =+  {-# SCC "backtrackFetch" #-}    do     notFirstRef <- newIORef False     return $ do
library/Hasql/Core/Loops/Receiver.hs view
@@ -3,31 +3,36 @@ import Hasql.Prelude import Hasql.Core.Model import qualified Hasql.Core.Socket as A-import qualified Data.ByteString as B-import qualified Scanner as C-import qualified Hasql.Core.Scanner as D+import qualified Hasql.Core.Protocol.Peek as E+import qualified Buffer as C+import qualified Ptr.Peek as D   {-# INLINABLE loop #-} loop :: A.Socket -> (Response -> IO ()) -> (Text -> IO ()) -> IO ()-loop socket sendResponse reportError =-  processScannerResult (C.More (C.scan D.response))+loop socket sendResponse reportTransportError =+  {-# SCC "loop" #-} +  do+    buffer <- C.new 16384+    withBuffer buffer   where-    processScannerResult =-      \case-        C.More consume -> do-          receivingResult <- A.receive socket (shiftL 2 12)-          case receivingResult of-            Right bytes ->-              if B.null bytes-                then reportError "Connection interrupted"-                else processScannerResult (consume bytes)-            Left msg ->-              reportError msg-        C.Done remainders responseMaybe -> do-          traverse_ sendResponse responseMaybe-          if B.null remainders-            then processScannerResult (C.More (C.scan D.response))-            else processScannerResult (C.scan D.response remainders)-        C.Fail remainders message -> do-          reportError (fromString message)+    withBuffer buffer =+      load+      where+        receiveToBuffer failure success =+          C.push buffer 8192 $ \ptr -> do+            result <- A.receiveToPtr socket ptr 8192+            case result of+              Right amountReceived -> return (amountReceived, success)+              Left error -> return (0, failure error)+        peekFromBuffer :: D.Peek a -> (a -> IO ()) -> IO ()+        peekFromBuffer (D.Peek amount ptrIO) succeed =+          fix $ \recur ->+          join $ C.pull buffer amount (fmap succeed . {-# SCC "loop/peeking" #-} ptrIO) $ \_ ->+          receiveToBuffer reportTransportError recur+        load =+          peekFromBuffer+            (E.response+              $(todo "Handle corrupt response")+              (maybe load (\response -> sendResponse response >> load)))+            (\ bodyPeek -> peekFromBuffer bodyPeek id)
library/Hasql/Core/Loops/Sender.hs view
@@ -8,6 +8,7 @@ {-# INLINABLE loop #-} loop :: A.Socket -> IO ByteString -> (Text -> IO ()) -> IO () loop socket getNextChunk reportError =+  {-# SCC "loop" #-}    forever $ do     bytes <- getNextChunk     resultOfSending <- A.send socket bytes
library/Hasql/Core/Loops/Serializer.hs view
@@ -12,6 +12,7 @@  loop :: IO Message -> (ByteString -> IO ()) -> IO () loop getMessage sendBytes =+  {-# SCC "loop" #-}    startAnew   where     size =
library/Hasql/Core/Model.hs view
@@ -4,7 +4,7 @@   data Response =-  DataRowResponse !(Vector (Maybe ByteString)) |+  DataRowResponse {-# UNPACK #-} !ByteString |   CommandCompleteResponse !Int |   ReadyForQueryResponse !TransactionStatus |   ParseCompleteResponse |
library/Hasql/Core/ParseDataRow.hs view
@@ -1,8 +1,8 @@ module Hasql.Core.ParseDataRow where  import Hasql.Prelude-import qualified BinaryParser as D-import qualified Data.Vector as A+import qualified Ptr.Parse as B+import qualified Hasql.Core.Protocol.Parse.Primitives as C   {-|@@ -11,28 +11,20 @@ It is assumed that the size of the input vector is checked externally. -} data ParseDataRow result =-  ParseDataRow !Int !(Vector (Maybe ByteString) -> Int -> Either Text result)+  ParseDataRow {-# UNPACK #-} !Int (B.Parse result)  deriving instance Functor ParseDataRow  instance Applicative ParseDataRow where   pure x =-    ParseDataRow 0 (\_ _ -> Right x)-  (<*>) (ParseDataRow leftSize leftInterpreter) (ParseDataRow rightSize rightInterpreter) =-    ParseDataRow-      (leftSize + rightSize)-      (\vec !index -> leftInterpreter vec index <*> rightInterpreter vec (index + leftSize))+    ParseDataRow 0 (pure x)+  (<*>) (ParseDataRow leftSize leftParse) (ParseDataRow rightSize rightParse) =+    ParseDataRow (leftSize + rightSize) (leftParse <*> rightParse) -nullableColumn :: D.BinaryParser column -> ParseDataRow (Maybe column)-nullableColumn parser =-  ParseDataRow 1 $ \vec !index ->-  either (Left . mappend ("Column " <> (fromString . show) index <> ": ")) Right $-  traverse (D.run parser) (A.unsafeIndex vec index)+nullableColumn :: B.Parse column -> ParseDataRow (Maybe column)+nullableColumn parseColumn =+  ParseDataRow 1 (C.nullableDataRowColumn parseColumn) -column :: D.BinaryParser column -> ParseDataRow column-column parser =-  ParseDataRow 1 $ \vec !index ->-  either (Left . mappend ("Column " <> (fromString . show) index <> ": ")) Right $-  case A.unsafeIndex vec index of-    Just bytes -> D.run parser bytes-    Nothing -> Left "Unexpected NULL"+column :: B.Parse column -> ParseDataRow column+column parseColumn =+  ParseDataRow 1 (C.nonNullDataRowColumn parseColumn)
− library/Hasql/Core/Protocol/Decoding.hs 
@@ -1,207 +0,0 @@-module Hasql.Core.Protocol.Decoding where--import Hasql.Prelude-import Hasql.Core.Protocol.Model-import BinaryParser-import qualified Data.Vector as A-import qualified Hasql.Core.ParseDataRow as F---{-# INLINE word8 #-}-word8 :: BinaryParser Word8-word8 =-  byte--{-# INLINE word16 #-}-word16 :: BinaryParser Word16-word16 =-  beWord16--{-# INLINE word32 #-}-word32 :: BinaryParser Word32-word32 =-  beWord32--{-# INLINE int32 #-}-int32 :: BinaryParser Int32-int32 =-  fromIntegral <$> beWord32--{-# INLINE messageTypeAndLength #-}-messageTypeAndLength :: (MessageType -> PayloadLength -> a) -> BinaryParser a-messageTypeAndLength cont =-  cont <$> messageType <*> payloadLength--{-# INLINE messageType #-}-messageType :: BinaryParser MessageType-messageType =-  MessageType <$> word8--{-# INLINE payloadLength #-}-payloadLength :: BinaryParser PayloadLength-payloadLength =-  PayloadLength . subtract 4 . fromIntegral <$> word32--{-# INLINE nullableSizedValue #-}-nullableSizedValue :: BinaryParser a -> BinaryParser (Maybe a)-nullableSizedValue value =-  do-    size <- int32-    case size of-      -1 -> return Nothing-      _ -> sized (fromIntegral size) (fmap Just value)--{-# INLINE sizedValue #-}-sizedValue :: BinaryParser a -> BinaryParser a-sizedValue value =-  do-    size <- int32-    case size of-      -1 -> failure "Unexpected null"-      _ -> sized (fromIntegral size) value--{-|-Extracts the number of affected rows from the body of the CommandComplete message.--}-{-# INLINE commandCompleteMessageAffectedRows #-}-commandCompleteMessageAffectedRows :: BinaryParser Int-commandCompleteMessageAffectedRows =-  do-    header <- bytesWhile byteIsUpperLetter-    byte-    case header of-      "INSERT" -> unitWhile byteIsDecimal *> byte *> asciiIntegral <* byte-      _ -> asciiIntegral <* byte-  where-    byteIsUpperLetter byte =-      byte - 65 <= 25-    byteIsDecimal byte =-      byte - 48 <= 9--{-|-The essential components of the error (or notice) message.--}-{-# INLINE errorMessage #-}-errorMessage :: (ByteString -> ByteString -> errorMessage) -> BinaryParser errorMessage-errorMessage errorMessage =-  do-    tupleFn <- loop id-    case tupleFn (Nothing, Nothing) of-      (Just v1, Just v2) -> return (errorMessage v1 v2)-      _ -> failure "Some of the error fields are missing"-  where-    loop state =-      (noticeField fieldState >>= id >>= loop) <|> pure state-      where-        fieldState =-          \case-            CodeNoticeFieldType -> \payload -> pure (state . (\(v1, v2) -> (Just payload, v2)))-            MessageNoticeFieldType -> \payload -> pure (state . (\(v1, v2) -> (v1, Just payload)))-            _ -> \_ -> pure state--{-# INLINE noticeField #-}-noticeField :: (NoticeFieldType -> ByteString -> a) -> BinaryParser a-noticeField cont =-  cont <$> noticeFieldType <*> nullTerminatedString--{-# INLINE noticeFieldType #-}-noticeFieldType :: BinaryParser NoticeFieldType-noticeFieldType =-  NoticeFieldType <$> word8--{-# INLINE nullTerminatedString #-}-nullTerminatedString :: BinaryParser ByteString-nullTerminatedString =-  bytesWhile (/= 0) <* byte--{-# INLINE protocolVersion #-}-protocolVersion :: BinaryParser (Word16, Word16)-protocolVersion =-  (,) <$> word16 <*> word16--{-# INLINE authenticationMessage #-}-authenticationMessage :: BinaryParser AuthenticationMessage-authenticationMessage =-  do-    method <- word32-    case method of-      0 -> return OkAuthenticationMessage-      3 -> return ClearTextPasswordAuthenticationMessage-      5 -> MD5PasswordAuthenticationMessage <$> remainders-      _ -> failure ("Unsupported authentication method: " <> (fromString . show) method)--{-# INLINE notificationMessage #-}-notificationMessage :: (Word32 -> ByteString -> ByteString -> result) -> BinaryParser result-notificationMessage cont =-  cont <$> word32 <*> nullTerminatedString <*> nullTerminatedString--{-# INLINE dataRowMessage #-}-dataRowMessage :: (Word16 -> BinaryParser a) -> BinaryParser a-dataRowMessage contentsParser =-  do-    amountOfColumns <- word16-    contentsParser amountOfColumns--{-# INLINE parseDataRow #-}-parseDataRow :: F.ParseDataRow a -> BinaryParser a-parseDataRow (F.ParseDataRow columnsAmount vectorFn) =-  do-    actualColumnsAmount <- fromIntegral <$> word16-    if actualColumnsAmount == columnsAmount-      then do-        bytesVector <- A.replicateM actualColumnsAmount sizedBytes-        either throwError return (vectorFn bytesVector 0)-      else throwError ("Invalid amount of columns: " <> (fromString . show) actualColumnsAmount <>-        ", expecting " <> (fromString . show) columnsAmount)--{-|-ParameterStatus (B)-Byte1('S')-Identifies the message as a run-time parameter status report.--Int32-Length of message contents in bytes, including self.--String-The name of the run-time parameter being reported.--String-The current value of the parameter.--}-{-# INLINE parameterStatusMessagePayloadKeyValue #-}-parameterStatusMessagePayloadKeyValue :: (ByteString -> ByteString -> a) -> BinaryParser a-parameterStatusMessagePayloadKeyValue cont =-  cont <$> nullTerminatedString <*> nullTerminatedString--{-|-Int16-The number of column values that follow (possibly zero).--Next, the following pair of fields appear for each column:--Int32-The length of the column value, in bytes (this count does not include itself). Can be zero. As a special case, -1 indicates a NULL column value. No value bytes follow in the NULL case.--Byten-The value of the column, in the format indicated by the associated format code. n is the above length.--}-vector :: BinaryParser element -> BinaryParser (Vector element)-vector element =-  do-    size <- fromIntegral <$> word16-    A.replicateM size element--{-|-Int32-The length of the column value, in bytes (this count does not include itself). Can be zero. As a special case, -1 indicates a NULL column value. No value bytes follow in the NULL case.--Byten-The value of the column, in the format indicated by the associated format code. n is the above length.--}-sizedBytes :: BinaryParser (Maybe ByteString)-sizedBytes =-  do-    size <- fromIntegral <$> word32-    if size == -1-      then return Nothing-      else Just <$> bytesOfSize size
+ library/Hasql/Core/Protocol/Parse/Primitives.hs view
@@ -0,0 +1,62 @@+module Hasql.Core.Protocol.Parse.Primitives where++import Hasql.Prelude hiding (fail)+import Hasql.Core.Model+import Ptr.Parse+++-- * Primitives+-------------------------++{-|+Int32+The length of the column value, in bytes (this count does not include itself). Can be zero. As a special case, -1 indicates a NULL column value. No value bytes follow in the NULL case.++Byten+The value of the column, in the format indicated by the associated format code. n is the above length.+-}+{-# INLINE sized #-}+sized :: Parse result -> Parse result -> Parse result+sized nullParse sizedParse =+  {-# SCC "sized" #-} +  do+    size <- fromIntegral <$> beWord32+    if size == -1+      then nullParse+      else sizedParse++{-|+Int32+The length of the column value, in bytes (this count does not include itself). Can be zero. As a special case, -1 indicates a NULL column value. No value bytes follow in the NULL case.++Byten+The value of the column, in the format indicated by the associated format code. n is the above length.+-}+{-# INLINE sizedBytes #-}+sizedBytes :: Parse (Maybe ByteString)+sizedBytes =+  {-# SCC "sizedBytes" #-} +  do+    size <- fromIntegral <$> beWord32+    if size == -1+      then return Nothing+      else do+        !bytes_ <- bytes size+        return (Just bytes_)+++-- * Components+-------------------------++{-# INLINE nullableDataRowColumn #-}+nullableDataRowColumn :: Parse column -> Parse (Maybe column)+nullableDataRowColumn parseColumn =+  {-# SCC "nullableDataRowColumn" #-} +  sized (return Nothing) (fmap Just parseColumn)++{-# INLINE nonNullDataRowColumn #-}+nonNullDataRowColumn :: Parse column -> Parse column+nonNullDataRowColumn parseColumn =+  {-# SCC "nonNullDataRowColumn" #-} +  sized (fail "Unexpected Null column value") parseColumn+
+ library/Hasql/Core/Protocol/Parse/Responses.hs view
@@ -0,0 +1,137 @@+module Hasql.Core.Protocol.Parse.Responses where++import Hasql.Prelude hiding (fail)+import Hasql.Core.Protocol.Parse.Primitives+import Hasql.Core.Model+import Ptr.Parse+import qualified Data.ByteString as B+import qualified Data.ByteString.Internal as A+import qualified Data.Vector as D+import qualified Hasql.Core.MessageTypePredicates as C+import qualified Hasql.Core.NoticeFieldTypes as E+import qualified Hasql.Core.ParseDataRow as F+++{-# INLINE responseBody #-}+responseBody :: Word8 -> Parse (Maybe Response)+responseBody type_ =+  {-# SCC "responseBody" #-} +  if+    | C.dataRow type_ -> (Just . DataRowResponse) <$> allBytes+    | C.commandComplete type_ -> Just . CommandCompleteResponse <$> commandCompleteBody+    | C.readyForQuery type_ -> fmap (Just . ReadyForQueryResponse) readyForQueryBody+    | C.parseComplete type_ -> pure (Just ParseCompleteResponse)+    | C.bindComplete type_ -> pure (Just BindCompleteResponse)+    | C.emptyQuery type_ -> pure (Just EmptyQueryResponse)+    | C.notification type_ -> Just <$> notificationBody NotificationResponse+    | C.error type_ -> Just <$> errorResponseBody ErrorResponse+    | C.authentication type_ -> fmap (Just . AuthenticationResponse) authenticationBody+    | C.parameterStatus type_ -> Just <$> parameterStatusBody ParameterStatusResponse+    | True -> pure Nothing++{-# INLINE unparsedFieldsOfDataRowBody #-}+unparsedFieldsOfDataRowBody :: Parse (Vector (Maybe ByteString))+unparsedFieldsOfDataRowBody =+  {-# SCC "unparsedFieldsOfDataRowBody" #-} +  do+    amountOfColumns <- beWord16+    D.replicateM (fromIntegral amountOfColumns) sizedBytes++{-# INLINE dataRowBody #-}+dataRowBody :: F.ParseDataRow row -> Parse row+dataRowBody (F.ParseDataRow rowLength parse) =+  do+    amountOfColumns <- beWord16+    if fromIntegral amountOfColumns == rowLength+      then parse+      else fail (fromString+        (showString "Invalid amount of columns: "+          (shows amountOfColumns+            (showString ", expecting "+              (show rowLength)))))++{-# INLINE commandCompleteBody #-}+commandCompleteBody :: Parse Int+commandCompleteBody =+  {-# SCC "commandCompleteBody" #-} +  do+    header <- bytesWhile byteIsUpperLetter+    word8+    case header of+      "INSERT" -> skipWhile byteIsDigit *> word8 *> unsignedASCIIIntegral <* word8+      _ -> unsignedASCIIIntegral <* word8+  where+    byteIsUpperLetter byte =+      byte - 65 <= 25+    byteIsDigit byte =+      byte - 48 <= 9++{-# INLINE readyForQueryBody #-}+readyForQueryBody :: Parse TransactionStatus+readyForQueryBody =+  {-# SCC "readyForQueryBody" #-} +  do+    statusByte <- word8+    case statusByte of+      73 -> return IdleTransactionStatus+      84 -> return ActiveTransactionStatus+      69 -> return FailedTransactionStatus+      _ -> fail ("Unexpected transaction status byte: " <> (fromString . show) statusByte)++{-# INLINE notificationBody #-}+notificationBody :: (Word32 -> ByteString -> ByteString -> result) -> Parse result+notificationBody result =+  {-# SCC "notificationBody" #-} +  result <$> beWord32 <*> nullTerminatedBytes <*> nullTerminatedBytes++{-# INLINE errorResponseBody #-}+errorResponseBody :: (ByteString -> ByteString -> result) -> Parse result+errorResponseBody result =+  {-# SCC "errorResponseBody" #-} +  iterate Nothing Nothing+  where+    iterate code message =+      element <|> end+      where+        element =+          join (noticeField (\type_ payload ->+            if+              | type_ == E.code -> iterate (Just payload) message+              | type_ == E.message -> iterate code (Just payload)+              | True -> iterate code message))+        end =+          do+            word8+            case code of+              Just code -> case message of+                Just message -> return (result code message)+                _ -> fail "The \"message\" field is missing"+              _ -> fail "The \"code\" field is missing"++{-# INLINE noticeField #-}+noticeField :: (Word8 -> ByteString -> result) -> Parse result+noticeField result =+  {-# SCC "noticeField" #-} +  result <$> word8 <*> nullTerminatedBytes++{-# INLINE authenticationBody #-}+authenticationBody :: Parse AuthenticationStatus+authenticationBody =+  {-# SCC "authenticationBody" #-} +  do+    status <- beWord32+    case status of+      0 -> return OkAuthenticationStatus+      3 -> return NeedClearTextPasswordAuthenticationStatus+      5 -> do+        salt <- bytes 4+        return (NeedMD5PasswordAuthenticationStatus salt)+      _ -> fail ("Unsupported authentication status: " <> (fromString . show) status)++{-# INLINE parameterStatusBody #-}+parameterStatusBody :: (ByteString -> ByteString -> result) -> Parse result+parameterStatusBody result =+  {-# SCC "parameterStatusBody" #-} +  result <$> nullTerminatedBytes <*> nullTerminatedBytes++
+ library/Hasql/Core/Protocol/Parse/Values.hs view
@@ -0,0 +1,51 @@+module Hasql.Core.Protocol.Parse.Values where++import Hasql.Prelude hiding (fail)+import Ptr.Parse+import Hasql.Core.Protocol.Parse.Primitives+++{-# INLINE int4 #-}+int4 :: Parse Int32+int4 =+  fmap fromIntegral beWord32++{-# INLINE int8 #-}+int8 :: Parse Int64+int8 =+  fmap fromIntegral beWord64++{-# INLINE float4 #-}+float4 :: Parse Float+float4 =+  unsafeCoerce beWord32++{-# INLINE float8 #-}+float8 :: Parse Double+float8 =+  unsafeCoerce beWord64++{-# INLINE bool #-}+bool :: Parse Bool+bool =+  fmap (== 1) word8++{-# INLINE text #-}+text :: Parse Text+text =+  $(todo "text")++{-# INLINE bytea #-}+bytea :: Parse ByteString+bytea =+  $(todo "bytea")++{-# INLINE intTimestamptz #-}+intTimestamptz :: Parse UTCTime+intTimestamptz =+  $(todo "intTimestamptz")++{-# INLINE floatTimestamptz #-}+floatTimestamptz :: Parse UTCTime+floatTimestamptz =+  $(todo "floatTimestamptz")
+ library/Hasql/Core/Protocol/Peek.hs view
@@ -0,0 +1,43 @@+module Hasql.Core.Protocol.Peek where++import Hasql.Prelude hiding (take)+import Hasql.Core.Model+import Ptr.Peek+import qualified Hasql.Core.Protocol.Parse.Responses as G+import qualified Ptr.Parse as F+import qualified Data.ByteString as B+import qualified Data.ByteString.Internal as A+import qualified Data.Vector as D+import qualified Hasql.Core.MessageTypePredicates as C+import qualified Hasql.Core.NoticeFieldTypes as E++++-- * Postgres Protocol-specific Primitives+-------------------------++{-# INLINE messageTypeAndLength #-}+messageTypeAndLength :: (Word8 -> Int -> a) -> Peek a+messageTypeAndLength cont =+  cont <$> word8 <*> payloadLength++{-# INLINE payloadLength #-}+payloadLength :: Peek Int+payloadLength =+  subtract 4 . fromIntegral <$> beWord32++{-# INLINE messageTypeAndPayload #-}+messageTypeAndPayload :: (Text -> a) -> (Word8 -> F.Parse a) -> Peek (Peek a)+messageTypeAndPayload error parse_ =+  messageTypeAndLength $ \ !messageType !length ->+  parse length (parse_ messageType) (\ _ -> error "Not enough data") error+++-- * Responses+-------------------------++{-# INLINE response #-}+response :: (Text -> x) -> (Maybe Response -> x) -> Peek (Peek x)+response error response =+  {-# SCC "response" #-} +  messageTypeAndPayload error (fmap response . G.responseBody)
library/Hasql/Core/Request.hs view
@@ -3,7 +3,6 @@ import Hasql.Prelude import Hasql.Core.Model import qualified ByteString.StrictBuilder as B-import qualified BinaryParser as D import qualified Hasql.Core.InterpretResponses as A import qualified Hasql.Core.Protocol.Encoding as K import qualified Hasql.Core.Protocol.Model as C
− library/Hasql/Core/Scanner.hs 
@@ -1,193 +0,0 @@-module Hasql.Core.Scanner where--import Hasql.Prelude-import Hasql.Core.Model-import Scanner (Scanner)-import qualified Scanner as A-import qualified Data.ByteString as B-import qualified Data.Vector as D-import qualified Hasql.Core.MessageTypePredicates as C-import qualified Hasql.Core.NoticeFieldTypes as E---{-# INLINE word8 #-}-word8 :: Scanner Word8-word8 =-  A.anyWord8--{-# INLINE word16 #-}-word16 :: Scanner Word16-word16 =-  numOfSize 2--{-# INLINE word32 #-}-word32 :: Scanner Word32-word32 =-  numOfSize 4--{-# INLINE word64 #-}-word64 :: Scanner Word64-word64 =-  numOfSize 8--{-# INLINE numOfSize #-}-numOfSize :: (Bits a, Num a) => Int -> Scanner a-numOfSize size =-  B.foldl' (\n h -> shiftL n 8 .|. fromIntegral h) 0 <$> A.take size--{-# INLINE int32 #-}-int32 :: Scanner Int32-int32 =-  fromIntegral <$> word32--{-# INLINE messageTypeAndLength #-}-messageTypeAndLength :: (Word8 -> Word32 -> a) -> Scanner a-messageTypeAndLength cont =-  cont <$> word8 <*> payloadLength--{-# INLINE payloadLength #-}-payloadLength :: (Integral a, Bits a) => Scanner a-payloadLength =-  subtract 4 <$> numOfSize 4--{-# INLINE messageTypeAndPayload #-}-messageTypeAndPayload :: (Word8 -> ByteString -> a) -> Scanner a-messageTypeAndPayload cont =-  cont <$> word8 <*> (payloadLength >>= A.take)---- |--- Integral number encoded in ASCII.-{-# INLINE asciiIntegral #-}-asciiIntegral :: Integral a => Scanner a-asciiIntegral =-  B.foldl' step 0 <$> A.takeWhile byteIsDigit-  where-    byteIsDigit byte =-      byte - 48 <= 9-    step !state !byte =-      state * 10 + fromIntegral byte - 48--{-# INLINE nullTerminatedString #-}-nullTerminatedString :: Scanner ByteString-nullTerminatedString =-  A.takeWhile (/= 0) <* A.anyWord8---- * Responses----------------------------{-# INLINE response #-}-response :: Scanner (Maybe Response)-response =-  do-    type_ <- word8-    bodyLength <- payloadLength-    if-      | C.dataRow type_ -> dataRowBody (Just . DataRowResponse)-      | C.commandComplete type_ -> commandCompleteBody (Just . CommandCompleteResponse)-      | C.readyForQuery type_ -> readyForQueryBody (Just . ReadyForQueryResponse)-      | C.parseComplete type_ -> pure (Just ParseCompleteResponse)-      | C.bindComplete type_ -> pure (Just BindCompleteResponse)-      | C.emptyQuery type_ -> pure (Just EmptyQueryResponse)-      | C.notification type_ -> Just <$> notificationBody NotificationResponse-      | C.error type_ -> Just <$> errorResponseBody bodyLength ErrorResponse-      | C.authentication type_ -> Just <$> authenticationBody AuthenticationResponse-      | C.parameterStatus type_ -> Just <$> parameterStatusBody ParameterStatusResponse-      | True -> A.take bodyLength $> Nothing--{-# INLINE dataRowBody #-}-dataRowBody :: (Vector (Maybe ByteString) -> result) -> Scanner result-dataRowBody result =-  do-    amountOfColumns <- word16-    bytesVector <- D.replicateM (fromIntegral amountOfColumns) sizedBytes-    return (result bytesVector)--{-# INLINE commandCompleteBody #-}-commandCompleteBody :: (Int -> result) -> Scanner result-commandCompleteBody result =-  do-    header <- A.takeWhile byteIsUpperLetter-    A.anyWord8-    count <- case header of-      "INSERT" -> A.skipWhile byteIsDigit *> A.anyWord8 *> asciiIntegral <* A.anyWord8-      _ -> asciiIntegral <* A.anyWord8-    return (result count)-  where-    byteIsUpperLetter byte =-      byte - 65 <= 25-    byteIsDigit byte =-      byte - 48 <= 9--{-# INLINE readyForQueryBody #-}-readyForQueryBody :: (TransactionStatus -> result) -> Scanner result-readyForQueryBody result =-  do-    statusByte <- A.anyWord8-    case statusByte of-      73 -> return (result IdleTransactionStatus)-      84 -> return (result ActiveTransactionStatus)-      69 -> return (result FailedTransactionStatus)-      _ -> fail (showString "Unexpected transaction status byte: " (show statusByte))--{-# INLINE notificationBody #-}-notificationBody :: (Word32 -> ByteString -> ByteString -> result) -> Scanner result-notificationBody result =-  result <$> word32 <*> nullTerminatedString <*> nullTerminatedString--{-# INLINE errorResponseBody #-}-errorResponseBody :: Int -> (ByteString -> ByteString -> result) -> Scanner result-errorResponseBody length result =-  do-    tuple <- iterate 0 Nothing Nothing-    A.anyWord8-    case tuple of-      (Just code, Just message) -> return (result code message)-      _ -> fail "Some of the required error fields are missing"-  where-    iterate !offset code message  =-      if offset < length - 1-        then join (noticeField (\type_ payload ->-          if-            | type_ == E.code -> iterate (offset + 2 + B.length payload) (Just payload) message-            | type_ == E.message -> iterate (offset + 2 + B.length payload) code (Just payload)-            | True -> iterate (offset + 2 + B.length payload) code message))-        else return (code, message)--{-# INLINE noticeField #-}-noticeField :: (Word8 -> ByteString -> result) -> Scanner result-noticeField result =-  result <$> word8 <*> nullTerminatedString--{-# INLINE authenticationBody #-}-authenticationBody :: (AuthenticationStatus -> result) -> Scanner result-authenticationBody result =-  do-    status <- word32-    case status of-      0 -> return (result OkAuthenticationStatus)-      3 -> return (result NeedClearTextPasswordAuthenticationStatus)-      5 -> do-        salt <- A.take 4-        return (result (NeedMD5PasswordAuthenticationStatus salt))-      _ -> fail ("Unsupported authentication status: " <> show status)--{-# INLINE parameterStatusBody #-}-parameterStatusBody :: (ByteString -> ByteString -> result) -> Scanner result-parameterStatusBody result =-  result <$> nullTerminatedString <*> nullTerminatedString--{-|-Int32-The length of the column value, in bytes (this count does not include itself). Can be zero. As a special case, -1 indicates a NULL column value. No value bytes follow in the NULL case.--Byten-The value of the column, in the format indicated by the associated format code. n is the above length.--}-{-# INLINE sizedBytes #-}-sizedBytes :: Scanner (Maybe ByteString)-sizedBytes =-  do-    size <- fromIntegral <$> word32-    if size == -1-      then return Nothing-      else Just <$> A.take size
library/Hasql/DecodePrimitive.hs view
@@ -2,6 +2,7 @@ (   DecodePrimitive,   bool,+  int4,   int8,   text,   bytea,
profiling/Main.hs view
@@ -18,11 +18,7 @@     connection <- connect     traceEventIO "START Session"     Right !result <- fmap force <$> A.session connection (session 50 10 100)-    Right !result <- fmap force <$> A.session connection (session 50 10 100)     Right !result <- fmap force <$> A.session connection (session 10 50 100)-    Right !result <- fmap force <$> A.session connection (session 50 10 100)-    Right !result <- fmap force <$> A.session connection (session 10 50 100)-    Right !result <- fmap force <$> A.session connection (session 10 50 100)     traceEventIO "STOP Session"     return () @@ -40,7 +36,7 @@ -- * Sessions ------------------------- -session :: Int -> Int -> Int -> F.Session [[[(Int64, Int64)]]]+session :: Int -> Int -> Int -> F.Session [[[(Int32, Int32)]]] session amountOfQueries amountOfStatements amountOfRows =   replicateM amountOfQueries (F.batch (replicateM amountOfStatements (manyRowsBatch amountOfRows (B.revList))))   where@@ -54,7 +50,7 @@ -- * Queries ------------------------- -manyRowsBatch :: Int -> (C.DecodeRow (Int64, Int64) -> B.DecodeResult result) -> J.Batch result+manyRowsBatch :: Int -> (C.DecodeRow (Int32, Int32) -> B.DecodeResult result) -> J.Batch result manyRowsBatch amountOfRows decodeResult =   J.statement (G.unprepared template conquer decode) ()   where@@ -62,7 +58,7 @@       "SELECT generate_series(0," <> fromString (show amountOfRows) <> ") as a, generate_series(10000," <> fromString (show (amountOfRows + 10000)) <> ") as b"     decode =       decodeResult $-      tuple <$> C.primitive D.int8 <*> C.primitive D.int8+      tuple <$> C.primitive D.int4 <*> C.primitive D.int4         where         tuple !a !b =           (a, b)
tests/Main.hs view
@@ -46,27 +46,27 @@         testGroup "Batch" $         [           test "select 1" (Right 1) $-          J.statement (E.prepared "select 1" conquer (B.head (C.primitive D.int8))) ()+          J.statement (E.prepared "select 1" conquer (B.head (C.primitive D.int4))) ()           ,           test "select '1' and select 'true'" (Right (1, True)) $           (,) <$>-          J.statement (E.prepared "select 1" conquer (B.head (C.primitive D.int8))) () <*>+          J.statement (E.prepared "select 1" conquer (B.head (C.primitive D.int4))) () <*>           J.statement (E.prepared "select 'true' :: bool" conquer (B.head (C.primitive D.bool))) ()           ,           test "Error" (Left (A.BackendError "42703" "column \"abc\" does not exist")) $-          J.statement (E.prepared "select abc" conquer (B.head (C.primitive D.int8))) ()+          J.statement (E.prepared "select abc" conquer (B.head (C.primitive D.int4))) ()           ,           test "Errors in multiple queries" (Left (A.BackendError "42703" "column \"abc\" does not exist")) $-          J.statement (E.unprepared "select 1" conquer (B.head (C.primitive D.int8))) () *>-          J.statement (E.unprepared "select abc" conquer (B.head (C.primitive D.int8))) () *>-          J.statement (E.unprepared "select abc" conquer (B.head (C.primitive D.int8))) ()+          J.statement (E.unprepared "select 1" conquer (B.head (C.primitive D.int4))) () *>+          J.statement (E.unprepared "select abc" conquer (B.head (C.primitive D.int4))) () *>+          J.statement (E.unprepared "select abc" conquer (B.head (C.primitive D.int4))) ()           ,           test "traverse" (Right [1,2,3]) $-          traverse (\template -> J.statement (E.prepared template conquer (B.head (C.primitive D.int8))) ()) $+          traverse (\template -> J.statement (E.prepared template conquer (B.head (C.primitive D.int4))) ()) $           ["select 1", "select 2", "select 3"]           ,           test "Not a single row" (Left (A.DecodingError "Empty query")) $-          J.statement (E.prepared "" conquer (B.head (C.primitive D.int8))) ()+          J.statement (E.prepared "" conquer (B.head (C.primitive D.int4))) ()           ,           testCaseInfo "Simultaneous result decoding and counting" $ pure "Pending"         ]