{-# LANGUAGE
FlexibleContexts
, OverloadedStrings
#-}
module App where
import App.Types (AppM, Env (envSecure, envHost, envPort, envPath))
import Network.WebSockets
(ClientApp, DataMessage (..), ConnectionException (..), 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 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, link, 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
mainThread <- 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)
liftIO (link mainThread)
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
ws :: (String -> IO ()) -> Chan String -> ClientApp ()
ws print' outgoingChan conn = do
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
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
UnicodeException s -> do
print' $ "[Error] Websocket couldn't parse unicode: " ++ s
exitFailure