{-# 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 :: AppM ()
app = do
String -> IO ()
print' <- forall (m :: * -> *). MonadIO m => InputT m (String -> IO ())
getExternalPrint
Env
env <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall r (m :: * -> *). MonadReader r m => m r
ask
Chan String
outgoingChan <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO (Chan a)
newChan
Async ()
mainThread <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO (Async a)
async forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle (forall a. (String -> IO ()) -> ConnectionException -> IO a
handleConnException String -> IO ()
print') forall a b. (a -> b) -> a -> b
$
if Env -> Bool
envSecure Env
env
then forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> PortNumber -> String -> ClientApp a -> m a
runSecureClient
(Env -> String
envHost Env
env)
(Env -> PortNumber
envPort Env
env)
(Env -> String
envPath Env
env)
((String -> IO ()) -> Chan String -> ClientApp ()
ws String -> IO ()
print' Chan String
outgoingChan)
else forall a. String -> Int -> String -> ClientApp a -> IO a
runClient
(Env -> String
envHost Env
env)
(forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Env -> PortNumber
envPort Env
env)
(Env -> String
envPath Env
env)
((String -> IO ()) -> Chan String -> ClientApp ()
ws String -> IO ()
print' Chan String
outgoingChan)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. Async a -> IO ()
link Async ()
mainThread)
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
Maybe String
mx <- forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m (Maybe String)
getInputLine forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ (if Env -> Bool
envSecure Env
env then Text
"wss" else Text
"ws")
forall a. Semigroup a => a -> a -> a
<> Text
"://" forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Env -> String
envHost Env
env)
forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show (Env -> PortNumber
envPort Env
env)) forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Env -> String
envPath Env
env) forall a. Semigroup a => a -> a -> a
<> Text
"> "
case Maybe String
mx of
Maybe String
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just String
x -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Chan a -> a -> IO ()
writeChan Chan String
outgoingChan String
x
where
ws :: (String -> IO ()) -> Chan String -> ClientApp ()
ws :: (String -> IO ()) -> Chan String -> ClientApp ()
ws String -> IO ()
print' Chan String
outgoingChan Connection
conn = do
let listen :: IO b
listen = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
DataMessage
message <- Connection -> IO DataMessage
receiveDataMessage Connection
conn
let bs :: ByteString
bs = case DataMessage
message of
Text ByteString
x Maybe Text
_ -> ByteString
x
Binary ByteString
x -> ByteString
x
String -> IO ()
print' forall a b. (a -> b) -> a -> b
$ case ByteString -> Either UnicodeException Text
LT.decodeUtf8' ByteString
bs of
Left UnicodeException
e -> String
"[Warn] UTF8 Decode Error: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show UnicodeException
e
Right Text
t -> Text -> String
LT.unpack Text
t
let sender :: IO b
sender = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
String
userInput <- forall a. Chan a -> IO a
readChan Chan String
outgoingChan
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String
userInput forall a. Eq a => a -> a -> Bool
== String
"") forall a b. (a -> b) -> a -> b
$
forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
conn (String -> Text
T.pack String
userInput)
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync forall {b}. IO b
listen forall a b. (a -> b) -> a -> b
$ \Async Any
l ->
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync forall {b}. IO b
sender forall a b. (a -> b) -> a -> b
$ \Async Any
s -> do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. Async a -> IO a
wait Async Any
l
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. Async a -> IO a
wait Async Any
s
forall a. WebSocketsData a => Connection -> a -> IO ()
sendClose Connection
conn (Text
"Bye from ws!" :: T.Text)
handleConnException :: (String -> IO ()) -> ConnectionException -> IO a
handleConnException :: forall a. (String -> IO ()) -> ConnectionException -> IO a
handleConnException String -> IO ()
print' ConnectionException
e =
case ConnectionException
e of
CloseRequest Word16
c ByteString
m -> do
String -> IO ()
print' forall a b. (a -> b) -> a -> b
$ String
"[Info] Closing with code " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word16
c
forall a. [a] -> [a] -> [a]
++ String
" and message " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ByteString
m
forall {b}. IO b
exitSuccess
ConnectionException
ConnectionClosed -> do
String -> IO ()
print' String
"[Error] Connection closed unexpectedly"
forall {b}. IO b
exitFailure
ParseException String
s -> do
String -> IO ()
print' forall a b. (a -> b) -> a -> b
$ String
"[Error] Websocket stream parse failure: " forall a. [a] -> [a] -> [a]
++ String
s
forall {b}. IO b
exitFailure
UnicodeException String
s -> do
String -> IO ()
print' forall a b. (a -> b) -> a -> b
$ String
"[Error] Websocket couldn't parse unicode: " forall a. [a] -> [a] -> [a]
++ String
s
forall {b}. IO b
exitFailure