{-# 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
    -- totally ripped off from
    -- https://hackage.haskell.org/package/wuss-1.0.4/docs/Wuss.html
    ws :: (String -> IO ()) -> Chan String -> ClientApp ()
    ws :: (String -> IO ()) -> Chan String -> ClientApp ()
ws String -> IO ()
print' Chan String
outgoingChan Connection
conn = do
      -- always listen for incoming messages in a separate thread
      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

      -- always listen for outgoing messages in the main thread
      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