diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,36 @@ +# ws + +A really trivial websocket client for debugging and testing. + +## Installation / Building + +```bash +git clone http://github.com/athanclark/ws +``` + +Then depending on your build system: + +```bash +stack install +``` + +or + +```bash +cabal install +``` + +> It _should_ work with either, but if you run into issues, don't hesitate to +> file an issue. + + +## Usage + +``` +ws ws://echo.websocket.org/ + +ws://echo.websocket.org/> test +test +ws://echo.websocket.org/> ayoo +ayoo +``` diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,14 +1,22 @@ {-# LANGUAGE ScopedTypeVariables , FlexibleContexts + , NamedFieldPuns + , OverloadedStrings #-} module Main where import App (app) -import App.Types (Env (Env, envHost, envPort, envPath, envSecure), runAppM, handleInitException, InitException (NoURIAuthority, URIParseException)) +import App.Types (Env (..), runAppM, handleInitException, InitException (..)) import Options.Applicative (Parser, strArgument, ParserInfo, metavar, help, fullDesc, progDesc, header, helper, info, execParser) -import Network.URI (parseURI, uriAuthority, uriRegName, uriUserInfo, uriScheme, uriPath, uriPort) +import qualified Data.Text as T +import qualified Data.Vector as V +import qualified Data.Strict.Maybe as Strict +import Data.Strict.Tuple (Pair (..)) +import Data.URI (URI (..), parseURI) +import Data.URI.Auth (URIAuth (..), printURIAuth) +import Data.Attoparsec.Text (parseOnly) import Data.Monoid ((<>)) import Control.Monad.Catch (throwM, handle) @@ -62,28 +70,32 @@ putStrLn "Websocket URI: " getLine Just x -> pure x - case parseURI u of - Nothing -> throwM $ URIParseException u - Just u' -> - case uriAuthority u' of - Nothing -> throwM $ NoURIAuthority u - Just a -> - let host = uriUserInfo a - ++ uriRegName a - port = fromIntegral $ - let ps = drop 1 (uriPort a) - in if ps /= "" - then read ps - else if uriScheme u' == "wss:" - then 443 :: Int - else 80 - path' = - let p = uriPath u' - in if p == "" - then "/" - else p + case parseOnly parseURI (T.pack u) of + Left _ -> throwM $ URIParseException u + Right URI + { uriScheme + , uriAuthority = URIAuth + { uriAuthUser + , uriAuthHost + , uriAuthPort + } + , uriPath + , uriQuery + } -> + let host = T.unpack $ printURIAuth URIAuth {uriAuthUser,uriAuthHost,uriAuthPort = Strict.Nothing} + port = case uriAuthPort of + Strict.Nothing + | uriScheme == Strict.Just "wss" -> 433 + | otherwise -> 80 + Strict.Just p -> fromIntegral p + path' = T.unpack $ + "/" <> T.intercalate "/" (V.toList uriPath) <> + ( if V.null uriQuery + then "" + else "?" <> T.intercalate "&" ((\(k :!: mv) -> k <> Strict.maybe "" ("=" <>) mv) <$> V.toList uriQuery) + ) in pure Env { envHost = host , envPort = port , envPath = path' - , envSecure = uriScheme u' == "wss:" + , envSecure = uriScheme == Strict.Just "wss" } diff --git a/src/App.hs b/src/App.hs --- a/src/App.hs +++ b/src/App.hs @@ -7,7 +7,8 @@ import App.Types (AppM, Env (envSecure, envHost, envPort, envPath)) -import Network.WebSockets (ClientApp, DataMessage (Text, Binary), ConnectionException (CloseRequest, ConnectionClosed, ParseException), runClient, receiveDataMessage, sendTextData, sendClose) +import Network.WebSockets + (ClientApp, DataMessage (..), ConnectionException (..), runClient, receiveDataMessage, sendTextData, sendClose) import Wuss (runSecureClient) import qualified Data.Text as T @@ -64,7 +65,7 @@ let listen = forever $ do message <- receiveDataMessage conn let bs = case message of - Text x -> x + Text x _ -> x Binary x -> x print' $ case LT.decodeUtf8' bs of Left e -> "[Warn] UTF8 Decode Error: " ++ show e @@ -96,4 +97,7 @@ exitFailure ParseException s -> do print' $ "[Error] Websocket stream parse failure: " ++ s + exitFailure + UnicodeException s -> do + print' $ "[Error] Websocket couldn't parse unicode: " ++ s exitFailure diff --git a/src/App/Types.hs b/src/App/Types.hs --- a/src/App/Types.hs +++ b/src/App/Types.hs @@ -39,7 +39,6 @@ data InitException = URIParseException String - | NoURIAuthority String deriving (Generic, Show) instance Exception InitException @@ -50,7 +49,4 @@ case e of URIParseException u -> do hPutStr stderr $ "Error: not a valid URI string - `" ++ u ++ "`" - exitFailure - NoURIAuthority u -> do - hPutStr stderr $ "Error: no URI authority - `" ++ u ++ "`" exitFailure diff --git a/ws.cabal b/ws.cabal --- a/ws.cabal +++ b/ws.cabal @@ -1,44 +1,76 @@ -Name: ws -Version: 0.0.3 -Author: Athan Clark -Maintainer: Athan Clark -License: BSD3 -License-File: LICENSE -Synopsis: A simple CLI utility for interacting with a websocket --- Description: -Cabal-Version: >= 1.10 -Build-Type: Simple +-- This file has been generated from package.yaml by hpack version 0.21.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: b6402f73c4dc03d95debbd67a2f16770b5dac6fc20c70e0bfa61dcc04a2950f4 -Library - Default-Language: Haskell2010 - HS-Source-Dirs: src - GHC-Options: -Wall - Exposed-Modules: App - App.Types - Build-Depends: base >= 4.8 && < 5 - , async - , bytestring - , exceptions - , haskeline >= 0.7.4 - , mtl - , network - , network-uri - , text - , websockets - , wuss +name: ws +version: 0.0.4 +synopsis: A simple CLI utility for interacting with a websocket +description: Please see the README on Github at +category: Web +homepage: https://github.com/athanclark/ws#readme +bug-reports: https://github.com/athanclark/ws/issues +author: Athan Clark +maintainer: athan.clark@localcooking.com +copyright: 2018 Athan Clark +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 -Executable ws - Default-Language: Haskell2010 - HS-Source-Dirs: app - GHC-Options: -Wall -threaded - Main-Is: Main.hs - Build-Depends: base - , ws - , exceptions - , network-uri - , optparse-applicative +extra-source-files: + README.md +source-repository head + type: git + location: https://github.com/athanclark/ws -Source-Repository head - Type: git - Location: https://github.com/athanclark/ws.git +library + exposed-modules: + App + App.Types + other-modules: + Paths_ws + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + async + , attoparsec-uri + , base >=4.7 && <5 + , bytestring + , exceptions + , haskeline >=0.7.4 + , mtl + , network + , text + , websockets >=0.12 + , wuss + default-language: Haskell2010 + +executable ws + main-is: Main.hs + other-modules: + Paths_ws + hs-source-dirs: + app + ghc-options: -Wall -threaded -rtsopts -Wall -with-rtsopts=-N + build-depends: + async + , attoparsec + , attoparsec-uri + , base >=4.7 && <5 + , bytestring + , exceptions + , haskeline >=0.7.4 + , mtl + , network + , optparse-applicative + , strict + , text + , vector + , websockets >=0.12 + , ws + , wuss + default-language: Haskell2010