diff --git a/app/box-socket.hs b/app/box-socket.hs --- a/app/box-socket.hs +++ b/app/box-socket.hs @@ -6,23 +6,16 @@ {-# 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.Concurrent.Classy.Async as C -import Control.Lens hiding (Unwrapped, Wrapped) -import Data.Bool -import Data.Generics.Labels () -import Data.Text (pack) +import Box.Socket.Example import Options.Generic data SocketType = Client | Responder | TestRun deriving (Eq, Read, Show, Generic) @@ -48,59 +41,3 @@ Responder -> show <$> q' serverIO TestRun -> show <$> testRun 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 (pack . 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 () - _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) <- cRef - runClient - defaultSocketConfig - ( \conn -> - (\b -> clientApp b conn) - <$.> ( Box c - <$> fromListE (xs <> ["q"]) - ) - ) - r - -tClientIO :: [Text] -> IO () -tClientIO xs = - (runClient defaultSocketConfig . clientApp) - <$.> (Box (contramap (pack . 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 (pack . 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,6 +1,6 @@ cabal-version: 2.4 name: box-socket -version: 0.2.0 +version: 0.3.0 synopsis: Box websockets description: Websockets built with the box library. category: project @@ -11,7 +11,7 @@ homepage: https://github.com/tonyday567/box-socket#readme bug-reports: https://github.com/tonyday567/box-socket/issues build-type: Simple -tested-with: GHC ==8.8.4 || ==8.10.4 || ==9.0.1 || ==9.2.0.20210821 +tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.2.1 source-repository head type: git @@ -20,18 +20,17 @@ library exposed-modules: Box.Socket + Box.Socket.Example Box.TCP hs-source-dirs: src build-depends: , async ^>=2.2.3 - , base >=4.12 && <5 - , box ^>=0.7 - , bytestring ^>=0.10 + , base >=4.12 && <5 + , box ^>=0.8 + , bytestring >=0.10 && <0.12 , concurrency ^>=1.11 , exceptions ^>=0.10 - , generic-lens ^>=2.2 - , lens ^>=5.0 , network ^>=3.1 , network-simple ^>=0.4 , text ^>=1.2.4 @@ -41,22 +40,17 @@ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fwrite-ide-info - -hiedir=.hie -Wunused-packages + -hiedir=.hie executable box-socket main-is: box-socket.hs hs-source-dirs: app build-depends: - , base >=4.7 && <5 - , box ^>=0.7 + , base >=4.7 && <5 , box-socket - , concurrency ^>=1.11 - , generic-lens ^>=2.2 - , lens ^>=5.0 - , optparse-generic ^>=1.3 - , text ^>=1.2.4 + , optparse-generic >=1.3 && <1.5 default-language: Haskell2010 ghc-options: -funbox-strict-fields -fforce-recomp -threaded -rtsopts - -with-rtsopts=-N -fwrite-ide-info -hiedir=.hie -Wunused-packages + -with-rtsopts=-N -fwrite-ide-info -hiedir=.hie diff --git a/src/Box/Socket.hs b/src/Box/Socket.hs --- a/src/Box/Socket.hs +++ b/src/Box/Socket.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StrictData #-} {-# OPTIONS_GHC -Wall #-} @@ -23,13 +22,11 @@ import Box import qualified Control.Concurrent.Classy.Async as C -import Control.Lens import Control.Monad import Control.Monad.Catch import Control.Monad.Conc.Class as C import Control.Monad.IO.Class import qualified Data.ByteString as BS -import Data.Generics.Labels () import Data.Text (Text, pack, unpack) import GHC.Generics import qualified Network.WebSockets as WS @@ -51,15 +48,15 @@ -- | Run a client app. runClient :: (MonadIO m) => SocketConfig -> WS.ClientApp () -> m () -runClient c app = liftIO $ WS.runClient (unpack $ c ^. #host) (c ^. #port) (unpack $ c ^. #path) app +runClient c app = liftIO $ WS.runClient (unpack $ host c) (port c) (unpack $ path c) app -- | Run a server app. runServer :: (MonadIO m) => SocketConfig -> WS.ServerApp -> m () -runServer c app = liftIO $ WS.runServer (unpack $ c ^. #host) (c ^. #port) app +runServer c app = liftIO $ WS.runServer (unpack $ host c) (port c) app -- | Connection continuation. -connect :: (MonadIO m, MonadConc m) => WS.PendingConnection -> Cont m WS.Connection -connect p = Cont $ \action -> +connect :: (MonadIO m, MonadConc m) => WS.PendingConnection -> Codensity m WS.Connection +connect p = Codensity $ \action -> bracket (liftIO $ WS.acceptRequest p) (\conn -> liftIO $ WS.sendClose conn ("Bye from connect!" :: Text)) @@ -86,7 +83,7 @@ (Text -> Either Text Text) -> WS.PendingConnection -> IO () -responderApp f p = with (connect p) (responder f mempty) +responderApp f p = process (responder f mempty) (connect p) -- | Standard server app for a box. serverApp :: @@ -96,13 +93,13 @@ m () serverApp (Box c e) p = void $ - with - (connect p) + process ( \conn -> C.race (receiver c conn) (sender (Box mempty e) conn) ) + (connect p) -- | default websocket receiver with messages -- Lefts are info/debug diff --git a/src/Box/Socket/Example.hs b/src/Box/Socket/Example.hs new file mode 100644 --- /dev/null +++ b/src/Box/Socket/Example.hs @@ -0,0 +1,75 @@ +{-# 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.Classy.Async as C +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 = C.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 <- C.async (runServer defaultSocketConfig (responderApp (\x -> bool (Right $ "echo:" <> x) (Left "quit") (x == "q")))) + sleep 0.1 + r <- tClient (pack . show <$> [1 .. 3 :: Int]) + C.cancel a + pure r diff --git a/src/Box/TCP.hs b/src/Box/TCP.hs --- a/src/Box/TCP.hs +++ b/src/Box/TCP.hs @@ -23,12 +23,12 @@ ) where -import Box +import Box hiding (close) import Control.Concurrent.Async -import Control.Lens 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 @@ -101,8 +101,7 @@ -- | Response function. responder :: (ByteString -> IO ByteString) -> Box IO ByteString ByteString -> IO () -responder f (Box c e) = - glue c (mapE (fmap Just . f) e) +responder f = fuse (fmap Just . f) -- | A server that explicitly responds to client messages. tcpResponder :: TCPConfig -> (ByteString -> IO ByteString) -> IO () @@ -157,4 +156,4 @@ testServerSender :: IO () testServerSender = testHarness $ - tcpSender defaultTCPConfig <$.> fromListE ["hi!"] + tcpSender defaultTCPConfig <$|> qList ["hi!"]