diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ See also http://pvp.haskell.org/faq +### 0.1.4.0 + +* New module `Network.Http.Client.WebSocket` providing basic RFC6455 support. +* New function 'inputStreamBodyChunked' supporting breaking up over-sized chunks. + ### 0.1.3.0 * New functions `receiveUpgradeResponse`, 'receiveConnectResponse', and `unsafeWithRawStreams` for accessing full-duplex low-level streams (e.g. for upgrading to Websockets protocol diff --git a/LICENCE b/LICENCE deleted file mode 100644 --- a/LICENCE +++ /dev/null @@ -1,32 +0,0 @@ -An HTTP client for use with io-streams - -Copyright © 2012-2018 Operational Dynamics Consulting, Pty Ltd and Others -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: - - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - 2. Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - 3. Neither the name of the project nor the names of its contributors - may be used to endorse or promote products derived from this - software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,51 @@ +SPDX-License-Identifier: GPL-2.0-or-later AND BSD-3-Clause + +Copyright © 2020 Herbert Valerio Riedel + + This library is free software: you may copy, redistribute and/or modify it + under the terms of the GNU General Public License as published by the + Free Software Foundation, either version 2 of the License, or (at your + option) any later version. + + This library is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program (see `LICENSE.GPLv2`). If not, see + . + +This library incorporates work covered by the following copyright and +permission notice: + + Copyright © 2012-2018 Operational Dynamics Consulting, Pty Ltd and Others + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + 3. Neither the name of the project nor the names of its contributors + may be used to endorse or promote products derived from this + software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/LICENSE.GPLv2 b/LICENSE.GPLv2 new file mode 100644 --- /dev/null +++ b/LICENSE.GPLv2 @@ -0,0 +1,339 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Lesser General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. diff --git a/http-io-streams.cabal b/http-io-streams.cabal --- a/http-io-streams.cabal +++ b/http-io-streams.cabal @@ -1,24 +1,18 @@ cabal-version: 2.2 name: http-io-streams -version: 0.1.3.0 +version: 0.1.4.0 -synopsis: HTTP client based on io-streams +synopsis: HTTP and WebSocket client based on io-streams description: - An HTTP client, using the Snap Framework's [io-streams](https://hackage.haskell.org/package/io-streams) library to + An HTTP client with WebSocket (RFC 6455) support, using the Snap Framework's [io-streams](https://hackage.haskell.org/package/io-streams) library to handle the streaming IO. The @http-io-streams@ API designed for ease of use when querying web services and dealing with the result as streaming I/O. . - The library is exported in a single module; see "Network.Http.Client" - for full documentation. + The main HTTP/1.1 part of the library is exported in a single module "Network.Http.Client"; the WebSocket specific functionality is available from the "Network.Http.Client.WebSocket" module. . - __NOTE__: This is a fork of [http-streams](http://hackage.haskell.org/package/http-streams) - with a lighter dependency footprint which focuses on core HTTP - functionality and as a consequence doesn't include out-of-the-box - support for handling JSON data. If you need support for handling JSON - web-services, you should use the original @http-streams@ package instead of - this package. + __NOTE__: This package originally started as a fork of [http-streams](http://hackage.haskell.org/package/http-streams) with a lighter dependency footprint focusing on core HTTP functionality. -license: BSD-3-Clause -license-file: LICENCE +license: BSD-3-Clause AND GPL-2.0-or-later +license-files: LICENSE LICENSE.GPLv2 author: Andrew Cowie , Herbert Valerio Riedel maintainer: Herbert Valerio Riedel @@ -36,6 +30,11 @@ default: True description: Build with support for () compression algorithm for . +flag fast-xor + manual: True + default: True + description: Enable use of faster and more efficient @XOR@ routines. + common settings build-depends: , base >= 4.5 && < 4.15 @@ -56,6 +55,13 @@ library import: settings + -- xor + if flag(fast-xor) + build-depends: xor ^>= 0.0.1.0 + else + hs-source-dirs: xor/lib + other-modules: Data.XOR + -- http-streams if flag(brotli) build-depends: @@ -64,6 +70,8 @@ build-depends: , HsOpenSSL ^>= 0.11.2 , attoparsec ^>= 0.13.2.2 + , binary ^>= 0.7.1 || ^>= 0.8.3 + , cryptohash-sha1 ^>= 0.11.100 , directory ^>= 1.2.0.1 || ^>= 1.3.0.0 , io-streams ^>= 1.5.0.1 , network ^>= 2.6.0.0 || ^>= 2.7.0.0 || ^>= 2.8.0.0 || ^>= 3.0.0.0 || ^>= 3.1.0.0 @@ -75,6 +83,7 @@ hs-source-dirs: http-streams/lib exposed-modules: Network.Http.Client + Network.Http.Client.WebSocket other-modules: Network.Http.Connection Network.Http.ResponseParser @@ -82,7 +91,6 @@ Network.Http.Inconvenience -- http-common - build-depends: , base64-bytestring ^>= 1.1.0.0 , mtl ^>= 2.2.2 diff --git a/http-streams/lib/Network/Http/Client.hs b/http-streams/lib/Network/Http/Client.hs --- a/http-streams/lib/Network/Http/Client.hs +++ b/http-streams/lib/Network/Http/Client.hs @@ -128,6 +128,7 @@ utf8LazyTextBody, fileBody, inputStreamBody, + inputStreamBodyChunked, encodedFormBody, -- * Processing HTTP response diff --git a/http-streams/lib/Network/Http/Client/WebSocket.hs b/http-streams/lib/Network/Http/Client/WebSocket.hs new file mode 100644 --- /dev/null +++ b/http-streams/lib/Network/Http/Client/WebSocket.hs @@ -0,0 +1,621 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{-# OPTIONS_GHC -Wall #-} +-- | +-- Copyright: © 2020 Herbert Valerio Riedel +-- SPDX-License-Identifier: GPL-2.0-or-later +-- +-- Basic WebSocket support. +-- +-- @since 0.1.4.0 +module Network.Http.Client.WebSocket + ( -- * WebSocket Frames + -- ** WebSocket Frame Header + WSFrameHdr(..) + , wsFrameHdrSize + , wsFrameHdrToBuilder + + , WSOpcode(..) + , WSOpcodeReserved(..) + , wsIsDataFrame + + -- ** Mid-level I/O primitives + + -- *** Sending WebSocket frames + , writeWSFrame + , sendWSFragData + + -- *** Receiving WebSocket frames +-- , readWSFrameHdr + , readWSFrame + , receiveWSFrame + + -- * WebSocket handshake + + -- ** HTTP/1.1 WebSocket connection upgrade + + , wsUpgradeConnection + + -- ** Low-level primitives for WebSocket handshake + , SecWebSocketKey + , wsKeyToAcceptB64 + + , secWebSocketKeyFromB64 + , secWebSocketKeyToB64 + , secWebSocketKeyFromWords + + -- * Exception + , WsException(..) + ) where + +import Blaze.ByteString.Builder (Builder) +import qualified Blaze.ByteString.Builder as Builder +import Control.Exception +import Control.Monad (unless, when) +import qualified Crypto.Hash.SHA1 as SHA1 +import qualified Data.Binary as Bin +import qualified Data.Binary.Get as Bin +import qualified Data.Binary.Put as Bin +import Data.Bits +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Lazy as BL +import qualified Data.CaseInsensitive as CI +import Data.IORef +import Data.Maybe (isJust) +import Data.Monoid (Monoid (..)) +import Data.Typeable (Typeable) +import Data.Word +import Data.XOR (xor32LazyByteString, xor32StrictByteString') +import Network.Http.Client as HC +import qualified Network.Http.Connection as HC +import System.IO.Streams (InputStream, OutputStream) +import qualified System.IO.Streams as Streams + +-- | Exception type thrown by WebSocket routines. +-- +-- These exceptions mostly denote WebSocket protocol violations from either side, client and server. +-- +-- @since 0.1.4.0 +data WsException = WsException String + deriving (Typeable,Show) + +instance Exception WsException + +-- | WebSocket Frame as per +-- +-- +-- > 0 1 2 3 +-- > 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 +-- > +-+-+-+-+-------+-+-------------+-------------------------------+ +-- > |F|R|R|R| opcode|M| Payload len | Extended payload length | +-- > |I|S|S|S| (4) |A| (7) | (16/64) | +-- > |N|V|V|V| |S| | (if payload len==126/127) | +-- > | |1|2|3| |K| | | +-- > +-+-+-+-+-------+-+-------------+ - - - - - - - - - - - - - - - + +-- > | Extended payload length continued, if payload len == 127 | +-- > + - - - - - - - - - - - - - - - +-------------------------------+ +-- > | |Masking-key, if MASK set to 1 | +-- > +-------------------------------+-------------------------------+ +-- > | Masking-key (continued) | Payload Data | +-- > +-------------------------------- - - - - - - - - - - - - - - - + +-- > : Payload Data continued ... : +-- > + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +-- > | Payload Data continued ... | +-- > +---------------------------------------------------------------+ +-- +-- @since 0.1.4.0 +data WSFrameHdr = WSFrameHdr + { ws'FIN :: !Bool -- ^ MUST be set for control-frames (control-frames MUST NOT be fragmented). + , ws'RSV1 :: !Bool + , ws'RSV2 :: !Bool + , ws'RSV3 :: !Bool + , ws'opcode :: !WSOpcode -- see 'WSOpcode' + , ws'length :: !Word64 -- ^ MUST be smaller than 2^63 for data-frames; + -- MUST be smaller than 126 for control-frames. + , ws'mask :: !(Maybe Word32) + -- ^ Whether the frame is masked and which masking key is used; + -- 'Nothing' denotes unmasked frames. + -- + -- A client MUST mask all frames that it sends to the server; A + -- server MUST NOT mask any frames that it sends to the client. + } deriving Show + +-- | Size of serialized WebSocket frame header (i.e. without payload data) in octets. +-- +-- @since 0.1.4.0 +wsFrameHdrSize :: WSFrameHdr -> Int +wsFrameHdrSize WSFrameHdr{ws'mask = Nothing, ws'length} + | ws'length < 126 = 2 + | ws'length <= 0xffff = 4 + | otherwise = 10 +wsFrameHdrSize WSFrameHdr{ws'mask = Just _, ws'length} + | ws'length < 126 = 6 + | ws'length <= 0xffff = 8 + | otherwise = 14 + +-- not exported yet +-- | Try reading a 'WSFrameHdr' from the 'InputStream'. +-- +-- Returns 'Nothing' is EOF is encountered before any WebSocket header byte is read +readWSFrameHdr :: Connection -> IO (Maybe WSFrameHdr) +readWSFrameHdr (HC.Connection { cIn = is }) = do + mchunk <- Streams.read is + case mchunk of + Nothing -> return Nothing + Just chunk -> go $ (if BS.null chunk then id else flip Bin.pushChunk chunk) + $ Bin.runGetIncremental Bin.get + where + go :: Bin.Decoder WSFrameHdr -> IO (Maybe WSFrameHdr) + go (Bin.Fail rest _ err) = do + unless (BS.null rest) $ + Streams.unRead rest is + throwIO $ WsException ("readWSFrameHdr: " ++ err) + go partial@(Bin.Partial cont) = do + mchunk <- Streams.read is + case mchunk of + Nothing -> go (cont Nothing) -- eof, will likely trigger failure + Just chunk + | BS.null chunk -> go partial -- loop + | otherwise -> go (cont (Just chunk)) + go (Bin.Done rest _ x) = do + unless (BS.null rest) $ + Streams.unRead rest is + return (Just x) + +-- | Receive a single WebSocket frame as 'InputStream'. +-- +-- This operation does not perform any defragmentation nor automatically deal with control-frames (those will be returned to the caller as-is). +-- +-- See also 'readWSFrame' for a simple non-streaming version. +-- +-- @since 0.1.4.0 +receiveWSFrame :: Connection -> (WSFrameHdr -> InputStream ByteString -> IO a) -> IO (Maybe a) +receiveWSFrame (conn@HC.Connection { cIn = is }) cont = do + mhdr <- readWSFrameHdr conn + case mhdr of + Nothing -> return Nothing + Just hdr + | ws'length hdr == 0 -> do + is' <- Streams.nullInput + Just `fmap` cont hdr is' + | otherwise -> do + is' <- Streams.takeExactly (fromIntegral (ws'length hdr)) is + is'' <- xor32InputStream (maybe 0 id (ws'mask hdr)) is' + res <- cont hdr is'' + Streams.skipToEof is' + return $! Just $! res + +-- | Send WebSocket message as fragmented data-frames. +-- +-- This function can be used if the size of the data payload to be sent is not known in advance. +-- +-- This operation does not flush automatically after every chunk; write an empty chunk to the 'OutputStream' to trigger flushing pending data onto the WebSocket connection. +-- +-- The 'ws'length' and 'ws'FIN' fields are ignored and computed from the chunks to be sent. +-- +-- Pre-conditions: +-- +-- - This function does not support sending control-frames as those MUST NOT be fragmented. +-- - 'ws'opcode' MUST NOT be 'WSOpcode'Continuation' +-- +-- @since 0.1.4.0 +sendWSFragData :: Connection -> WSFrameHdr -> (OutputStream ByteString -> IO a) -> IO a +sendWSFragData _ hdr0 _ + | not (wsIsDataFrame (ws'opcode hdr0)) + = throwIO (WsException "sendWSFragData: sending control-frame requested") + | ws'opcode hdr0 == WSOpcode'Continuation + = throwIO (WsException "sendWSFragData: sending continuation frame requested") +sendWSFragData (HC.Connection { cOut = os }) hdr0 cont = do + opcodeRef <- newIORef (ws'opcode hdr0) + let go Nothing = return () + go (Just chunk) + | BS.null chunk = Streams.write (Just Builder.flush) os + | otherwise = do + let (_,chunk') = xor32StrictByteString' (maybe 0 id $ ws'mask hdr0) chunk + opcode <- readIORef opcodeRef + writeIORef opcodeRef WSOpcode'Continuation + let fraghdr = hdr0 { ws'FIN = False + , ws'length = fromIntegral (BS.length chunk) + , ws'opcode = opcode + } + Streams.write (Just $! wsFrameHdrToBuilder fraghdr `mappend` Builder.fromByteString chunk') os + + os' <- Streams.makeOutputStream go + !res <- cont os' + + -- send FINal frame + opcode <- readIORef opcodeRef + let final = (hdr0 { ws'FIN = True + , ws'length = 0 + , ws'opcode = opcode + , ws'mask = Just 0 + }) + Streams.write (Just $ wsFrameHdrToBuilder final `mappend` Builder.flush) os + + return $! res + +-- | Convenience function for writing simple non-fragmented frames to an established WebSocket connection. +-- +-- Control-frames MUST have a payload smaller than 126 bytes. +-- +-- @since 0.1.4.0 +writeWSFrame :: Connection -> WSOpcode -> Maybe Word32 -> BL.ByteString -> IO () +writeWSFrame (HC.Connection { cOut = os }) opcode mmask payload = do + when (not (wsIsDataFrame opcode) && plen >= 126) $ + throwIO (WsException "writeWSFrame: over-sized control-frame") + + let hdr = wsFrameHdrToBuilder (WSFrameHdr True False False False opcode plen mmask) + dat = case mmask of + Nothing -> Builder.fromLazyByteString payload + Just 0 -> Builder.fromLazyByteString payload + Just msk -> Builder.fromLazyByteString (xor32LazyByteString msk payload) + Streams.write (Just $ hdr `mappend` dat `mappend` Builder.flush) os + where + plen = fromIntegral (BL.length payload) + +-- | Convenience function for reading a single (possibly fragmented) frame from an established WebSocket connection. +-- +-- The first argument is the maximum expected frame size to receive; if a larger frame is encountered an exception is raised. +-- +-- This operation does not perform any defragmentation nor automatically deal with control-frames (those will be returned to the caller as-is). +-- +-- Returns 'Nothing' if the 'InputStream' is terminated before reading the first octet. +-- +-- @since 0.1.4.0 +readWSFrame :: Int -> Connection -> IO (Maybe (WSFrameHdr,ByteString)) +readWSFrame maxSize (conn@HC.Connection { cIn = is }) = do + mhdr <- readWSFrameHdr conn + case mhdr of + Nothing -> return Nothing + Just hdr + | ws'length hdr == 0 -> + return $ Just (hdr,BS.empty) + | ws'length hdr >= fromIntegral maxSize -> + throwIO (WsException "readWSFrame: frame larger than maxSize") + | otherwise -> do + dat <- Streams.readExactly (fromIntegral (ws'length hdr)) is + let dat' = case ws'mask hdr of + Nothing -> dat + Just 0 -> dat + Just m -> snd (xor32StrictByteString' m dat) + return $ Just (hdr,dat') + +-- | Serialize 'WSFrameHdr' to 'BB.Builder' +-- +-- @since 0.1.4.0 +wsFrameHdrToBuilder :: WSFrameHdr -> Builder +wsFrameHdrToBuilder WSFrameHdr{..} = mconcat + [ Builder.fromWord8 $! + (if ws'FIN then 0x80 else 0) .|. + (if ws'RSV1 then 0x40 else 0) .|. + (if ws'RSV2 then 0x20 else 0) .|. + (if ws'RSV3 then 0x10 else 0) .|. + (encodeWSOpcode ws'opcode) + + , Builder.fromWord8 $! + (if isJust ws'mask then 0x80 else 0) .|. len7 + + -- extended payload length + , case len7 of + 126 -> Builder.fromWord16be (fromIntegral ws'length) + 127 -> Builder.fromWord64be ws'length + _ -> Data.Monoid.mempty + + , maybe mempty Builder.fromWord32be ws'mask + ] + where + len7 | ws'length < 126 = fromIntegral ws'length + | ws'length <= 0xffff = 126 -- 16bit + | otherwise = 127 -- 64bit + +instance Bin.Binary WSFrameHdr where + -- put :: WSFrameHdr -> Bin.Put + put WSFrameHdr{..} = do + Bin.putWord8 $! + (if ws'FIN then 0x80 else 0) .|. + (if ws'RSV1 then 0x40 else 0) .|. + (if ws'RSV2 then 0x20 else 0) .|. + (if ws'RSV3 then 0x10 else 0) .|. + (encodeWSOpcode ws'opcode) + + Bin.putWord8 $! + (if isJust ws'mask then 0x80 else 0) .|. len7 + + -- extended payload length + case len7 of + 126 -> Bin.putWord16be (fromIntegral ws'length) + 127 -> Bin.putWord64be ws'length + _ -> return () + + maybe (return ()) Bin.putWord32be ws'mask + where + len7 | ws'length < 126 = fromIntegral ws'length + | ws'length <= 0xffff = 126 -- 16bit + | otherwise = 127 -- 64bit + + ---------------------------------------------------------------------------- + + -- get :: Bin.Get WSFrameHdr + get = do + o0 <- Bin.getWord8 + + let ws'FIN = testBit o0 7 + ws'RSV1 = testBit o0 6 + ws'RSV2 = testBit o0 5 + ws'RSV3 = testBit o0 4 + ws'opcode = decodeWSOpcode o0 + + when (not ws'FIN && not (wsIsDataFrame ws'opcode)) $ + fail "invalid fragmented control-frame" + + o1 <- Bin.getWord8 + + let len7 = o1 .&. 0x7f + msk = o1 >= 0x80 + + ws'length <- case len7 of + 127 -> do + unless (wsIsDataFrame ws'opcode) $ fail "invalid 64-bit extended length (control-frame)" + v <- Bin.getWord64be + unless (v > 0xffff) $ fail "invalid 64-bit extended length (<= 0xffff)" + unless (v < 0x8000000000000000) $ fail "invalid 64-bit extended length (MSB set)" + return v + 126 -> do + unless (wsIsDataFrame ws'opcode) $ fail "invalid 16-bit extended length (control-frame)" + v <- Bin.getWord16be + unless (v > 125) $ fail "invalid 16-bit extended length (<= 0x7d)" + return (fromIntegral v) + _ -> return (fromIntegral len7) + + ws'mask <- if msk + then Just `fmap` Bin.getWord32be + else return Nothing + + return WSFrameHdr{..} + +-- | WebSocket frame opcode. +-- +-- See also 'wsIsDataFrame'. +-- +-- @since 0.1.4.0 +data WSOpcode + = WSOpcode'Continuation -- ^ /data/ fragmented data-frame + | WSOpcode'Text -- ^ /data/ payload must utf-8 encoded + | WSOpcode'Binary -- ^ /data/ binary data payload + | WSOpcode'Close -- ^ /control/ connection close frame (optional payload with reason-code) + | WSOpcode'Ping -- ^ /control/ PING frame + | WSOpcode'Pong -- ^ /control/ PONG frame + | WSOpcode'Reserved !WSOpcodeReserved -- ^ reserved frame kind not defined by RFC 6455 + deriving (Eq,Show) + +-- | WebSocket frame opcodes reserved for future use by RFC 6455 +-- +-- @since 0.1.4.0 +data WSOpcodeReserved + = WSOpcode'Reserved3 + | WSOpcode'Reserved4 + | WSOpcode'Reserved5 + | WSOpcode'Reserved6 + | WSOpcode'Reserved7 + | WSOpcode'Reserved11 + | WSOpcode'Reserved12 + | WSOpcode'Reserved13 + | WSOpcode'Reserved14 + | WSOpcode'Reserved15 + deriving (Eq,Show) + +-- | Whether 'WSOpcode' denotes a data-frame. +-- +-- There are two kinds of WebSocket frames, data-frames and +-- control-frames. Consequently, this predicate is 'False' for +-- control-frames. +-- +-- @since 0.1.4.0 +wsIsDataFrame :: WSOpcode -> Bool +wsIsDataFrame x = case x of + WSOpcode'Continuation -> True + WSOpcode'Text -> True + WSOpcode'Binary -> True + + WSOpcode'Reserved WSOpcode'Reserved3 -> True + WSOpcode'Reserved WSOpcode'Reserved4 -> True + WSOpcode'Reserved WSOpcode'Reserved5 -> True + WSOpcode'Reserved WSOpcode'Reserved6 -> True + WSOpcode'Reserved WSOpcode'Reserved7 -> True + + WSOpcode'Close -> False + WSOpcode'Ping -> False + WSOpcode'Pong -> False + + WSOpcode'Reserved WSOpcode'Reserved11 -> False + WSOpcode'Reserved WSOpcode'Reserved12 -> False + WSOpcode'Reserved WSOpcode'Reserved13 -> False + WSOpcode'Reserved WSOpcode'Reserved14 -> False + WSOpcode'Reserved WSOpcode'Reserved15 -> False + + +-- NB: ignores high nibble +decodeWSOpcode :: Word8 -> WSOpcode +decodeWSOpcode x = case x .&. 0xf of + 0x0 -> WSOpcode'Continuation + 0x1 -> WSOpcode'Text + 0x2 -> WSOpcode'Binary + + 0x3 -> WSOpcode'Reserved WSOpcode'Reserved3 + 0x4 -> WSOpcode'Reserved WSOpcode'Reserved4 + 0x5 -> WSOpcode'Reserved WSOpcode'Reserved5 + 0x6 -> WSOpcode'Reserved WSOpcode'Reserved6 + 0x7 -> WSOpcode'Reserved WSOpcode'Reserved7 + + 0x8 -> WSOpcode'Close + 0x9 -> WSOpcode'Ping + 0xA -> WSOpcode'Pong + + 0xB -> WSOpcode'Reserved WSOpcode'Reserved11 + 0xC -> WSOpcode'Reserved WSOpcode'Reserved12 + 0xD -> WSOpcode'Reserved WSOpcode'Reserved13 + 0xE -> WSOpcode'Reserved WSOpcode'Reserved14 + 0xF -> WSOpcode'Reserved WSOpcode'Reserved15 + + _ -> undefined -- impossible + +-- internal +encodeWSOpcode :: WSOpcode -> Word8 +encodeWSOpcode x = case x of + WSOpcode'Continuation -> 0x0 + WSOpcode'Text -> 0x1 + WSOpcode'Binary -> 0x2 + + WSOpcode'Reserved WSOpcode'Reserved3 -> 0x3 + WSOpcode'Reserved WSOpcode'Reserved4 -> 0x4 + WSOpcode'Reserved WSOpcode'Reserved5 -> 0x5 + WSOpcode'Reserved WSOpcode'Reserved6 -> 0x6 + WSOpcode'Reserved WSOpcode'Reserved7 -> 0x7 + + WSOpcode'Close -> 0x8 + WSOpcode'Ping -> 0x9 + WSOpcode'Pong -> 0xA + + WSOpcode'Reserved WSOpcode'Reserved11 -> 0xB + WSOpcode'Reserved WSOpcode'Reserved12 -> 0xC + WSOpcode'Reserved WSOpcode'Reserved13 -> 0xD + WSOpcode'Reserved WSOpcode'Reserved14 -> 0xE + WSOpcode'Reserved WSOpcode'Reserved15 -> 0xF + +-- | Compute @Sec-WebSocket-Accept@ header value from @Sec-WebSocket-Key@ header value according to RFC 6455 +-- +-- >>> wsKeyToAcceptB64 <$> secWebSocketKeyFromB64 "dGhlIHNhbXBsZSBub25jZQ==" +-- Just "s3pPLMBiTxaQ9kYGzzhZRbK+xOo=" +-- +-- @since 0.1.4.0 +wsKeyToAcceptB64 :: SecWebSocketKey -> ByteString +wsKeyToAcceptB64 key = B64.encode (SHA1.hash (secWebSocketKeyToB64 key `BS.append` rfc6455Guid)) + where + rfc6455Guid :: ByteString + rfc6455Guid = "258EAFA5-E914-47DA-95CA-C5AB0DC85B11" + +-- | @Sec-WebSocket-Key@ header value according to RFC 6455 +-- +-- @since 0.1.4.0 +newtype SecWebSocketKey = WSKey ByteString deriving (Eq,Ord,Show) + +-- | Construct 'SecWebSocketKey' from its HTTP header base64 representation. +-- +-- The input must be a valid @Sec-WebSocket-Key@ value, i.e. a @base64@ encoded 16-octet value (i.e. 24 base64 characters) with optional surrounding whitespace (@TAB@ or @SPC@) characters or this function will return 'Nothing'. +-- +-- @since 0.1.4.0 +secWebSocketKeyFromB64 :: ByteString -> Maybe SecWebSocketKey +secWebSocketKeyFromB64 key + | BS.length key' /= 24 = Nothing -- invalid base64 or wrong length + | Left _ <- B64.decode key' = Nothing -- invalid base64 + | otherwise = Just $! WSKey key' + where + -- strip leading/trailing OWS from key + key' = fst (BS.spanEnd isOWS (BS.dropWhile isOWS key)) + + -- optional whitespace + isOWS :: Word8 -> Bool + isOWS 0x09 = True + isOWS 0x20 = True + isOWS _ = False + +-- | Emit 'SecWebSocketKey' as base64-encoded value suitable for use in the @Sec-WebSocket-Accept@ HTTP header. +-- +-- @since 0.1.4.0 +secWebSocketKeyToB64 :: SecWebSocketKey -> ByteString +secWebSocketKeyToB64 (WSKey bs) = bs + +-- | Construct 'SecWebSocketKey' from two 'Word64' values. +-- +-- @since 0.1.4.0 +secWebSocketKeyFromWords :: Word64 -> Word64 -> SecWebSocketKey +secWebSocketKeyFromWords h l = WSKey (B64.encode key) + where + key = BS.concat $ BL.toChunks $ Bin.runPut (Bin.putWord64be h >> Bin.putWord64be l) + +-- upgradeToWebSockets :: HC.Connection +-- -> (Response -> InputStream ByteString -> IO a) -- ^ Non-code @101@ response handler +-- -> (Response -> InputStream ByteString -> OutputStream Builder -> IO a) -- ^ Code @101@ response handler +-- -> IO a +-- upgradeToWebSockets = do +-- + +xor32InputStream :: Word32 -> InputStream ByteString -> IO (InputStream ByteString) +xor32InputStream 0 is = return is +xor32InputStream msk0 is = do + mskref <- newIORef msk0 + let go = do + mchunk <- Streams.read is + case mchunk of + Nothing -> return Nothing + Just chunk -> do + msk <- readIORef mskref + let (msk',chunk') = xor32StrictByteString' msk chunk + writeIORef mskref msk' + return $! Just $! chunk' + Streams.makeInputStream go + +-- xor32OutputStream :: Word32 -> OutputStream ByteString -> IO (OutputStream ByteString) +-- xor32OutputStream msk0 os = do +-- mskref <- newIORef msk0 +-- let go Nothing = Streams.write Nothing os +-- go (Just chunk) = do +-- msk <- readIORef mskref +-- let (msk',chunk') = xor32StrictByteString' msk chunk +-- writeIORef mskref msk' +-- Streams.write (Just $! chunk') os +-- Streams.makeOutputStream go + +---------------------------------------------------------------------------- + +-- | Perform an opening WebSocket handshake as per +-- +-- This operation sets the @host@, @upgrade@, @connection@, @sec-websocket-version@, @sec-websocket-key@ HTTP headers; if you need to customize the handshake request further use the 'BuildRequest'-modifier argument to inject more headers into the request. +-- +-- @since 0.1.4.0 +wsUpgradeConnection :: Connection -- ^ Connection in HTTP/1.1 protocol state (i.e. not yet upgraded) + -> ByteString -- ^ resource name (i.e. the argument to the @GET@ verb) + -> RequestBuilder α -- ^ Additional Handshake request builder operations (i.e. to add additional HTTP headers to Handshake HTTP request) + -> SecWebSocketKey -- ^ The @sec-websocket-key@ value to use + -> (Response -> InputStream ByteString -> IO b) -- ^ failure continuation if handshake fails with a non-101 response code + -> (Response -> Connection -> IO b) -- ^ success continuation; the 'Connection' has been succesfully upgraded to WebSocket mode and only WebSocket operations shall be performed over this 'Connection'. + -> IO b +wsUpgradeConnection conn resource rqmod wskey failedToUpgrade success = do + let rqToWS = HC.buildRequest1 $ do + HC.http HC.GET resource + HC.setHeader "upgrade" "websocket" + HC.setHeader "connection" "Upgrade" + HC.setHeader "sec-websocket-version" "13" + HC.setHeader "sec-websocket-key" (secWebSocketKeyToB64 wskey) + rqmod + + HC.sendRequest conn rqToWS HC.emptyBody + + HC.receiveUpgradeResponse conn failedToUpgrade $ \resp _is _os -> do + + case CI.mk `fmap` HC.getHeader resp "connection" of + Nothing -> abort "missing 'connection' header" + Just "upgrade" -> return () + Just _ -> abort "'connection' header has non-'upgrade' value" + + case CI.mk `fmap` HC.getHeader resp "upgrade" of + Nothing -> abort "missing 'upgrade' header" + Just "websocket" -> return () + Just _ -> abort "'upgrade' header has non-'websocket' value" + + case HC.getHeader resp "sec-websocket-accept" of + Nothing -> abort "missing 'sec-websocket-accept' header" + Just wsacc + | wsacc /= wsKeyToAcceptB64 wskey -> abort "sec-websocket-accept header mismatch" + | otherwise -> return () -- pass + + success resp conn + where + abort msg = throwIO (WsException ("wsUpgradeConnection: "++msg)) + diff --git a/http-streams/lib/Network/Http/Connection.hs b/http-streams/lib/Network/Http/Connection.hs --- a/http-streams/lib/Network/Http/Connection.hs +++ b/http-streams/lib/Network/Http/Connection.hs @@ -43,6 +43,7 @@ utf8TextBody, utf8LazyTextBody, inputStreamBody, + inputStreamBodyChunked, debugHandler, concatHandler ) where @@ -667,6 +668,7 @@ -- This function maps "Builder.fromByteString" over the input, which will -- be efficient if the ByteString chunks are large. -- +-- See also 'inputStreamBodyChunked'. {- Note that this has to be 'supply' and not 'connect' as we do not want the end of stream to prematurely terminate the chunked encoding @@ -677,6 +679,38 @@ i2 <- Streams.map Builder.fromByteString i1 Streams.supply i2 o +-- | Variant of 'inputStreamBody' which enforces a maximum chunk-size. +-- +-- This is useful to deal with some HTTP server implementation which +-- impose maximum chunk-size for @chunked-transfer@ encoded request +-- bodies. +-- +-- When called with a negative or @0@ chunk-size argument this +-- function is equivalent to 'inputStreamBody', i.e. over sized chunks +-- from the 'InputStream' are not broken up. +-- +-- @since 0.1.4.0 +inputStreamBodyChunked :: Int -> InputStream ByteString -> OutputStream Builder -> IO () +inputStreamBodyChunked maxChunkSize i o + | maxChunkSize > 0 = go + | otherwise = inputStreamBody i o + where + go = do + mchunk <- Streams.read i + case mchunk of + Nothing -> return () -- don't pass on EOF signal + Just chunk + | chunkLen <= maxChunkSize -> do + Streams.write (Just $! Builder.fromByteString chunk) o + go + | otherwise -> do + let (chunk1,rest) | chunkLen < 2*maxChunkSize = S.splitAt (chunkLen `quot` 2) chunk + | otherwise = S.splitAt maxChunkSize chunk + Streams.unRead rest i + Streams.write (Just $! Builder.fromByteString chunk1) o + go + where + chunkLen = S.length chunk -- -- | Print the response headers and response body to @stdout@. You can diff --git a/xor/lib/Data/XOR.hs b/xor/lib/Data/XOR.hs new file mode 100644 --- /dev/null +++ b/xor/lib/Data/XOR.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE Trustworthy #-} + +-- | +-- Copyright: © 2020 Herbert Valerio Riedel +-- SPDX-License-Identifier: GPL-2.0-or-later +-- +-- Compat-layer providing (slow) fallbacks when compiled w/o +-- https://hackage.haskell.org/package/xor +-- +module Data.XOR + ( xor32StrictByteString' + , xor32LazyByteString + ) where + +import Data.Bits (rotateL, xor) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Internal as BL (ByteString (..)) +import Data.Word (Word32, Word8) + +xor32StrictByteString' :: Word32 -> ByteString -> (Word32,ByteString) +xor32StrictByteString' 0 = (,) 0 +xor32StrictByteString' msk0 = BS.mapAccumL go msk0 + where + go :: Word32 -> Word8 -> (Word32,Word8) + go msk b = let b' = fromIntegral msk' `xor` b + msk' = rotateL msk 8 + in b' `seq` (msk',b') + +xor32LazyByteString :: Word32 -> BL.ByteString -> BL.ByteString +xor32LazyByteString 0 = id +xor32LazyByteString msk0 = go msk0 + where + go _ BL.Empty = BL.Empty + go msk (BL.Chunk x xs) = BL.Chunk x' (go msk' xs) + where + (msk',x') = xor32StrictByteString' msk x