{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}

{- |
Module      : Buttplug.Core.Connector
Copyright   : (c) James Sully, 2020-2021
License     : BSD 3-Clause
Maintainer  : sullyj3@gmail.com
Stability   : experimental
Portability : untested

Provides methods of connecting to a Buttplug Server
-}
module Buttplug.Core.Connector where

import           Control.Exception
import           System.IO.Error              ( isDoesNotExistError )
import           Data.ByteString.Lazy         ( fromStrict, toStrict )
import           Data.ByteString              ( ByteString )
import qualified Network.WebSockets           as WS
import           Network.WebSockets.Stream    ( makeStream )
import qualified Wuss
import           Network.Connection           ( TLSSettings(..)
                                              , ConnectionParams(..)
                                              , initConnectionContext
                                              , connectTo
                                              , connectionGetChunk
                                              , connectionPut )
import           Network.Socket               ( withSocketsDo, PortNumber )
import           Data.Aeson                   ( encode
                                              , decode )

import           Buttplug.Core.Message

-- TODO currently websocket connector runclient blocks indefinitely if host
-- exists but port is unavailable. Need to think about providing an API to
-- allow for time limits

-- | Abstracts over methods of connecting to a buttplug server. The connector 
-- contains all the information necessary for establishing a connection.
class Connector c where
  -- | A Connector determines a unique connection type that is used for 
  -- communication.
  type Connection c = conn | conn -> c

  -- | Main entry point for communicating with the Buttplug server. Establish a
  -- connection to the server and pass the connection handle to the 
  -- continuation.
  runClient :: c -> (Connection c -> IO a) -> IO a

  -- | Send 'Message's to the server. In the Buttplug protocol, all messages 
  -- are wrapped in a JSON array (here a Haskell list) to facilitate sending 
  -- multiple messages simultaneously. Use 'sendMessage' to send a single 
  -- message.
  sendMessages :: Connection c -> [Message] -> IO ()

  -- | receive 'Message's from the server
  receiveMsgs :: Connection c -> IO [Message]

-- | Send the server a single 'Message'
sendMessage :: forall c. Connector c => Connection c -> Message -> IO ()
sendMessage :: Connection c -> Message -> IO ()
sendMessage Connection c
conn Message
msg = Connection c -> [Message] -> IO ()
forall c. Connector c => Connection c -> [Message] -> IO ()
sendMessages @c Connection c
conn [Message
msg]

-- | Connect to the buttplug server using websockets
data WebSocketConnector =
    InsecureWebSocketConnector { WebSocketConnector -> String
insecureWSConnectorHost :: String
                               , WebSocketConnector -> Int
insecureWSConnectorPort :: Int }
  | SecureWebSocketConnector { WebSocketConnector -> String
secureWSConnectorHost :: String
                             , WebSocketConnector -> PortNumber
secureWSConnectorPort :: PortNumber
                             , WebSocketConnector -> Bool
secureWSBypassCertVerify :: Bool }

-- I'm not incredibly psyched about this design, but it's not immediately
-- obvious to me how to improve it.

-- | An exception type abstracting over the exceptions that might arise in the
-- course of communication with the buttplug server. 'Connector' instances in
-- general should throw these rather than Exceptions specific to the connection
-- type.
data ConnectorException = ConnectionFailed String
                        | UnexpectedConnectionClosed
                        | ConnectionClosedNormally
                        | ReceivedInvalidMessage ByteString
                        | OtherConnectorError String
  deriving Int -> ConnectorException -> ShowS
[ConnectorException] -> ShowS
ConnectorException -> String
(Int -> ConnectorException -> ShowS)
-> (ConnectorException -> String)
-> ([ConnectorException] -> ShowS)
-> Show ConnectorException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConnectorException] -> ShowS
$cshowList :: [ConnectorException] -> ShowS
show :: ConnectorException -> String
$cshow :: ConnectorException -> String
showsPrec :: Int -> ConnectorException -> ShowS
$cshowsPrec :: Int -> ConnectorException -> ShowS
Show

