diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,12 @@ +0.5.2 +=== +* dependency bumps for 9.10 + +0.5 +=== +* complete refactor + +* aligned TCP api with Websockets + +* Action & Codensity-based API surface + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/box-socket.hs b/app/box-socket.hs --- a/app/box-socket.hs +++ b/app/box-socket.hs @@ -1,105 +1,64 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wall #-} -{-# OPTIONS_GHC -Wno-unused-do-bind #-} {- -It's a box. It's a socket. +It's a box. It's a socket. It's an app. -} module Main where -import Box -import Box.Socket -import Control.Lens hiding (Wrapped, Unwrapped) -import Data.Generics.Labels () -import NumHask.Prelude hiding (STM, bracket) -import Options.Generic -import Control.Concurrent.Classy.Async as C +import Box.TCP.Example as TCP +import Box.Websocket.Example as Websocket +import Options.Applicative -data SocketType = Client | Responder | TestRun deriving (Eq, Read, Show, Generic) +boxSocketOpts :: ParserInfo Opts +boxSocketOpts = + info + (boxSocketOptions <**> helper) + (fullDesc <> progDesc "box-socket tests" <> header "examples of box socket usage") -instance ParseField SocketType +data SocketType = TCPSocket | WebSocket deriving (Eq, Read, Show) -instance ParseRecord SocketType +data ExampleType = ClientIO | ServerIO | EchoExample | SenderExample deriving (Eq, Read, Show) -instance ParseFields SocketType +data Opts = Opts + { socketType :: SocketType, + exampleType :: ExampleType + } + deriving (Eq, Show) -data Opts w - = Opts - { apptype :: w ::: SocketType "type of websocket app" - } - deriving (Generic) +boxSocketOptions :: Parser Opts +boxSocketOptions = + Opts + <$> parseSocketType + <*> parseExampleType -instance ParseRecord (Opts Wrapped) +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 :: Text <- 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 - --- * older stuff -serverIO :: IO () -serverIO = runServer defaultSocketConfig - (responderApp (\x -> bool (Right $ "echo:" <> x) (Left "quit") (x=="q"))) - -clientIO :: IO () -clientIO = - (runClient defaultSocketConfig . clientApp) - (Box (contramap show toStdout) fromStdin) - -q' :: IO a -> IO (Either () a) -q' f = C.race (cancelQ fromStdin) f - -cancelQ :: Emitter IO Text -> IO () -cancelQ e = do - e' <- emit e - case e' of - Just "q" -> pure () - _ -> do - putStrLn ("nothing happens" :: Text) - 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) <- cRef - runClient defaultSocketConfig - (\conn -> - (\b -> clientApp b conn) <$.> - (Box <$> - pure c <*> - fromListE (xs <> ["q"]))) - r - -tClientIO :: [Text] -> IO () -tClientIO xs = - (runClient defaultSocketConfig . clientApp) <$.> - (Box (contramap show toStdout) <$> (fromListE (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 <- C.async (runServer defaultSocketConfig (responderApp (\x -> bool (Right $ "echo:" <> x) (Left "quit") (x=="q")))) - sleep 0.1 - r <- tClient (show <$> [1..3::Int]) - C.cancel a - pure r - diff --git a/box-socket.cabal b/box-socket.cabal --- a/box-socket.cabal +++ b/box-socket.cabal @@ -1,92 +1,96 @@ -cabal-version: 2.4 -name: box-socket -version: 0.0.2 -synopsis: See readme.md -description: See readme.md for description. -category: project +cabal-version: 3.0 +name: box-socket +version: 0.5.3.0 +license: BSD-3-Clause +license-file: LICENSE +copyright: Tony Day (c) 2017 +category: web 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 +synopsis: Box websockets +description: Websockets built with the box library. build-type: Simple +tested-with: + ghc ==9.10.2 + ghc ==9.12.2 + ghc ==9.14.1 + +extra-doc-files: + ChangeLog.md + readme.md + source-repository head type: git location: https://github.com/tonyday567/box-socket -library - exposed-modules: - Box.Socket - hs-source-dirs: - src - build-depends: - base >= 4.12 && <5, - box >= 0.6 && < 0.7, - concurrency >= 1.11, - exceptions >= 0.10, - generic-lens >= 1.1.0 && < 3.0, - lens >= 4.17.1 && < 4.20, - numhask >= 0.6, - websockets >= 0.12, - default-language: Haskell2010 - default-extensions: - NegativeLiterals - NoImplicitPrelude - OverloadedStrings - UnicodeSyntax +common ghc-options-exe-stanza ghc-options: + -fforce-recomp + -funbox-strict-fields + -rtsopts + -threaded + -with-rtsopts=-N + +common ghc-options-stanza + ghc-options: -Wall -Wcompat + -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns + -Wpartial-fields -Wredundant-constraints +common ghc2024-additions + default-extensions: + DataKinds + DerivingStrategies + DisambiguateRecordFields + ExplicitNamespaces + GADTs + LambdaCase + MonoLocalBinds + RoleAnnotations + +common ghc2024-stanza + if impl(ghc >=9.10) + default-language: + GHC2024 + else + import: ghc2024-additions + default-language: + GHC2021 + +library + import: ghc-options-stanza + import: ghc2024-stanza + hs-source-dirs: src + build-depends: + async >=2.2.3 && <2.3, + base >=4.14 && <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.14, + + 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: ghc2024-stanza main-is: box-socket.hs hs-source-dirs: app build-depends: - base >= 4.7 && < 5, - box, - box-socket, - concurrency >= 1.11, - generic-lens >= 2.0, - lens >= 4.19, - numhask >= 0.6, - optparse-generic >= 1.3, - default-language: Haskell2010 - default-extensions: - NegativeLiterals - NoImplicitPrelude - OverloadedStrings - UnicodeSyntax - ghc-options: - -funbox-strict-fields - -fforce-recomp - -threaded - -rtsopts - -with-rtsopts=-N - -test-suite test - type: exitcode-stdio-1.0 - main-is: test.hs - hs-source-dirs: - test - build-depends: - base >=4.7 && <5, + base >=4.14 && <5, box-socket, - doctest >= 0.16, - numhask >= 0.6, - default-language: Haskell2010 - default-extensions: - NegativeLiterals - NoImplicitPrelude - OverloadedStrings - UnicodeSyntax - ghc-options: - -Wall - -Wcompat - -Wincomplete-record-updates - -Wincomplete-uni-patterns - -Wredundant-constraints - -funbox-strict-fields + optparse-applicative >=0.17 && <0.20, diff --git a/readme.md b/readme.md new file mode 100644 --- /dev/null +++ b/readme.md @@ -0,0 +1,29 @@ +[![img](https://img.shields.io/hackage/v/box-socket.svg)](https://hackage.haskell.org/package/box-socket) [![img](https://github.com/tonyday567/box-socket/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/tonyday567/box/actions/workflows/haskell-ci.yml) + +Socket API based on the box library, with websockets and TCP support. + + +# Usage + + :set -XOverloadedStrings + import Box + import Box.Socket.Types + import Box.Websocket + +IO client: + + clientBox defaultSocketConfig (CloseAfter 0) (stdBox "q") + +IO server: + + serverBox defaultSocketConfig (CloseAfter 0) (stdBox "q") + +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. + diff --git a/src/Box/Socket.hs b/src/Box/Socket.hs deleted file mode 100644 --- a/src/Box/Socket.hs +++ /dev/null @@ -1,163 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# OPTIONS_GHC -Wall #-} -{-# OPTIONS_GHC -Wno-unused-do-bind #-} - -module Box.Socket - ( SocketConfig(..), - defaultSocketConfig, - runClient, - runServer, - connect, - clientApp, - responderApp, - serverApp, - receiver', - receiver, - sender, - responder, - ) -where - -import qualified Network.WebSockets as WS -import Box -import Control.Lens -import NumHask.Prelude hiding (bracket) -import Data.Generics.Labels () -import Control.Monad.Conc.Class as C -import Control.Monad.Catch -import qualified Control.Concurrent.Classy.Async as C - -data SocketConfig - = SocketConfig - { host :: Text, - port :: Int, - path :: Text - } - deriving (Show, Eq, Generic) - -defaultSocketConfig :: SocketConfig -defaultSocketConfig = SocketConfig "127.0.0.1" 9160 "/" - -runClient :: (MonadIO m) => SocketConfig -> WS.ClientApp () -> m () -runClient c app = liftIO $ WS.runClient (unpack $ c ^. #host) (c ^. #port) (unpack $ c ^. #path) app - -runServer :: (MonadIO m) => SocketConfig -> WS.ServerApp -> m () -runServer c app = liftIO $ WS.runServer (unpack $ c ^. #host) (c ^. #port) app - -connect :: (MonadIO m, MonadConc m) => WS.PendingConnection -> Cont m WS.Connection -connect p = Cont $ \action -> - bracket - (liftIO $ WS.acceptRequest p) - (\conn -> liftIO $ WS.sendClose conn ("Bye from connect!" :: Text)) - (\conn -> - C.withAsync - (liftIO $ forever $ WS.sendPing conn ("ping" :: ByteString) >> sleep 30) - (\_ -> action conn)) - -clientApp :: (MonadIO m, MonadConc m) => - Box m (Either Text Text) Text -> - WS.Connection -> - m () -clientApp (Box c e) conn = - void $ - C.race - (receiver' c conn) - (sender (Box mempty e) conn) - -responderApp :: - (Text -> Either Text Text) -> - WS.PendingConnection -> - IO () -responderApp f p = with (connect p) (responder f mempty) - -serverApp :: - (MonadConc m, MonadIO m) => - Box m Text Text -> - WS.PendingConnection -> - m () -serverApp (Box c e) p = void $ with (connect p) - (\conn -> C.race - (receiver c conn) - (sender (Box mempty e) conn)) - --- | default websocket receiver --- Lefts are info/debug -receiver' :: (MonadIO m) => - Committer m (Either Text Text) -> - WS.Connection -> - m Bool -receiver' c conn = go - where - go = do - msg <- liftIO $ WS.receive conn - case msg of - WS.ControlMessage (WS.Close w b) -> - commit - c - ( Left - ( "receiver: received: close: " <> show w <> " " <> 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 - --- | default websocket receiver --- Lefts are info/debug -receiver :: (MonadIO m) => - Committer m Text -> - WS.Connection -> - m () -receiver c conn = go - where - go = do - msg <- liftIO $ WS.receive conn - case msg of - WS.ControlMessage (WS.Close _ _) -> pure () - WS.ControlMessage _ -> go - WS.DataMessage _ _ _ msg' -> commit c (WS.fromDataMessage msg') >> go - --- | default websocket sender -sender :: - (MonadIO m, WS.WebSocketsData a, Show a) => - Box m Text a -> - WS.Connection -> - m () -sender (Box c e) conn = forever $ do - msg <- emit e - case msg of - Nothing -> pure () - Just msg' -> do - commit c $ "sender: sending: " <> (show msg' :: Text) - liftIO $ WS.sendTextData conn msg' - --- | a receiver that responds based on received Text. --- lefts are quit signals. Rights are response text. -responder :: (MonadIO m) => - (Text -> Either Text Text) -> - Committer m Text -> - WS.Connection -> - m () -responder f c conn = go - where - go = do - msg <- liftIO $ WS.receive conn - case msg of - WS.ControlMessage (WS.Close _ _) -> do - commit c "responder: normal close" - liftIO $ 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" - liftIO $ WS.sendClose conn ("received close signal: responder closed." :: Text) - Right r -> do - commit c ("responder: sending" <> r) - liftIO $ WS.sendTextData conn r - go diff --git a/src/Box/Socket/Types.hs b/src/Box/Socket/Types.hs new file mode 100644 --- /dev/null +++ b/src/Box/Socket/Types.hs @@ -0,0 +1,14 @@ +-- | 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) diff --git a/src/Box/TCP.hs b/src/Box/TCP.hs new file mode 100644 --- /dev/null +++ b/src/Box/TCP.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | TCP Boxes. +module Box.TCP + ( TCPConfig (..), + defaultTCPConfig, + TCPEnv (..), + Socket, + connect, + serve, + receiver, + sender, + duplex, + clientBox, + clientCoBox, + serverBox, + serverCoBox, + responseServer, + ) +where + +import Box +import Box.Socket.Types +import Control.Concurrent.Async +import Control.Monad +import Data.ByteString (ByteString) +import Data.Text (Text, unpack) +import GHC.Generics (Generic) +import Network.Simple.TCP (Socket) +import Network.Simple.TCP qualified as NS + +-- | TCP configuration +-- +-- >>> defaultTCPConfig +-- TCPConfig {hostPreference = HostAny, host = "127.0.0.1", port = "3566", chunk = 2048, endLine = "\n"} +data TCPConfig = TCPConfig + { hostPreference :: NS.HostPreference, + host :: Text, + port :: Text, + chunk :: Int, + endLine :: Text + } + deriving (Show, Eq, Generic) + +-- | default +defaultTCPConfig :: TCPConfig +defaultTCPConfig = TCPConfig NS.HostAny "127.0.0.1" "3566" 2048 "\n" + +-- | An active TCP environment +data TCPEnv = TCPEnv + { socket :: NS.Socket, + sockaddr :: NS.SockAddr + } + +-- | 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)) + +-- | 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)) + +-- | 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 + +-- | Send emitted ByteStrings. +sender :: + Emitter IO ByteString -> + Socket -> + IO SocketStatus +sender e conn = go + where + go = do + bs <- emit e + case bs of + Nothing -> pure SocketOpen + Just bs' -> NS.send conn bs' >> go + +-- | A two-way connection. +duplex :: + TCPConfig -> + PostSend -> + Box IO ByteString ByteString -> + Socket -> + IO () +duplex cfg ps (Box c e) conn = do + _ <- + race + ( do + status <- sender e conn + case (ps, status) of + (CloseAfter s, SocketOpen) -> sleep s + _ -> pure () + ) + (receiver cfg c conn) + 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 + +-- | A client 'CoBox'. +clientCoBox :: + TCPConfig -> + PostSend -> + CoBox IO ByteString ByteString +clientCoBox cfg ps = fromAction (clientBox cfg ps) + +-- | 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) diff --git a/src/Box/TCP/Example.hs b/src/Box/TCP/Example.hs new file mode 100644 --- /dev/null +++ b/src/Box/TCP/Example.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | 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: : does not exist (Connection refused) +clientIO :: IO () +clientIO = + clientBox defaultTCPConfig (CloseAfter 0) (dimap decodeUtf8 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 decodeUtf8 encodeUtf8 (stdBox "q")) diff --git a/src/Box/Websocket.hs b/src/Box/Websocket.hs new file mode 100644 --- /dev/null +++ b/src/Box/Websocket.hs @@ -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) diff --git a/src/Box/Websocket/Example.hs b/src/Box/Websocket/Example.hs new file mode 100644 --- /dev/null +++ b/src/Box/Websocket/Example.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | 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: : 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") diff --git a/test/test.hs b/test/test.hs deleted file mode 100644 --- a/test/test.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# OPTIONS_GHC -Wall #-} - -module Main where - -import NumHask.Prelude -import Test.DocTest - -main :: IO () -main = doctest - [ "app/box-socket.hs" - ]