quic-simple (empty) → 0.1.0.0
raw patch · 8 files changed
+484/−0 lines, 8 filesdep +asyncdep +basedep +bytestring
Dependencies added: async, base, bytestring, crypton, crypton-x509, hourglass, iproute, memory, network, quic, quic-simple, serialise, stm, tls
Files
- CHANGELOG.md +11/−0
- LICENSE +26/−0
- README.md +15/−0
- quic-simple.cabal +79/−0
- src/Network/QUIC/Simple.hs +96/−0
- src/Network/QUIC/Simple/Credentials.hs +49/−0
- src/Network/QUIC/Simple/Stream.hs +74/−0
- test/Spec.hs +134/−0
+ CHANGELOG.md view
@@ -0,0 +1,11 @@+# Changelog for `quic-simple`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## Unreleased++## 0.1.0.0 - YYYY-MM-DD
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright 2025 IC Rainbow++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 copyright holder 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 HOLDER 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.
+ README.md view
@@ -0,0 +1,15 @@+# quic-simple++A set of wrappers for getting started with QUIC easier.++- `QUIC.runServer [("127.0.0.1", 14443)] \conn stream ->` -- start a generic server with random TLS credentials and auto-accept the first stream.+- `QUIC.runClient "127.0.0.1" "14443" \conn stream ->` -- start a generic client and request an initial stream.+- `(writeQ, readQ) <- QUIC.streamCodec encode decodeIncremental stream` -- convert a stream to a pair of queues.+- `(writeQ, readQ) <- QUIC.streamSerialise stream` -- run a CBOR codec over a stream.++An extra-simple pair of wrappers for QUIC and dirty RPC:++- `QUIC.runServerSimple "127.0.0.1" 14443 handleCall` -- start a CBOR server running `streamSerialise`.+- `(stop, call) <- QUIC.startClientSimple "127.0.0.1" "14443"` -- spawn a CBOR client running `streamSerialise`.++See [tests](./test/Spec.hs) for copypastable examples of different wrapping levels.
+ quic-simple.cabal view
@@ -0,0 +1,79 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.38.1.+--+-- see: https://github.com/sol/hpack++name: quic-simple+version: 0.1.0.0+synopsis: Quick-start wrappers for QUIC+category: Network+author: IC Rainbow+maintainer: aenor.realm@gmail.com+copyright: 2025 IC Rainbow+license: BSD-3-Clause+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://gitlab.com/dpwiz/quic-simple++library+ exposed-modules:+ Network.QUIC.Simple+ Network.QUIC.Simple.Credentials+ Network.QUIC.Simple.Stream+ other-modules:+ Paths_quic_simple+ autogen-modules:+ Paths_quic_simple+ hs-source-dirs:+ src+ default-extensions:+ BlockArguments+ ImportQualifiedPost+ LambdaCase+ OverloadedStrings+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+ build-depends:+ async+ , base >=4.7 && <5+ , bytestring+ , crypton+ , crypton-x509+ , hourglass+ , iproute+ , memory+ , network+ , quic+ , serialise+ , stm+ , tls+ default-language: GHC2021++test-suite quic-simple-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_quic_simple+ autogen-modules:+ Paths_quic_simple+ hs-source-dirs:+ test+ default-extensions:+ BlockArguments+ ImportQualifiedPost+ LambdaCase+ OverloadedStrings+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ async+ , base >=4.7 && <5+ , bytestring+ , quic-simple+ , stm+ default-language: GHC2021
+ src/Network/QUIC/Simple.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE CPP #-}++module Network.QUIC.Simple+ ( -- * Basic wrappers+ runServer+ , runClient+ -- * CBOR/Serialise wrappers+ , Serialise+ , runServerSimple+ , startClientSimple+ -- * The rest of the QUIC API+ , module Network.QUIC+ ) where++import Network.QUIC+import Network.QUIC.Simple.Stream++import Control.Monad (forever)+import Control.Concurrent (forkIO, killThread)+import Control.Concurrent.STM (atomically, readTBQueue, writeTBQueue, newTBQueueIO)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Codec.Serialise (Serialise)+import Data.IP (IP(..))+import Network.QUIC.Client (ClientConfig(..), defaultClientConfig)+import Network.QUIC.Client qualified as Client+import Network.QUIC.Server (ServerConfig(..), defaultServerConfig)+import Network.QUIC.Server qualified as Server+import Network.QUIC.Simple.Credentials (genCredentials)+import Network.Socket (HostName, PortNumber, ServiceName)++runServer :: [(IP, PortNumber)] -> (Connection -> Stream -> IO ()) -> IO ()+runServer scAddresses action = do+ scCredentials <- genCredentials+ let+ sc = defaultServerConfig+ { scCredentials+ , scAddresses+ }+ Server.run sc \conn -> do+ defaultStream <- acceptStream conn+ action conn defaultStream++runServerSimple+ :: (Serialise q, Serialise r)+ => IP+ -> PortNumber+ -> (q -> IO r)+ -> IO ()+runServerSimple host port action =+ runServer [(host, port)] \_conn stream0 -> do+ (writeQ, readQ) <- streamSerialise stream0+ forever do+ query <- atomically (readTBQueue readQ)+ reply <- action query+ atomically $ writeTBQueue writeQ reply++runClient :: HostName -> ServiceName -> (Connection -> Stream -> IO ()) -> IO ()+runClient ccServerName ccPortName action = do+ Client.run cc \conn -> do+ defaultStream <- stream conn+ action conn defaultStream+ where+ cc = defaultClientConfig+ { ccServerName+ , ccPortName+ , ccValidate = False+#if MIN_VERSION_quic(0,2,10)+ , ccSockConnected = True+ , ccWatchDog = True+#endif+ }++startClientSimple+ :: (Serialise q, Serialise r)+ => HostName+ -> ServiceName+ -> IO (IO (), q -> IO r)+startClientSimple host port = do+ client <- newEmptyMVar+ tid <- forkIO $ runClient host port \_conn stream0 -> do+ requests <- newTBQueueIO 16+ putMVar client requests+ (writeQ, readQ) <- streamSerialise stream0+ forever do+ (query, handler) <- atomically $ readTBQueue requests+ atomically $ writeTBQueue writeQ query+ reply <- atomically $ readTBQueue readQ+ handler reply+ requests <- takeMVar client+ pure+ ( killThread tid+ , \query -> do+ reply <- newEmptyMVar+ atomically $ writeTBQueue requests (query, putMVar reply)+ takeMVar reply+ )
+ src/Network/QUIC/Simple/Credentials.hs view
@@ -0,0 +1,49 @@+module Network.QUIC.Simple.Credentials+ ( genCredentials+ ) where++import Crypto.PubKey.Ed25519 qualified as Ed25519+import Data.ByteArray qualified as Memory+import Data.Hourglass (Hours(..), timeAdd)+import Data.X509 qualified as X509+import Network.TLS qualified as TLS+import Time.System qualified as Hourglass++genCredentials :: IO TLS.Credentials+genCredentials = do+ secret <- Ed25519.generateSecretKey+ let public = Ed25519.toPublic secret++ today <- Hourglass.dateCurrent+ let+ validity =+ ( timeAdd today (-25 :: Hours)+ , timeAdd today (365 * 24 :: Hours)+ )++ let+ certificate = X509.Certificate+ { X509.certVersion = 1+ , X509.certSerial = 1+ , X509.certSignatureAlg = X509.SignatureALG_IntrinsicHash X509.PubKeyALG_Ed25519+ , X509.certIssuerDN = mempty+ , X509.certValidity = validity+ , X509.certSubjectDN = mempty+ , X509.certPubKey = X509.PubKeyEd25519 public+ , X509.certExtensions = X509.Extensions Nothing+ }+ (signed, ()) =+ X509.objectToSignedExact+ ( \bytes ->+ ( Memory.convert $ Ed25519.sign secret public bytes+ , X509.SignatureALG_IntrinsicHash X509.PubKeyALG_Ed25519+ , ()+ )+ )+ certificate+ pure $+ TLS.Credentials+ [ ( X509.CertificateChain [signed]+ , X509.PrivKeyEd25519 secret+ )+ ]
+ src/Network/QUIC/Simple/Stream.hs view
@@ -0,0 +1,74 @@+module Network.QUIC.Simple.Stream+ ( MessageQueues+ , streamSerialise+ , streamCodec+ ) where++import Codec.Serialise (Serialise, serialise, deserialiseIncremental)+import Codec.Serialise qualified as IDecode (IDecode(..))+import Control.Concurrent (forkIO)+import Control.Concurrent.Async (race_)+import Control.Concurrent.STM+import Control.Exception (throwIO)+import Control.Monad.ST (stToIO)+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as BSL+import Data.IORef+import Network.QUIC qualified as QUIC++type MessageQueues sendMsg recvMsg = (TBQueue sendMsg, TBQueue recvMsg)++streamSerialise+ :: forall sendMsg recvMsg+ . (Serialise sendMsg, Serialise recvMsg)+ => QUIC.Stream+ -> IO (MessageQueues sendMsg recvMsg)+streamSerialise stream = do+ initial <- stToIO $ deserialiseIncremental @recvMsg+ state <- newIORef initial+ let+ decode starting chunk = do+ decoder <- readIORef state+ case decoder of+ IDecode.Fail _leftovers _offset err ->+ throwIO err -- crash writer (thus the stream, and the reader/writer etc)+ IDecode.Done leftovers _consumed msg -> do+ stToIO deserialiseIncremental >>= writeIORef state -- restart decoder+ pure (leftovers, Just msg)+ IDecode.Partial consume -> do+ -- want more data (initial state?)+ stToIO (consume $ Just chunk) >>= writeIORef state -- step decoder+ if starting then+ -- re-check if done+ decode False ""+ else+ -- suspend and wait for next chunk+ pure ("", Nothing)+ streamCodec serialise (decode True) stream++streamCodec+ :: (sendMsg -> BSL.ByteString)+ -> (BS.ByteString -> IO (BS.ByteString, Maybe recvMsg))+ -> QUIC.Stream+ -> IO (MessageQueues sendMsg recvMsg)+streamCodec encode decode stream = do+ readQ <- newTBQueueIO 1024+ writeQ <- newTBQueueIO 1024+ _tid <- forkIO $ race_ (reader "" readQ) (writer writeQ)+ pure (writeQ, readQ)+ where+ reader leftovers readQ = do+ chunk <-+ if BS.null leftovers then+ QUIC.recvStream stream 4096+ else+ pure leftovers+ (leftovers', message_) <- decode chunk+ mapM_ (atomically . writeTBQueue readQ) message_+ reader leftovers' readQ++ writer writeQ = do+ message <- atomically $ readTBQueue writeQ+ let chunks = BSL.toChunks $ encode message+ QUIC.sendStreamMany stream chunks+ writer writeQ
+ test/Spec.hs view
@@ -0,0 +1,134 @@+module Main (main) where++import Control.Concurrent.Async (race_)+import Control.Concurrent.STM (atomically, readTBQueue, writeTBQueue)+import Control.Monad (forever, replicateM_)+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as BSL+import Data.IORef (newIORef, atomicModifyIORef')+import GHC.Generics (Generic)+import Network.QUIC.Simple qualified as QUIC+import Network.QUIC.Simple.Stream (MessageQueues, streamCodec, streamSerialise)+import System.Timeout (timeout)++main :: IO ()+main = do+ putStrLn "Raw"+ race_ serverRaw clientRaw+ putStrLn ""++ putStrLn "Mailbox"+ race_ serverBox clientBox+ putStrLn ""++ putStrLn "Serialise"+ race_ serverSerialise clientSerialise+ putStrLn ""++ putStrLn "Simple"+ race_ serverSimple clientSimple+ putStrLn ""++serverRaw :: IO ()+serverRaw = QUIC.runServer [("127.0.0.1", 14443)] \conn stream -> do+ putStrLn "Server accepted connection:"+ QUIC.getConnectionInfo conn >>= print++ query <- QUIC.recvStream stream 4096+ putStrLn $ "Server got query: " <> show query+ QUIC.sendStream stream $ "got yer bytes: " <> query+ _ <- QUIC.recvStream stream 4096+ putStrLn "Server quits"++clientRaw :: IO ()+clientRaw = QUIC.runClient "127.0.0.1" "14443" \conn stream -> do+ putStrLn "Client connected:"+ QUIC.getConnectionInfo conn >>= print++ QUIC.sendStream stream "hi there"+ reply <- QUIC.recvStream stream 4096+ putStrLn $ "Client got reply: " <> show reply+ QUIC.closeStream stream+ putStrLn "Client quits"++serverBox :: IO ()+serverBox = QUIC.runServer [("127.0.0.1", 14443)] \_conn stream -> do+ putStrLn "Server accepted connection:"+ (writeQ, readQ) <- dummyCodec stream+ forever do+ query <- atomically $ readTBQueue readQ+ putStrLn $ "Server got query: " <> show query+ atomically $ writeTBQueue writeQ $ "got yer bytes: " <> BSL.fromStrict query++clientBox :: IO ()+clientBox = do+ QUIC.runClient "127.0.0.1" "14443" \_conn stream -> do+ (writeQ, readQ) <- dummyCodec stream+ atomically $ writeTBQueue writeQ "hi there"+ reply <- atomically $ readTBQueue readQ+ putStrLn $ "Client got reply: " <> show reply++dummyCodec :: QUIC.Stream -> IO (MessageQueues BSL.ByteString BS.ByteString)+dummyCodec = streamCodec id (\chunk -> pure ("", Just chunk))++data ClientMessage+ = Hello+ | Bye+ deriving (Eq, Show, Ord, Generic)++instance QUIC.Serialise ClientMessage++data ServerMessage+ = Ok Int+ deriving (Eq, Show, Ord, Generic)++instance QUIC.Serialise ServerMessage++serverSerialise :: IO ()+serverSerialise = QUIC.runServer [("127.0.0.1", 14443)] \_conn stream -> do+ putStrLn "Server accepted connection:"+ (writeQ, readQ) <- streamSerialise stream+ let+ loop counter = do+ query <- atomically (readTBQueue readQ)+ putStrLn $ "Server got query: " <> show query+ case query of+ Hello -> do+ atomically $ writeTBQueue writeQ (Ok counter)+ loop (counter + 1)+ Bye ->+ pure ()+ loop 0++clientSerialise :: IO ()+clientSerialise = do+ QUIC.runClient "127.0.0.1" "14443" \_conn stream -> do+ (writeQ, readQ) <- streamSerialise stream+ replicateM_ 5 do+ atomically $ writeTBQueue writeQ Hello+ reply <- atomically $ readTBQueue @ServerMessage readQ+ putStrLn $ "Client got reply: " <> show reply+ atomically $ writeTBQueue writeQ Bye++serverSimple :: IO ()+serverSimple = do+ counter <- newIORef 0+ QUIC.runServerSimple "127.0.0.1" 14443 \case+ Hello -> do+ putStrLn "Server got Hello"+ n <- atomicModifyIORef' counter \old -> (old + 1, old)+ pure $ Ok n+ Bye -> do+ putStrLn "Server got Bye"+ error "Whelp, the serverSimple must reply, but the protocol must stop. Needs a re-design."++clientSimple :: IO ()+clientSimple = do+ (stop, call) <- QUIC.startClientSimple "127.0.0.1" "14443"+ replicateM_ 5 do+ Ok n <- call Hello+ putStrLn $ "Client got reply " <> show n+ timeout 1000000 (call Bye) >>= mapM_ \reply ->+ putStrLn $ "Shouldn't happen, the server errors out on this: " <> show reply+ putStrLn "Stopping"+ stop