instance Exception ConnectorException


instance Connector WebSocketConnector where
  type Connection WebSocketConnector = WS.Connection

  sendMessages :: WS.Connection -> [Message] -> IO ()
  sendMessages :: Connection -> [Message] -> IO ()
sendMessages Connection
wsCon [Message]
msgs = (ConnectionException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle ConnectionException -> IO ()
forall a. ConnectionException -> IO a
handleWSConnException (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
WS.sendTextData Connection
wsCon ([Message] -> ByteString
forall a. ToJSON a => a -> ByteString
encode [Message]
msgs)

  receiveMsgs :: WS.Connection -> IO [Message]
  receiveMsgs :: Connection -> IO [Message]
receiveMsgs Connection
wsCon = (ConnectionException -> IO [Message])
-> IO [Message] -> IO [Message]
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle ConnectionException -> IO [Message]
forall a. ConnectionException -> IO a
handleWSConnException (IO [Message] -> IO [Message]) -> IO [Message] -> IO [Message]
forall a b. (a -> b) -> a -> b
$ do
    ByteString
received <- Connection -> IO ByteString
forall a. WebSocketsData a => Connection -> IO a
WS.receiveData Connection
wsCon
    case ByteString -> Maybe [Message]
forall a. FromJSON a => ByteString -> Maybe a
decode (ByteString -> Maybe [Message]) -> ByteString -> Maybe [Message]
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
fromStrict ByteString
received :: Maybe [Message] of
      Just [Message]
msgs -> [Message] -> IO [Message]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Message]
msgs
      Maybe [Message]
Nothing -> ConnectorException -> IO [Message]
forall e a. Exception e => e -> IO a
throwIO (ConnectorException -> IO [Message])
-> ConnectorException -> IO [Message]
forall a b. (a -> b) -> a -> b
$ ByteString -> ConnectorException
ReceivedInvalidMessage ByteString
received

  runClient :: WebSocketConnector -> (WS.Connection -> IO a) -> IO a
  runClient :: WebSocketConnector -> (Connection -> IO a) -> IO a
runClient WebSocketConnector
connector Connection -> IO a
client =
    (IOError -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle IOError -> IO a
forall a. IOError -> IO a
handleSockConnFailed (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ (HandshakeException -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle HandshakeException -> IO a
forall a. HandshakeException -> IO a
handleWSConnFailed (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$
      IO a -> IO a
forall a. IO a -> IO a
withSocketsDo (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ case WebSocketConnector
connector of
        InsecureWebSocketConnector String
host Int
port ->
           String -> Int -> String -> (Connection -> IO a) -> IO a
forall a. String -> Int -> String -> ClientApp a -> IO a
WS.runClient String
host Int
port String
"/" Connection -> IO a
client
        SecureWebSocketConnector String
host PortNumber
port Bool
bypassCertVerify ->
          if Bool
bypassCertVerify
            then do
              -- adapted from https://hackage.haskell.org/package/wuss-1.1.18/docs/Wuss.html#v:runSecureClientWith
              let options :: ConnectionOptions
options = ConnectionOptions
WS.defaultConnectionOptions
              let headers :: [a]
headers = []
              let tlsSettings :: TLSSettings
tlsSettings = TLSSettingsSimple :: Bool -> Bool -> Bool -> TLSSettings
TLSSettingsSimple
                    -- This is the important setting.
                    { settingDisableCertificateValidation :: Bool
settingDisableCertificateValidation = Bool
True
                    , settingDisableSession :: Bool
settingDisableSession = Bool
False
                    , settingUseServerName :: Bool
settingUseServerName = Bool
False
                    }
              let connectionParams :: ConnectionParams
connectionParams = ConnectionParams :: String
-> PortNumber
-> Maybe TLSSettings
-> Maybe ProxySettings
-> ConnectionParams
ConnectionParams
                    { connectionHostname :: String
connectionHostname = String
host
                    , connectionPort :: PortNumber
connectionPort = PortNumber
port
                    , connectionUseSecure :: Maybe TLSSettings
connectionUseSecure = TLSSettings -> Maybe TLSSettings
forall a. a -> Maybe a
Just TLSSettings
tlsSettings
                    , connectionUseSocks :: Maybe ProxySettings
connectionUseSocks = Maybe ProxySettings
forall a. Maybe a
Nothing
                    }

              ConnectionContext
context <- IO ConnectionContext
initConnectionContext
              Connection
connection <- ConnectionContext -> ConnectionParams -> IO Connection
connectTo ConnectionContext
context ConnectionParams
connectionParams
              Stream
stream <- IO (Maybe ByteString) -> (Maybe ByteString -> IO ()) -> IO Stream
makeStream
                  ((ByteString -> Maybe ByteString)
-> IO ByteString -> IO (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Connection -> IO ByteString
connectionGetChunk Connection
connection))
                  (IO () -> (ByteString -> IO ()) -> Maybe ByteString -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Connection -> ByteString -> IO ()
connectionPut Connection
connection (ByteString -> IO ())
-> (ByteString -> ByteString) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
toStrict))
              Stream
-> String
-> String
-> ConnectionOptions
-> Headers
-> (Connection -> IO a)
-> IO a
forall a.
Stream
-> String
-> String
-> ConnectionOptions
-> Headers
-> ClientApp a
-> IO a
WS.runClientWithStream Stream
stream String
host String
"/" ConnectionOptions
options Headers
forall a. [a]
headers Connection -> IO a
client
            else String -> PortNumber -> String -> (Connection -> IO a) -> IO a
forall a. String -> PortNumber -> String -> ClientApp a -> IO a
Wuss.runSecureClient String
host PortNumber
port String
"/" Connection -> IO a
client

--         --
-- Private --
--         --

-- | Convert 'WS.HandshakeException' into 'ConnectionFailed'
handleWSConnFailed :: WS.HandshakeException -> IO a
handleWSConnFailed :: HandshakeException -> IO a
handleWSConnFailed HandshakeException
e = ConnectorException -> IO a
forall e a. Exception e => e -> IO a
throwIO (String -> ConnectorException
ConnectionFailed (String -> ConnectorException) -> String -> ConnectorException
forall a b. (a -> b) -> a -> b
$ HandshakeException -> String
forall a. Show a => a -> String
show HandshakeException
e)

-- | Convert socket connection issues into 'ConnectionFailed'
handleSockConnFailed :: IOError -> IO a
handleSockConnFailed :: IOError -> IO a
handleSockConnFailed IOError
e
  | IOError -> Bool
isDoesNotExistError IOError
e = ConnectorException -> IO a
forall e a. Exception e => e -> IO a
throwIO (String -> ConnectorException
ConnectionFailed (String -> ConnectorException) -> String -> ConnectorException
forall a b. (a -> b) -> a -> b
$ IOError -> String
forall a. Show a => a -> String
show IOError
e)
  | Bool
otherwise             = IOError -> IO a
forall e a. Exception e => e -> IO a
throwIO IOError
e

-- | Convert websocket specific connection exceptions into 'ConnectorException'
handleWSConnException :: WS.ConnectionException -> IO a
handleWSConnException :: ConnectionException -> IO a
handleWSConnException = \case
  ConnectionException
WS.ConnectionClosed    -> ConnectorException -> IO a
forall e a. Exception e => e -> IO a
throwIO ConnectorException
UnexpectedConnectionClosed
  WS.CloseRequest Word16
1000 ByteString
_ -> ConnectorException -> IO a
forall e a. Exception e => e -> IO a
throwIO ConnectorException
ConnectionClosedNormally
  ConnectionException
e                      -> ConnectorException -> IO a
forall e a. Exception e => e -> IO a
throwIO (ConnectorException -> IO a) -> ConnectorException -> IO a
forall a b. (a -> b) -> a -> b
$ String -> ConnectorException
OtherConnectorError (ConnectionException -> String
forall a. Show a => a -> String
show ConnectionException
e)