diff --git a/app/box-socket.hs b/app/box-socket.hs --- a/app/box-socket.hs +++ b/app/box-socket.hs @@ -1,11 +1,8 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wall #-} @@ -21,11 +18,12 @@ import Box import Box.Socket -import Control.Lens hiding (Wrapped, Unwrapped) +import Control.Concurrent.Classy.Async as C +import Control.Lens hiding (Unwrapped, Wrapped) +import Data.Bool import Data.Generics.Labels () -import NumHask.Prelude hiding (STM, bracket) +import Data.Text (pack) import Options.Generic -import Control.Concurrent.Classy.Async as C data SocketType = Client | Responder | TestRun deriving (Eq, Read, Show, Generic) @@ -35,10 +33,9 @@ instance ParseFields SocketType -data Opts w - = Opts - { apptype :: w ::: SocketType "type of websocket app" - } +newtype Opts w = Opts + { apptype :: w ::: SocketType "type of websocket app" + } deriving (Generic) instance ParseRecord (Opts Wrapped) @@ -46,21 +43,24 @@ main :: IO () main = do o :: Opts Unwrapped <- unwrapRecord "example websocket apps" - r :: Text <- case apptype o of + r :: String <- case apptype o of Client -> show <$> clientIO 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"))) +serverIO = + runServer + defaultSocketConfig + (responderApp (\x -> bool (Right $ "echo:" <> x) (Left "quit") (x == "q"))) clientIO :: IO () clientIO = (runClient defaultSocketConfig . clientApp) - (Box (contramap show toStdout) fromStdin) + (Box (contramap (pack . show) toStdout) fromStdin) q' :: IO a -> IO (Either () a) q' f = C.race (cancelQ fromStdin) f @@ -70,25 +70,28 @@ e' <- emit e case e' of Just "q" -> pure () - _ -> do - putStrLn ("nothing happens" :: Text) + _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"]))) + (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 show toStdout) <$> (fromListE (xs <> ["q"]))) + (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. @@ -96,9 +99,8 @@ -- [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")))) + a <- C.async (runServer defaultSocketConfig (responderApp (\x -> bool (Right $ "echo:" <> x) (Left "quit") (x == "q")))) sleep 0.1 - r <- tClient (show <$> [1..3::Int]) + 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,80 +1,62 @@ cabal-version: 2.4 name: box-socket -version: 0.1.2 -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 +version: 0.2.0 +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 +tested-with: GHC ==8.8.4 || ==8.10.4 || ==9.0.1 || ==9.2.0.20210821 + source-repository head - type: git + type: git location: https://github.com/tonyday567/box-socket library exposed-modules: Box.Socket Box.TCP - hs-source-dirs: - src + + hs-source-dirs: src build-depends: - base >= 4.12 && <5, - box >= 0.6 && < 0.7, - bytestring >= 0.10 && < 0.11, - concurrency >= 1.11 && < 1.12, - exceptions >= 0.10 && < 0.11, - generic-lens >= 1.1.0 && < 3.0, - lens >= 4.17.1 && < 4.20, - network >= 3.1 && < 3.2, - network-simple >= 0.4 && < 0.5, - numhask >= 0.7 && < 0.8, - websockets >= 0.12 && < 0.13, + , async ^>=2.2.3 + , base >=4.12 && <5 + , box ^>=0.7 + , bytestring ^>=0.10 + , concurrency ^>=1.11 + , exceptions ^>=0.10 + , generic-lens ^>=2.2 + , lens ^>=5.0 + , network ^>=3.1 + , network-simple ^>=0.4 + , text ^>=1.2.4 + , websockets ^>=0.12 + default-language: Haskell2010 ghc-options: - -Wall - -Wcompat - -Wincomplete-record-updates - -Wincomplete-uni-patterns - -Wredundant-constraints + -Wall -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wredundant-constraints -fwrite-ide-info + -hiedir=.hie -Wunused-packages executable box-socket - main-is: box-socket.hs - hs-source-dirs: app + main-is: box-socket.hs + hs-source-dirs: app build-depends: - base >= 4.7 && < 5, - box >= 0.6 && < 0.7, - box-socket, - concurrency >= 1.11 && < 1.12, - generic-lens >= 2.0 && < 3, - lens >= 4.19 && < 4.20, - numhask >= 0.7 && < 0.8, - optparse-generic >= 1.3 && < 1.4, - default-language: Haskell2010 - ghc-options: - -funbox-strict-fields - -fforce-recomp - -threaded - -rtsopts - -with-rtsopts=-N + , base >=4.7 && <5 + , box ^>=0.7 + , box-socket + , concurrency ^>=1.11 + , generic-lens ^>=2.2 + , lens ^>=5.0 + , optparse-generic ^>=1.3 + , text ^>=1.2.4 -test-suite test - type: exitcode-stdio-1.0 - main-is: test.hs - hs-source-dirs: - test - build-depends: - base >=4.7 && <5, - box-socket, - doctest >= 0.16 && < 0.18, - numhask >= 0.7 && < 0.8, default-language: Haskell2010 ghc-options: - -Wall - -Wcompat - -Wincomplete-record-updates - -Wincomplete-uni-patterns - -Wredundant-constraints + -funbox-strict-fields -fforce-recomp -threaded -rtsopts + -with-rtsopts=-N -fwrite-ide-info -hiedir=.hie -Wunused-packages diff --git a/src/Box/Socket.hs b/src/Box/Socket.hs --- a/src/Box/Socket.hs +++ b/src/Box/Socket.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE StrictData #-} {-# OPTIONS_GHC -Wall #-} -- | Websocket components built with 'Box'es. @@ -24,11 +24,15 @@ 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 -import NumHask.Prelude hiding (bracket) -- | Socket configuration -- @@ -61,7 +65,7 @@ (\conn -> liftIO $ WS.sendClose conn ("Bye from connect!" :: Text)) ( \conn -> C.withAsync - (liftIO $ forever $ WS.sendPing conn ("ping" :: ByteString) >> sleep 30) + (liftIO $ forever $ WS.sendPing conn ("ping" :: BS.ByteString) >> sleep 30) (\_ -> action conn) ) @@ -116,7 +120,7 @@ commit c ( Left - ( "receiver: received: close: " <> show w <> " " <> show b + ( "receiver: received: close: " <> (pack . show) w <> " " <> (pack . show) b ) ) WS.ControlMessage _ -> go @@ -151,7 +155,7 @@ case msg of Nothing -> pure () Just msg' -> do - _ <- commit c $ "sender: sending: " <> (show msg' :: Text) + _ <- commit c $ "sender: sending: " <> ((pack . show) msg' :: Text) liftIO $ WS.sendTextData conn msg' -- | A receiver that responds based on received Text. diff --git a/src/Box/TCP.hs b/src/Box/TCP.hs --- a/src/Box/TCP.hs +++ b/src/Box/TCP.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE StrictData #-} {-# OPTIONS_GHC -Wall #-} -- | TCP Boxes. @@ -25,9 +24,15 @@ where import Box +import Control.Concurrent.Async import Control.Lens +import Control.Monad +import Data.ByteString (ByteString) +import Data.Functor +import Data.Text (Text, unpack) +import Data.Text.Encoding +import GHC.Generics import Network.Simple.TCP -import NumHask.Prelude hiding (check, handle) -- | TCP configuration -- @@ -141,7 +146,7 @@ e' <- emit e case e' of Just "q" -> pure () - Just x -> putStrLn ("badly handled: " <> x) + Just x -> putStrLn ("badly handled: " <> unpack x) Nothing -> pure () -- | @"echo: " <>@ Responder diff --git a/test/test.hs b/test/test.hs deleted file mode 100644 --- a/test/test.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# OPTIONS_GHC -Wall #-} - -module Main where - -import NumHask.Prelude -import Test.DocTest - -main :: IO () -main = doctest - [ "app/box-socket.hs", - "src/Box/Socket.hs", - "src/Box/TCP.hs" - ]