packages feed

box-socket 0.0.2 → 0.5.3.0

raw patch · 13 files changed

Files

+ ChangeLog.md view
@@ -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+
+ 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
app/box-socket.hs view
@@ -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-
box-socket.cabal view
@@ -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,
+ readme.md view
@@ -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.+
− src/Box/Socket.hs 
@@ -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
+ src/Box/Socket/Types.hs view
@@ -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)
+ src/Box/TCP.hs view
@@ -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)
+ src/Box/TCP/Example.hs view
@@ -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: <socket: ...>: 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"))
+ 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,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: <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")
− test/test.hs 
@@ -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"-  ]