box-socket 0.4.1 → 0.5.0.0
raw patch · 12 files changed
+778/−440 lines, 12 filesdep +optparse-applicativedep +profunctorsdep −exceptionsdep −networkdep −optparse-genericdep ~asyncdep ~basedep ~box
Dependencies added: optparse-applicative, profunctors
Dependencies removed: exceptions, network, optparse-generic
Dependency ranges changed: async, base, box, bytestring, network-simple, text, websockets
Files
- ChangeLog.md +8/−0
- LICENSE +30/−0
- app/box-socket.hs +43/−18
- box-socket.cabal +120/−47
- readme.org +34/−0
- src/Box/Socket.hs +0/−176
- src/Box/Socket/Example.hs +0/−75
- src/Box/Socket/Types.hs +17/−0
- src/Box/TCP.hs +111/−124
- src/Box/TCP/Example.hs +88/−0
- src/Box/Websocket.hs +238/−0
- src/Box/Websocket/Example.hs +89/−0
+ ChangeLog.md view
@@ -0,0 +1,8 @@+0.5+===+* complete refactor++* aligned TCP api with Websockets++* Action & Codensity-based API surface+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2017, Tony Day++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of Tony Day nor the names of other+ 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.
app/box-socket.hs view
@@ -1,10 +1,8 @@ {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wall #-} {-@@ -15,29 +13,56 @@ module Main where -import Box.Socket.Example-import Options.Generic--data SocketType = Client | Responder | TestRun deriving (Eq, Read, Show, Generic)+import Box.TCP.Example as TCP+import Box.Websocket.Example as Websocket+import Options.Applicative -instance ParseField SocketType+boxSocketOpts :: ParserInfo Opts+boxSocketOpts =+ info+ (boxSocketOptions <**> helper)+ (fullDesc <> progDesc "box-socket tests" <> header "examples of box socket usage") -instance ParseRecord SocketType+data SocketType = TCPSocket | WebSocket deriving (Eq, Read, Show) -instance ParseFields SocketType+data ExampleType = ClientIO | ServerIO | EchoExample | SenderExample deriving (Eq, Read, Show) -newtype Opts w = Opts- { apptype :: w ::: SocketType <?> "type of websocket app"+data Opts = Opts+ { socketType :: SocketType,+ exampleType :: ExampleType }- deriving (Generic)+ deriving (Eq, Show) -instance ParseRecord (Opts Wrapped)+boxSocketOptions :: Parser Opts+boxSocketOptions =+ Opts+ <$> parseSocketType+ <*> parseExampleType +parseSocketType :: Parser SocketType+parseSocketType =+ flag' WebSocket (long "websocket" <> help "websocket socket")+ <|> flag' TCPSocket (long "tcp" <> help "tcp socket")+ <|> pure WebSocket++parseExampleType :: Parser ExampleType+parseExampleType =+ flag' ClientIO (long "clientio" <> help "client socket")+ <|> flag' ServerIO (long "serverio" <> help "server socket")+ <|> flag' EchoExample (long "echo" <> help "responder example")+ <|> flag' SenderExample (long "sender" <> help "sender example")+ <|> pure EchoExample+ main :: IO () main = do- o :: Opts Unwrapped <- unwrapRecord "example websocket apps"- r :: String <- case apptype o of- Client -> show <$> clientIO- Responder -> show <$> q' serverIO- TestRun -> show <$> testRun+ o <- execParser boxSocketOpts+ r <- case (socketType o, exampleType o) of+ (WebSocket, ClientIO) -> show <$> Websocket.clientIO+ (WebSocket, ServerIO) -> show <$> Websocket.serverIO+ (WebSocket, SenderExample) -> show <$> Websocket.senderExample ["hi", "bye"]+ (WebSocket, EchoExample) -> show <$> Websocket.echoExample ["hi", "bye"]+ (TCPSocket, ClientIO) -> show <$> TCP.clientIO+ (TCPSocket, ServerIO) -> show <$> TCP.serverIO+ (TCPSocket, SenderExample) -> show <$> TCP.senderExample ["hi", "bye"]+ (TCPSocket, EchoExample) -> show <$> TCP.echoExample ["hi", "bye"] putStrLn r
box-socket.cabal view
@@ -1,55 +1,128 @@-cabal-version: 2.4-name: box-socket-version: 0.4.1-synopsis: Box websockets-description: Websockets built with the box library.-category: project-author: Tony Day-maintainer: tonyday567@gmail.com-copyright: Tony Day (c) AfterTimes-license: BSD-3-Clause-homepage: https://github.com/tonyday567/box-socket#readme-bug-reports: https://github.com/tonyday567/box-socket/issues-build-type: Simple+cabal-version: 3.0+name: box-socket+version: 0.5.0.0+license: BSD-3-Clause+license-file: LICENSE+copyright: Tony Day (c) 2017+category: web+author: Tony Day+maintainer: tonyday567@gmail.com+homepage: https://github.com/tonyday567/box-socket#readme+bug-reports: https://github.com/tonyday567/box-socket/issues+synopsis: Box websockets+description: Websockets built with the box library.+build-type: Simple tested-with:- GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.2.5 || ==9.4.4+ GHC ==8.10.7 || ==9.4.7 || ==9.6.3 || ==9.8.1+extra-doc-files:+ ChangeLog.md+ readme.org source-repository head- type: git- location: https://github.com/tonyday567/box-socket+ type: git+ location: https://github.com/tonyday567/box-socket -library- exposed-modules:- Box.Socket- Box.Socket.Example- Box.TCP+common ghc-options-exe-stanza+ ghc-options:+ -fforce-recomp+ -funbox-strict-fields+ -rtsopts+ -threaded+ -with-rtsopts=-N - hs-source-dirs: src- build-depends:- , async ^>=2.2.3- , base >=4.12 && <5- , box >=0.9- , bytestring >=0.10 && <0.12- , exceptions ^>=0.10- , network ^>=3.1- , network-simple ^>=0.4- , text >=1.2.4 && < 2.1- , websockets ^>=0.12+common ghc-options-stanza+ ghc-options:+ -Wall+ -Wcompat+ -Widentities+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Wpartial-fields+ -Wredundant-constraints - default-language: Haskell2010- ghc-options:- -Wall -Wcompat -Wincomplete-record-updates- -Wincomplete-uni-patterns -Wredundant-constraints+common ghc2021-stanza+ if impl ( ghc >= 9.2 )+ default-language: GHC2021 -executable box-socket- main-is: box-socket.hs- hs-source-dirs: app- build-depends:- , base >=4.7 && <5- , box-socket- , optparse-generic >=1.3 && <1.5+ if impl ( ghc < 9.2 )+ default-language: Haskell2010+ default-extensions:+ BangPatterns+ BinaryLiterals+ ConstrainedClassMethods+ ConstraintKinds+ DeriveDataTypeable+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveLift+ DeriveTraversable+ DoAndIfThenElse+ EmptyCase+ EmptyDataDecls+ EmptyDataDeriving+ ExistentialQuantification+ ExplicitForAll+ FlexibleContexts+ FlexibleInstances+ ForeignFunctionInterface+ GADTSyntax+ GeneralisedNewtypeDeriving+ HexFloatLiterals+ ImplicitPrelude+ InstanceSigs+ KindSignatures+ MonomorphismRestriction+ MultiParamTypeClasses+ NamedFieldPuns+ NamedWildCards+ NumericUnderscores+ PatternGuards+ PolyKinds+ PostfixOperators+ RankNTypes+ RelaxedPolyRec+ ScopedTypeVariables+ StandaloneDeriving+ StarIsType+ TraditionalRecordSyntax+ TupleSections+ TypeApplications+ TypeOperators+ TypeSynonymInstances - default-language: Haskell2010- ghc-options:- -funbox-strict-fields -fforce-recomp -threaded -rtsopts- -with-rtsopts=-N+ if impl ( ghc < 9.2 ) && impl ( ghc >= 8.10 )+ default-extensions:+ ImportQualifiedPost+ StandaloneKindSignatures++library+ import: ghc-options-stanza+ import: ghc2021-stanza+ hs-source-dirs: src+ build-depends:+ , async >=2.2.3 && <2.3+ , base >=4.8 && <5+ , box >=0.9.3 && <0.10+ , bytestring >=0.11.3 && <0.13+ , network-simple >=0.4 && <0.5+ , profunctors >=5.6 && <5.7+ , text >=1.2 && <2.2+ , websockets >=0.12 && <0.13+ exposed-modules:+ Box.Socket.Types+ Box.TCP+ Box.TCP.Example+ Box.Websocket+ Box.Websocket.Example++executable box-socket+ import: ghc-options-exe-stanza+ import: ghc-options-stanza+ import: ghc2021-stanza+ main-is: box-socket.hs+ hs-source-dirs: app+ build-depends:+ , base >=4.7 && <5+ , box-socket+ , optparse-applicative >=0.17 && <0.19
+ readme.org view
@@ -0,0 +1,34 @@+#+TITLE: box-socket++[[https://hackage.haskell.org/package/box][file:https://img.shields.io/hackage/v/box-socket.svg]] [[https://github.com/tonyday567/box/actions?query=workflow%3Ahaskell-ci][file:https://github.com/tonyday567/box-socket/workflows/haskell-ci/badge.svg]]++Socket API based on the box library, with websockets and TCP support.++* Usage++#+begin_src haskell-ng+:set -XOverloadedStrings+import Box+import Box.Socket.Types+import Box.Websocket+#+end_src++IO client:++#+begin_src haskell-ng :results output+clientBox defaultSocketConfig (CloseAfter 0) (stdBox "q")+#+end_src++IO server:++#+begin_src haskell-ng :results output+serverBox defaultSocketConfig (CloseAfter 0) (stdBox "q")+#+end_src++See examples in Box.Websocket.Example and Box.TCP.Example for a variety of usage.++* Design++- The API attempts to be similar for TCP and Websocket++- A Codensity, continuation passing style is encouraged, similar to the box library.
− src/Box/Socket.hs
@@ -1,176 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE StrictData #-}-{-# OPTIONS_GHC -Wall #-}---- | Websocket components built with 'Box'es.-module Box.Socket- ( SocketConfig (..),- defaultSocketConfig,- runClient,- runServer,- connect,- clientApp,- responderApp,- serverApp,- receiver',- receiver,- sender,- responder,- )-where--import Box-import Control.Concurrent.Async-import Control.Monad-import Control.Monad.Catch-import qualified Data.ByteString as BS-import Data.Text (Text, pack, unpack)-import GHC.Generics-import qualified Network.WebSockets as WS---- | Socket configuration------ >>> defaultSocketConfig--- SocketConfig {host = "127.0.0.1", port = 9160, path = "/"}-data SocketConfig = SocketConfig- { host :: Text,- port :: Int,- path :: Text- }- deriving (Show, Eq, Generic)---- | official default-defaultSocketConfig :: SocketConfig-defaultSocketConfig = SocketConfig "127.0.0.1" 9160 "/"---- | Run a client app.-runClient :: SocketConfig -> WS.ClientApp () -> IO ()-runClient c app = WS.runClient (unpack $ host c) (port c) (unpack $ path c) app---- | Run a server app.-runServer :: SocketConfig -> WS.ServerApp -> IO ()-runServer c app = WS.runServer (unpack $ host c) (port c) app---- | Connection continuation.-connect :: WS.PendingConnection -> Codensity IO WS.Connection-connect p = Codensity $ \action ->- bracket- (WS.acceptRequest p)- (\conn -> WS.sendClose conn ("Bye from connect!" :: Text))- ( \conn ->- withAsync- (forever $ WS.sendPing conn ("ping" :: BS.ByteString) >> sleep 30)- (\_ -> action conn)- )---- | A simple client app for a box with Left debug messages.-clientApp ::- Box IO (Either Text Text) Text ->- WS.Connection ->- IO ()-clientApp (Box c e) conn =- void $- race- (receiver' c conn)- (sender (Box mempty e) conn)---- | Canned response function.-responderApp ::- (Text -> Either Text Text) ->- WS.PendingConnection ->- IO ()-responderApp f p = process (responder f mempty) (connect p)---- | Standard server app for a box.-serverApp ::- Box IO Text Text ->- WS.PendingConnection ->- IO ()-serverApp (Box c e) p =- void $- process- ( \conn ->- race- (receiver c conn)- (sender (Box mempty e) conn)- )- (connect p)---- | default websocket receiver with messages--- Lefts are info/debug-receiver' ::- Committer IO (Either Text Text) ->- WS.Connection ->- IO Bool-receiver' c conn = go- where- go = do- msg <- WS.receive conn- case msg of- WS.ControlMessage (WS.Close w b) ->- commit- c- ( Left- ( "receiver: received: close: " <> (pack . show) w <> " " <> (pack . show) b- )- )- WS.ControlMessage _ -> go- WS.DataMessage _ _ _ msg' -> do- _ <- commit c $ Left $ "receiver: received: " <> (WS.fromDataMessage msg' :: Text)- _ <- commit c (Right (WS.fromDataMessage msg'))- go---- | Receiver that only commits.-receiver ::- Committer IO Text ->- WS.Connection ->- IO ()-receiver c conn = go- where- go = do- msg <- WS.receive conn- case msg of- WS.ControlMessage (WS.Close _ _) -> pure ()- WS.ControlMessage _ -> go- WS.DataMessage _ _ _ msg' -> commit c (WS.fromDataMessage msg') >> go---- | Sender that only emits.-sender ::- (WS.WebSocketsData a, Show a) =>- Box IO Text a ->- WS.Connection ->- IO ()-sender (Box c e) conn = forever $ do- msg <- emit e- case msg of- Nothing -> pure ()- Just msg' -> do- _ <- commit c $ "sender: sending: " <> ((pack . show) msg' :: Text)- WS.sendTextData conn msg'---- | A receiver that responds based on received Text.--- lefts are quit signals. Rights are response text.-responder ::- (Text -> Either Text Text) ->- Committer IO Text ->- WS.Connection ->- IO ()-responder f c conn = go- where- go = do- msg <- WS.receive conn- case msg of- WS.ControlMessage (WS.Close _ _) -> do- _ <- commit c "responder: normal close"- WS.sendClose conn ("received close signal: responder closed." :: Text)- WS.ControlMessage _ -> go- WS.DataMessage _ _ _ msg' -> do- case f $ WS.fromDataMessage msg' of- Left _ -> do- _ <- commit c "responder: sender initiated close"- WS.sendClose conn ("received close signal: responder closed." :: Text)- Right r -> do- _ <- commit c ("responder: sending" <> r)- WS.sendTextData conn r- go
− src/Box/Socket/Example.hs
@@ -1,75 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -Wall #-}--{---It's a box. It's a socket. It's an example.---}--module Box.Socket.Example where--import Box-import Box.Socket-import Control.Concurrent.Async-import Data.Bool-import Data.Functor.Contravariant-import Data.Text (Text, pack)--serverIO :: IO ()-serverIO =- runServer- defaultSocketConfig- (responderApp (\x -> bool (Right $ "echo:" <> x) (Left "quit") (x == "q")))--clientIO :: IO ()-clientIO =- (runClient defaultSocketConfig . clientApp)- (Box (contramap (pack . show) toStdout) fromStdin)--q' :: IO a -> IO (Either () a)-q' f = race (cancelQ fromStdin) f--cancelQ :: Emitter IO Text -> IO ()-cancelQ e = do- e' <- emit e- case e' of- Just "q" -> pure ()- _notQ -> do- putStrLn "nothing happens"- cancelQ e---- | test of clientApp via a cRef committer and a canned list of Text-tClient :: [Text] -> IO [Either Text Text]-tClient xs = do- (c, r) <- refCommitter- runClient- defaultSocketConfig- ( \conn ->- (\b -> clientApp b conn) <$|>- ( Box c- <$> qList (xs <> ["q"])- )- )- r--tClientIO :: [Text] -> IO ()-tClientIO xs =- (runClient defaultSocketConfig . clientApp) <$|>- (Box (contramap (pack . show) toStdout) <$> qList (xs <> ["q"]))---- | main test run of client-server functionality--- the code starts a server in a thread, starts the client in the main thread, and cancels the server on completion.--- > testRun--- [Left "receiver: received: echo:1",Right "echo:1",Left "receiver: received: echo:2",Right "echo:2",Left "receiver: received: echo:3",Right "echo:3",Left "receiver: received: close: 1000 \"received close signal: responder closed.\""]-testRun :: IO [Either Text Text]-testRun = do- a <- async (runServer defaultSocketConfig (responderApp (\x -> bool (Right $ "echo:" <> x) (Left "quit") (x == "q"))))- sleep 0.1- r <- tClient (pack . show <$> [1 .. 3 :: Int])- cancel a- pure r
+ src/Box/Socket/Types.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeFamilies #-}++-- | Abstract sockets connected to 'Box'es.+module Box.Socket.Types+ ( PostSend (..),+ SocketStatus (..),+ )+where++import GHC.Generics (Generic)++-- | Whether to stay open after an emitter ends or send a close after a delay in seconds.+data PostSend = StayOpen | CloseAfter Double deriving (Generic, Eq, Show)++-- | Whether a socket remains open or closed after an action finishes.+data SocketStatus = SocketOpen | SocketClosed | SocketBroken deriving (Generic, Eq, Show)
src/Box/TCP.hs view
@@ -1,160 +1,147 @@-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE StrictData #-}-{-# OPTIONS_GHC -Wall #-} -- | TCP Boxes. module Box.TCP ( TCPConfig (..), defaultTCPConfig,- Env (..),- new,- close,- tcpEmitter,- tcpCommitter,- tcpBox,- tcpServer,- tcpResponder,- tcpSender,- tcpStdClient,- testHarness,- testResponder,- testServerSender,+ TCPEnv (..),+ Socket,+ connect,+ serve,+ receiver,+ sender,+ duplex,+ clientBox,+ clientCoBox,+ serverBox,+ serverCoBox,+ responseServer, ) where -import Box hiding (close)+import Box+import Box.Socket.Types import Control.Concurrent.Async import Control.Monad import Data.ByteString (ByteString)-import Data.Functor-import Data.Functor.Contravariant import Data.Text (Text, unpack)-import Data.Text.Encoding-import GHC.Generics-import Network.Simple.TCP+import GHC.Generics (Generic)+import Network.Simple.TCP (Socket)+import Network.Simple.TCP qualified as NS -- | TCP configuration -- -- >>> defaultTCPConfig--- TCPConfig {host = "127.0.0.1", port = "3566"}+-- TCPConfig {hostPreference = HostAny, host = "127.0.0.1", port = "3566", chunk = 2048, endLine = "\n"} data TCPConfig = TCPConfig- { host :: Text,- port :: Text+ { hostPreference :: NS.HostPreference,+ host :: Text,+ port :: Text,+ chunk :: Int,+ endLine :: Text } deriving (Show, Eq, Generic) -- | default defaultTCPConfig :: TCPConfig-defaultTCPConfig = TCPConfig "127.0.0.1" "3566"+defaultTCPConfig = TCPConfig NS.HostAny "127.0.0.1" "3566" 2048 "\n" -- | An active TCP environment-data Env = Env- { socket :: Socket,- sockaddr :: SockAddr,- -- | A screen dump thread- ascreendump :: Maybe (Async ()),- -- | A file dump thread- afiledump :: Maybe (Async ())+data TCPEnv = TCPEnv+ { socket :: NS.Socket,+ sockaddr :: NS.SockAddr } --- | Connects to a server with no screen or file dump.-new ::- -- | Configuration- TCPConfig ->- IO Env-new cfg = do- (sock, sa) <- connectSock (unpack $ host cfg) (unpack $ port cfg)- pure (Env sock sa Nothing Nothing)---- | close an Env-close :: Env -> IO ()-close env = do- closeSock (socket env)- maybe (pure ()) cancel (ascreendump env)- maybe (pure ()) cancel (afiledump env)---- | Emits from a 'Socket'-tcpEmitter :: Socket -> Emitter IO ByteString-tcpEmitter s = Emitter $ recv s 2048---- | Commits to a 'Socket'-tcpCommitter :: Socket -> Committer IO ByteString-tcpCommitter s = Committer $ \bs -> send s bs $> True---- | 'Box' connection for a 'Socket'-tcpBox :: Socket -> Box IO ByteString ByteString-tcpBox s = Box (tcpCommitter s) (tcpEmitter s)---- | TCP server 'Box'-tcpServer :: TCPConfig -> Box IO ByteString ByteString -> IO ()-tcpServer cfg (Box c e) =- serve- HostAny- (unpack $ port cfg)- ( \(s, _) ->- void $- race- (glue (tcpCommitter s) e)- (glue c (tcpEmitter s))- )---- | Response function.-responder :: (ByteString -> IO ByteString) -> Box IO ByteString ByteString -> IO ()-responder f = fuse (fmap Just . f)+-- | connect an action (ie a client)+connect :: TCPConfig -> Codensity IO TCPEnv+connect cfg =+ Codensity $+ NS.connect (unpack $ host cfg) (unpack $ port cfg)+ . (\action (s, a) -> action (TCPEnv s a)) --- | A server that explicitly responds to client messages.-tcpResponder :: TCPConfig -> (ByteString -> IO ByteString) -> IO ()-tcpResponder cfg f =- serve- HostAny- (unpack $ port cfg)- (\(s, _) -> responder f (Box (tcpCommitter s) (tcpEmitter s)))+-- | serve an action (ie a server)+serve :: TCPConfig -> Codensity IO TCPEnv+serve cfg =+ Codensity $+ NS.serve (hostPreference cfg) (unpack $ port cfg)+ . (\action (s, a) -> void $ action (TCPEnv s a)) --- | A server independent of incoming messages.-tcpSender :: TCPConfig -> Emitter IO ByteString -> IO ()-tcpSender cfg e =- serve- HostAny- (unpack $ port cfg)- (\(s, _) -> glue (tcpCommitter s) e)+-- | Commit received ByteStrings.+receiver ::+ TCPConfig ->+ Committer IO ByteString ->+ Socket ->+ IO ()+receiver cfg c conn = go+ where+ go = do+ msg <- NS.recv conn (chunk cfg)+ case msg of+ Nothing -> pure ()+ Just bs -> commit c bs >> go --- | A TCP client connected to stdin-tcpStdClient :: TCPConfig -> IO ()-tcpStdClient cfg = do- (Env s _ _ _) <- new cfg- void $- concurrently- (glue o (tcpEmitter s))- (glue (tcpCommitter s) i)+-- | Send emitted ByteStrings.+sender ::+ Emitter IO ByteString ->+ Socket ->+ IO SocketStatus+sender e conn = go where- o = contramap decodeUtf8 toStdout- i = fmap encodeUtf8 fromStdin+ go = do+ bs <- emit e+ case bs of+ Nothing -> pure SocketOpen+ Just bs' -> NS.send conn bs' >> go --- | test harness wrapping an action with a "q" escape.-testHarness :: IO () -> IO ()-testHarness io =- void $+-- | A two-way connection.+duplex ::+ TCPConfig ->+ PostSend ->+ Box IO ByteString ByteString ->+ Socket ->+ IO ()+duplex cfg ps (Box c e) conn = do+ _ <- race- io- (cancelQ fromStdin)+ ( do+ status <- sender e conn+ case (ps, status) of+ (CloseAfter s, SocketOpen) -> sleep s+ _ -> pure ()+ )+ (receiver cfg c conn)+ pure () --- | Cancel with a "q".-cancelQ :: Emitter IO Text -> IO ()-cancelQ e = do- e' <- emit e- case e' of- Just "q" -> pure ()- Just x -> putStrLn ("badly handled: " <> unpack x)- Nothing -> pure ()+-- | A 'Box' action for a client.+clientBox ::+ TCPConfig ->+ PostSend ->+ Box IO ByteString ByteString ->+ IO ()+clientBox cfg ps b = duplex cfg ps b . socket <$|> connect cfg --- | @"echo: " <>@ Responder-testResponder :: IO ()-testResponder = testHarness (tcpResponder defaultTCPConfig (pure . ("echo: " <>)))+-- | A client 'CoBox'.+clientCoBox ::+ TCPConfig ->+ PostSend ->+ CoBox IO ByteString ByteString+clientCoBox cfg ps = fromAction (clientBox cfg ps) --- | Test server.-testServerSender :: IO ()-testServerSender =- testHarness $- tcpSender defaultTCPConfig <$|>- qList ["hi!"]+-- | A 'Box' action for a server.+serverBox ::+ TCPConfig ->+ PostSend ->+ Box IO ByteString ByteString ->+ IO ()+serverBox cfg ps b = duplex cfg ps b . socket <$|> serve cfg++-- | A server 'CoBox'.+serverCoBox ::+ TCPConfig ->+ PostSend ->+ CoBox IO ByteString ByteString+serverCoBox cfg ps = fromAction (serverBox cfg ps)++-- | A receiver that applies a response function to received ByteStrings.+responseServer :: TCPConfig -> (ByteString -> Maybe ByteString) -> IO ()+responseServer cfg f = fuse (pure . f) <$|> serverCoBox cfg (CloseAfter 0.5)
+ src/Box/TCP/Example.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wall #-}++-- | It's a box. It's a TCP socket. It's an example.+module Box.TCP.Example where++import Box+import Box.Socket.Types+import Box.TCP+import Control.Concurrent.Async+import Data.ByteString+import Data.Profunctor+import Data.Text+import Data.Text.Encoding++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Box+-- >>> import Box.TCP.Example+-- >>> import Control.Concurrent.Async++-- | A server that only sends and a client that only receives.+--+-- The result here is indeterminate: it can return ["ab"] or ["a","b"] depending on when the client and servers fire.+--+-- > senderExample ["a","b"]+-- ["ab"]+senderExample :: [ByteString] -> IO [ByteString]+senderExample ts = do+ (c, r) <- refCommitter+ a <- async (serverBox defaultTCPConfig (CloseAfter 0.2) . Box mempty <$|> qList ts)+ sleep 0.2+ clientBox defaultTCPConfig (CloseAfter 0.5) (Box c mempty)+ sleep 0.6+ cancel a+ r++-- | A server that only sends and a client that only receives.+--+-- >>> senderLinesExample ["a","b"]+-- ["a","b"]+senderLinesExample :: [Text] -> IO [Text]+senderLinesExample ts = do+ (c, r) <- refCommitter+ a <- async (serverBox defaultTCPConfig (CloseAfter 0.2) . fromLineBox "\n" . Box mempty <$|> qList ts)+ sleep 0.2+ clientBox defaultTCPConfig (CloseAfter 0.5) (fromLineBox "\n" $ Box c mempty)+ sleep 0.6+ cancel a+ r++-- | echo server example+--+-- >>> echoExample ["a","b","c"]+-- ["echo: abc"]+echoExample :: [ByteString] -> IO [ByteString]+echoExample ts = do+ (c, r) <- refCommitter+ a <-+ async+ (responseServer defaultTCPConfig (pure . ("echo: " <>)))+ sleep 0.1+ clientBox defaultTCPConfig (CloseAfter 0.2) . Box c <$|> qList ts+ sleep 0.1+ cancel a+ r++-- | "q" to close the client, reads and writes from std+--+-- >>> clientIO+-- *** Exception: Network.Socket.connect: <socket: ...>: does not exist (Connection refused)+clientIO :: IO ()+clientIO =+ clientBox defaultTCPConfig (CloseAfter 0) (dimap decodeUtf8Lenient encodeUtf8 (stdBox "q"))++-- | "q" to close a client socket down. Ctrl-c to close the server. Reads and writes from std.+--+-- >>> a <- async serverIO+-- >>> serverIO+-- *** Exception: Network.Socket.bind: resource busy (Address already in use)+--+-- >>> cancel a+serverIO :: IO ()+serverIO = serverBox defaultTCPConfig (CloseAfter 0) (dimap decodeUtf8Lenient encodeUtf8 (stdBox "q"))
+ src/Box/Websocket.hs view
@@ -0,0 +1,238 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Websocket components built with 'Box'es.+module Box.Websocket+ ( SocketConfig (..),+ defaultSocketConfig,+ connect,+ serve,+ pending,+ serverApp,+ receiver,+ receiver_,+ sender,+ sender_,+ duplex,+ duplex_,+ clientBox,+ clientCoBox,+ serverBox,+ serverCoBox,+ responseServer,+ )+where++import Box+import Box.Socket.Types+import Control.Concurrent.Async+import Control.Exception+import Control.Monad+import Data.ByteString qualified as BS+import Data.Functor.Contravariant+import Data.Text (Text, pack, unpack)+import GHC.Generics (Generic)+import Network.WebSockets++-- | Socket configuration+--+-- >>> defaultSocketConfig+-- SocketConfig {host = "127.0.0.1", port = 9160, path = "/"}+data SocketConfig = SocketConfig+ { host :: Text,+ port :: Int,+ path :: Text+ }+ deriving (Show, Eq, Generic)++-- | official default+defaultSocketConfig :: SocketConfig+defaultSocketConfig = SocketConfig "127.0.0.1" 9160 "/"++-- | connect an action (ie a client)+connect :: SocketConfig -> Codensity IO Connection+connect c = Codensity $ \action ->+ runClient (unpack $ host c) (port c) (unpack $ path c) action++-- | serve an action (ie a server)+serve :: SocketConfig -> Codensity IO Connection+serve c =+ Codensity $+ runServerWithOptions (defaultServerOptions {serverHost = unpack (host c), serverPort = port c}) . upgrade+ where+ upgrade action p = void $ action <$|> pending p++-- | Attach a box to a 'PendingConnection' in wai-style.+serverApp ::+ Box IO Text Text ->+ PendingConnection ->+ IO ()+serverApp b p = upgrade (duplex (CloseAfter 0.2) b) p+ where+ upgrade action p' = void $ action <$|> pending p'++-- | Given a 'PendingConnection', provide a 'Connection' continuation.+pending :: PendingConnection -> Codensity IO Connection+pending p = Codensity $ \action ->+ bracket+ (acceptRequest p)+ (\_ -> pure ())+ ( \conn ->+ withAsync+ (forever $ sendPing conn ("connect ping" :: BS.ByteString) >> sleep 30)+ (\_ -> action conn)+ )++-- | Commit received messages, finalising on receiving a 'CloseRequest'+receiver ::+ (WebSocketsData a) =>+ Committer IO a ->+ Connection ->+ IO ()+receiver c conn = go+ where+ go = do+ msg <- try (receiveData conn)+ case msg of+ Left (CloseRequest _ _) -> pure ()+ Left err -> throwIO err+ Right msg' -> commit c msg' >> go++-- | Commit received messages, finalising on receiving a 'CloseRequest', with event logging.+receiver_ ::+ (WebSocketsData a, Show a) =>+ Committer IO a ->+ Committer IO Text ->+ Connection ->+ IO ()+receiver_ c cLog conn = go+ where+ go = do+ msg <- try (receiveData conn)+ _ <- commit cLog ("receiveData:" <> pack (show msg))+ case msg of+ Left (CloseRequest _ _) -> pure ()+ Left err -> throwIO err+ Right msg' -> commit c msg' >> go++-- | Send emitted messages, returning whether the socket remained open (the 'Emitter' ran out of emits) or closed (a 'CloseRequest' was received).+sender ::+ (WebSocketsData a) =>+ Emitter IO a ->+ Connection ->+ IO SocketStatus+sender e conn = go+ where+ go = do+ msg <- emit e+ case msg of+ Nothing -> pure SocketOpen+ Just msg' -> do+ ok <- try (sendTextData conn msg')+ case ok of+ Left (CloseRequest _ _) -> pure SocketClosed+ Left err -> throwIO err+ Right () -> go++-- | Send emitted messages, returning whether the socket remained open (the 'Emitter' ran out of emits) or closed (a 'CloseRequest' was received). With event logging.+sender_ ::+ (WebSocketsData a, Show a) =>+ Emitter IO a ->+ Committer IO Text ->+ Connection ->+ IO SocketStatus+sender_ e cLog conn = go+ where+ go = do+ msg <- emit e+ _ <- commit cLog ("emit:" <> pack (show msg))+ case msg of+ Nothing -> pure SocketOpen+ Just msg' -> do+ ok <- try (sendTextData conn msg')+ _ <- commit cLog ("sendTextData:" <> pack (show ok))+ case ok of+ Left (CloseRequest _ _) -> pure SocketClosed+ Left err -> throwIO err+ Right () -> go++-- | A two-way connection. Closes if it receives a 'CloseRequest' exception, or if 'PostSend' is 'CloseAfter'.+duplex ::+ (WebSocketsData a) =>+ PostSend ->+ Box IO a a ->+ Connection ->+ IO ()+duplex ps (Box c e) conn = do+ concurrentlyRight+ ( do+ status <- sender e conn+ case (ps, status) of+ (CloseAfter s, SocketOpen) -> do+ sleep s+ sendClose conn ("close after sending" :: Text)+ _ -> pure ()+ )+ (receiver c conn)++-- | A two-way connection. Closes if it receives a 'CloseRequest' exception, or if 'PostSend' is 'CloseAfter'. With event logging.+duplex_ ::+ (WebSocketsData a, Show a) =>+ PostSend ->+ Committer IO Text ->+ Box IO a a ->+ Connection ->+ IO ()+duplex_ ps cLog (Box c e) conn = do+ concurrentlyRight+ ( do+ status <- sender_ e (contramap ("sender_:" <>) cLog) conn+ _ <- commit cLog ("sender_ closed with " <> pack (show status))+ case (ps, status) of+ (CloseAfter s, SocketOpen) -> do+ sleep s+ sendClose conn ("close after sending" :: Text)+ _ -> pure ()+ )+ ( do+ receiver_ c (contramap ("receiver_:" <>) cLog) conn+ void $ commit cLog "receiver_ closed"+ )+ void $ commit cLog "duplex_ closed"++-- | A 'Box' action for a client.+clientBox ::+ (WebSocketsData a) =>+ SocketConfig ->+ PostSend ->+ Box IO a a ->+ IO ()+clientBox cfg ps b = duplex ps b <$|> connect cfg++-- | A client 'CoBox'.+clientCoBox ::+ (WebSocketsData a) =>+ SocketConfig ->+ PostSend ->+ CoBox IO a a+clientCoBox cfg ps = fromAction (clientBox cfg ps)++-- | A 'Box' action for a server.+serverBox ::+ (WebSocketsData a) =>+ SocketConfig ->+ PostSend ->+ Box IO a a ->+ IO ()+serverBox cfg ps b = duplex ps b <$|> serve cfg++-- | A server 'CoBox'.+serverCoBox ::+ (WebSocketsData a) =>+ SocketConfig ->+ PostSend ->+ CoBox IO a a+serverCoBox cfg ps = fromAction (serverBox cfg ps)++-- | A receiver that applies a response function to received messages.+responseServer :: (WebSocketsData a) => SocketConfig -> (a -> Maybe a) -> IO ()+responseServer cfg f = fuse (pure . f) <$|> serverCoBox cfg (CloseAfter 0.5)
+ src/Box/Websocket/Example.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wall #-}++-- | It's a box. It's a websocket. It's an example.+module Box.Websocket.Example where++import Box+import Box.Socket.Types+import Box.Websocket+import Control.Concurrent.Async+import Data.Functor.Contravariant+import Data.Text (Text)++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Box+-- >>> import Box.Websocket.Example+-- >>> import Control.Concurrent.Async++-- | A server that only sends and a client that only receives.+--+-- >>> senderExample ["a","b"]+-- ["a","b"]+senderExample :: [Text] -> IO [Text]+senderExample ts = do+ (c, r) <- refCommitter+ a <- async (serverBox defaultSocketConfig (CloseAfter 0.2) . Box mempty <$|> qList ts)+ sleep 0.1+ clientBox defaultSocketConfig StayOpen (Box c mempty)+ sleep 0.1+ cancel a+ r++-- | echo server example+--+-- >>> echoExample ["a","b","c"]+-- ["echo: a","echo: b","echo: c"]+echoExample :: [Text] -> IO [Text]+echoExample ts = do+ (c, r) <- refCommitter+ a <-+ async+ (responseServer defaultSocketConfig (pure . (("echo: " :: Text) <>)))+ sleep 0.1+ clientBox defaultSocketConfig (CloseAfter 0.2) . Box c <$|> qList ts+ sleep 0.1+ cancel a+ r++-- | echo server example, with event logging.+--+-- The order of events is non-deterministic, so this is a rough guide:+--+-- > echoLogExample ["a","b","c"]+-- (["echo: a","echo: b","echo: c"],["client:sender_:emit:Just \"a\"","client:sender_:sendTextData:Right ()","client:sender_:emit:Just \"b\"","client:sender_:sendTextData:Right ()","client:sender_:emit:Just \"c\"","client:sender_:sendTextData:Right ()","client:sender_:emit:Nothing","client:sender_ closed with SocketOpen","server:receiver_:receiveData:Right \"a\"","server:receiver_:receiveData:Right \"b\"","server:receiver_:receiveData:Right \"c\"","server:sender_:emit:Just \"echo: a\"","server:sender_:sendTextData:Right ()","server:sender_:emit:Just \"echo: b\"","server:sender_:sendTextData:Right ()","server:sender_:emit:Just \"echo: c\"","server:sender_:sendTextData:Right ()","client:receiver_:receiveData:Right \"echo: a\"","client:receiver_:receiveData:Right \"echo: b\"","client:receiver_:receiveData:Right \"echo: c\"","server:receiver_:receiveData:Left (CloseRequest 1000 \"close after sending\")","server:receiver_ closed","client:receiver_:receiveData:Left (CloseRequest 1000 \"close after sending\")","client:receiver_ closed","client:duplex_ closed","server:duplex_ closed"])+echoLogExample :: [Text] -> IO ([Text], [Text])+echoLogExample ts = do+ (c, r) <- refCommitter+ (cLog, resLog) <- refCommitter+ a <-+ async+ (fuse (pure . pure . (("echo: " :: Text) <>)) <$|> fromAction (\b -> duplex_ (CloseAfter 0.5) (contramap ("server:" <>) cLog) b <$|> serve defaultSocketConfig))+ sleep 0.1+ duplex_ (CloseAfter 0.2) (contramap ("client:" <>) cLog) . Box c <$> qList ts <*|> connect defaultSocketConfig+ sleep 0.1+ cancel a+ (,) <$> r <*> resLog++-- | "q" to close the client, reads and writes from std+--+-- >>> clientIO+-- *** Exception: Network.Socket.connect: <socket: ...>: does not exist (Connection refused)+clientIO :: IO ()+clientIO =+ clientBox defaultSocketConfig (CloseAfter 0) (stdBox "q")++-- | "q" to close a client socket down. Ctrl-c to close the server. Reads and writes from std.+--+-- >>> a <- async serverIO+-- >>> serverIO+-- *** Exception: Network.Socket.bind: resource busy (Address already in use)+--+-- >>> cancel a+serverIO :: IO ()+serverIO = serverBox defaultSocketConfig (CloseAfter 0) (stdBox "q")