{-|
Module: IHP.WebSocket
Description: Building blocks for websocket applications
Copyright: (c) digitally induced GmbH, 2020
-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module IHP.WebSocket
( WSApp (..)
, startWSApp
, setState
, getState
, receiveData
, receiveDataMessage
, sendTextData
)
where

import IHP.Prelude
import qualified Network.WebSockets as Websocket
import qualified Network.Wai.Handler.WebSockets as Websocket
import IHP.ApplicationContext
import IHP.Controller.RequestContext
import qualified Data.UUID.V4 as UUID
import qualified Data.UUID as UUID
import qualified Data.Maybe as Maybe
import qualified Control.Exception as Exception
import IHP.Controller.Context

class WSApp state where
    initialState :: state

    run :: (?state :: IORef state, ?context :: ControllerContext, ?applicationContext :: ApplicationContext, ?modelContext :: ModelContext, ?connection :: Websocket.Connection) => IO ()
    run = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    onPing :: (?state :: IORef state, ?context :: ControllerContext, ?applicationContext :: ApplicationContext, ?modelContext :: ModelContext, ?connection :: Websocket.Connection) => IO ()
    onPing = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    onClose :: (?state :: IORef state, ?context :: ControllerContext, ?applicationContext :: ApplicationContext, ?modelContext :: ModelContext, ?connection :: Websocket.Connection) => IO ()
    onClose = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

startWSApp :: forall state. (WSApp state, ?applicationContext :: ApplicationContext, ?requestContext :: RequestContext, ?context :: ControllerContext, ?modelContext :: ModelContext) => Websocket.Connection -> IO ()
startWSApp :: Connection -> IO ()
startWSApp Connection
connection = do
    IORef state
state <- state -> IO (IORef state)
forall a. a -> IO (IORef a)
newIORef (WSApp state => state
forall state. WSApp state => state
initialState @state)
    let ?state = state
    let ?connection = connection
    let
        handleException :: ConnectionException -> IO ()
handleException ConnectionException
Websocket.ConnectionClosed = (WSApp state, ?state::IORef state, ?context::ControllerContext,
 ?applicationContext::ApplicationContext,
 ?modelContext::ModelContext, ?connection::Connection) =>
IO ()
forall state.
(WSApp state, ?state::IORef state, ?context::ControllerContext,
 ?applicationContext::ApplicationContext,
 ?modelContext::ModelContext, ?connection::Connection) =>
IO ()
onClose @state
        handleException (Websocket.CloseRequest {}) = (WSApp state, ?state::IORef state, ?context::ControllerContext,
 ?applicationContext::ApplicationContext,
 ?modelContext::ModelContext, ?connection::Connection) =>
IO ()
forall state.
(WSApp state, ?state::IORef state, ?context::ControllerContext,
 ?applicationContext::ApplicationContext,
 ?modelContext::ModelContext, ?connection::Connection) =>
IO ()
onClose @state
        handleException ConnectionException
e = Text -> IO ()
forall a. Text -> a
error (Text
"Unhandled Websocket exception: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ConnectionException -> Text
forall a. Show a => a -> Text
show ConnectionException
e)
    Either SomeException ()
result <- IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
Exception.try ((Connection -> Int -> IO () -> IO () -> IO ()
forall a. Connection -> Int -> IO () -> IO a -> IO a
Websocket.withPingThread Connection
connection Int
30 ((WSApp state, ?state::IORef state, ?context::ControllerContext,
 ?applicationContext::ApplicationContext,
 ?modelContext::ModelContext, ?connection::Connection) =>
IO ()
forall state.
(WSApp state, ?state::IORef state, ?context::ControllerContext,
 ?applicationContext::ApplicationContext,
 ?modelContext::ModelContext, ?connection::Connection) =>
IO ()
onPing @state) ((WSApp state, ?state::IORef state, ?context::ControllerContext,
 ?applicationContext::ApplicationContext,
 ?modelContext::ModelContext, ?connection::Connection) =>
IO ()
forall state.
(WSApp state, ?state::IORef state, ?context::ControllerContext,
 ?applicationContext::ApplicationContext,
 ?modelContext::ModelContext, ?connection::Connection) =>
IO ()
run @state)) IO () -> (ConnectionException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch` ConnectionException -> IO ()
handleException)
    case Either SomeException ()
result of
        Left (Exception.SomeException e
e) -> Text -> IO ()
putStrLn (e -> Text
forall a. Show a => a -> Text
tshow e
e)
        Right ()
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

setState :: (?state :: IORef state) => state -> IO ()
setState :: state -> IO ()
setState state
newState = IORef state -> state -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef ?state::IORef state
IORef state
?state state
newState

getState :: (?state :: IORef state) => IO state
getState :: IO state
getState = IORef state -> IO state
forall a. IORef a -> IO a
readIORef ?state::IORef state
IORef state
?state

receiveData :: (?connection :: Websocket.Connection, Websocket.WebSocketsData a) => IO a
receiveData :: IO a
receiveData = Connection -> IO a
forall a. WebSocketsData a => Connection -> IO a
Websocket.receiveData ?connection::Connection
Connection
?connection

receiveDataMessage :: (?connection :: Websocket.Connection) => IO Websocket.DataMessage
receiveDataMessage :: IO DataMessage
receiveDataMessage = Connection -> IO DataMessage
Websocket.receiveDataMessage ?connection::Connection
Connection
?connection

sendTextData :: (?connection :: Websocket.Connection, Websocket.WebSocketsData text) => text -> IO ()
sendTextData :: text -> IO ()
sendTextData text
text = Connection -> text -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
Websocket.sendTextData ?connection::Connection
Connection
?connection text
text

instance Websocket.WebSocketsData UUID where
    fromDataMessage :: DataMessage -> UUID
fromDataMessage (Websocket.Text ByteString
byteString Maybe Text
_) = ByteString -> Maybe UUID
UUID.fromLazyASCIIBytes ByteString
byteString Maybe UUID -> (Maybe UUID -> UUID) -> UUID
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Maybe UUID -> UUID
forall a. HasCallStack => Maybe a -> a
Maybe.fromJust
    fromDataMessage (Websocket.Binary ByteString
byteString) = ByteString -> Maybe UUID
UUID.fromLazyASCIIBytes ByteString
byteString Maybe UUID -> (Maybe UUID -> UUID) -> UUID
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Maybe UUID -> UUID
forall a. HasCallStack => Maybe a -> a
Maybe.fromJust
    fromLazyByteString :: ByteString -> UUID
fromLazyByteString ByteString
byteString = ByteString -> Maybe UUID
UUID.fromLazyASCIIBytes ByteString
byteString Maybe UUID -> (Maybe UUID -> UUID) -> UUID
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Maybe UUID -> UUID
forall a. HasCallStack => Maybe a -> a
Maybe.fromJust
    toLazyByteString :: UUID -> ByteString
toLazyByteString = UUID -> ByteString
UUID.toLazyASCIIBytes