ws (empty) → 0.0.1

raw patch · 5 files changed

+312/−0 lines, 5 filesdep +asyncdep +basedep +bytestring

Dependencies added: async, base, bytestring, exceptions, haskeline, mtl, network, network-uri, optparse-applicative, text, websockets, ws, wuss

Files

• LICENSE +30/−0
• app/Main.hs +83/−0
• src/App.hs +98/−0
• src/App/Types.hs +57/−0
• ws.cabal +44/−0

@@ -0,0 +1,30 @@+Copyright (c) 2016, Athan Clark++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 Athan Clark 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.

@@ -0,0 +1,83 @@+{-# LANGUAGE+    ScopedTypeVariables+  , FlexibleContexts+  #-}++module Main where++import App (app)+import App.Types (Env (Env, envHost, envPort, envPath, envSecure), runAppM, handleInitException, InitException (NoURIAuthority, URIParseException))+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 Data.Monoid ((<>))+import Control.Monad.Catch (throwM, handle)+++-- * Options Parsing++-- | Application-wide options+newtype AppOpts = AppOpts+  { url :: String+  }++-- | Options for each field+appOpts :: Parser AppOpts+appOpts =+  AppOpts <$> urlOpt+  where+    urlOpt :: Parser String+    urlOpt = strArgument $+         metavar "TARGET"+      <> help "The websocket address to connect to - example:\+                \ `ws://localhost:3000/foo`"+++-- | Options for entire app+opts :: ParserInfo AppOpts+opts = info (helper <*> appOpts) $+    fullDesc+ <> progDesc "Connect to a websocket"+ <> header "ws - a CLI websocket tool"++++-- * Executable++main :: IO ()+main = do+  env <- handle handleInitException+       $ appOptsToEnv =<< execParser opts++  runAppM env app++++-- | Translate the CLI parsed options to a sane type we can use in our app+appOptsToEnv :: AppOpts -> IO Env+appOptsToEnv (AppOpts u) =+  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+          in  pure Env { envHost   = host+                       , envPort   = port+                       , envPath   = path'+                       , envSecure = uriScheme u' == "wss:"+                       }

@@ -0,0 +1,98 @@+{-# LANGUAGE+    FlexibleContexts+  , OverloadedStrings+  #-}++module App where++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 Wuss (runSecureClient)++import qualified Data.Text                  as T+import qualified Data.Text.Lazy             as LT+import qualified Data.Text.Lazy.Encoding    as LT+import qualified Data.ByteString.Lazy.Char8 as LBS+import Data.Monoid ((<>))+import Control.Monad (forever, unless, void)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Reader (ask)+import Control.Monad.Trans (lift)+import Control.Monad.Catch (handle)+import Control.Concurrent.Async (async, withAsync, wait)+import Control.Concurrent.Chan (Chan, newChan, writeChan, readChan)+import System.Exit (exitSuccess, exitFailure)+import System.Console.Haskeline (getExternalPrint, getInputLine)+++app :: AppM ()+app = do+  print' <- getExternalPrint+  env <- lift ask++  outgoingChan <- liftIO newChan++  _ <- liftIO $ async $+    handle (handleConnException print') $+      if envSecure env+      then runSecureClient+            (envHost env)+            (envPort env)+            (envPath env)+            (ws print' outgoingChan)+      else runClient+            (envHost env)+            (fromIntegral $ envPort env)+            (envPath env)+            (ws print' outgoingChan)++  forever $ do+    mx <- getInputLine $ T.unpack $ (if envSecure env then "wss" else "ws")+                           <> "://" <> T.pack (envHost env)+                           <> ":" <> T.pack (show (envPort env)) <> T.pack (envPath env) <> "> "+    case mx of+      Nothing -> pure ()+      Just x -> liftIO $ writeChan outgoingChan x+  where+    -- totally ripped off from+    -- https://hackage.haskell.org/package/wuss-1.0.4/docs/Wuss.html+    ws :: (String -> IO ()) -> Chan String -> ClientApp ()+    ws print' outgoingChan conn = do+      -- always listen for incoming messages in a separate thread+      let listen = forever $ do+            message <- receiveDataMessage conn+            let bs = case message of+                      Text   x -> x+                      Binary x -> x+            print' $ case LT.decodeUtf8' bs of+              Left e -> "[Warn] UTF8 Decode Error: " ++ show e+              Right t -> LT.unpack t++      -- always listen for outgoing messages in the main thread+      let sender = forever $ do+            userInput <- readChan outgoingChan+            unless (userInput == "") $+              sendTextData conn (T.pack userInput)++      withAsync listen $ \l ->+        withAsync sender $ \s -> do+          void $ wait l+          void $ wait s++      sendClose conn ("Bye from ws!" :: T.Text)+++handleConnException :: (String -> IO ()) -> ConnectionException -> IO a+handleConnException print' e =+  case e of+    CloseRequest c m -> do+      print' $ "[Info] Closing with code " ++ show c+            ++ " and message " ++ show m+      exitSuccess+    ConnectionClosed -> do+      print' "[Error] Connection closed unexpectedly"+      exitFailure+    ParseException s -> do+      print' $ "[Error] Websocket stream parse failure: " ++ s+      exitFailure

@@ -0,0 +1,57 @@+{-# LANGUAGE+    ConstraintKinds+  , FlexibleContexts+  , DeriveGeneric+  #-}++module App.Types where++import Control.Monad.Reader (ReaderT (runReaderT), MonadReader)+import Control.Monad.Catch (Exception)+import Control.Monad.IO.Class (MonadIO)++import System.IO (hPutStr, stderr)+import System.Exit (exitFailure)+import System.Console.Haskeline (InputT, runInputT, defaultSettings)+import Network.Socket (HostName, PortNumber)++import GHC.Generics (Generic)+++-- * Config Data++data Env = Env+  { envHost    :: HostName+  , envPort    :: PortNumber+  , envPath    :: String+  , envSecure  :: Bool+  } deriving (Show, Eq)+++-- * Effects Stack++type AppM = InputT (ReaderT Env IO)++runAppM :: Env -> AppM a -> IO a+runAppM env x = runReaderT (runInputT defaultSettings x) env+++-- * Exceptions++data InitException+  = URIParseException String+  | NoURIAuthority String+  deriving (Generic, Show)++instance Exception InitException+++handleInitException :: InitException -> IO a+handleInitException e =+  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

@@ -0,0 +1,44 @@+Name:                   ws+Version:                0.0.1+Author:                 Athan Clark <athan.clark@gmail.com>+Maintainer:             Athan Clark <athan.clark@gmail.com>+License:                BSD3+License-File:           LICENSE+Synopsis:               A simple CLI utility for interacting with a websocket+-- Description:+Cabal-Version:          >= 1.10+Build-Type:             Simple++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++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+++Source-Repository head+  Type:                 git+  Location:             https://github.com/athanclark/ws.git