From 2a85c321fa10b3cc517e9eb13ed53e9ba5138a55 Mon Sep 17 00:00:00 2001
From: Marc Scholten <marc@digitallyinduced.com>
Date: Sat, 3 Feb 2024 14:34:21 +0100
Subject: [PATCH] Use built-in ping pong mechanism of the latest version of
 websockets

---
 IHP/WebSocket.hs                           | 37 ++--------------------
 NixSupport/haskell-packages/websockets.nix | 33 +++++++++++++++++++
 2 files changed, 36 insertions(+), 34 deletions(-)
 create mode 100644 NixSupport/haskell-packages/websockets.nix

diff --git a/IHP/WebSocket.hs b/IHP/WebSocket.hs
index f6548c21a..37789a6d8 100644
--- a/IHP/WebSocket.hs
+++ b/IHP/WebSocket.hs
@@ -18,6 +18,7 @@ where
 
 import IHP.Prelude
 import qualified Network.WebSockets as Websocket
+import Network.WebSockets.Connection.PingPong (withPingPong, defaultPingPongOptions)
 import IHP.ApplicationContext
 import IHP.Controller.RequestContext
 import qualified Data.UUID as UUID
@@ -60,20 +61,11 @@ class WSApp state where
     connectionOptions = WebSocket.defaultConnectionOptions
 
 startWSApp :: forall state. (WSApp state, ?applicationContext :: ApplicationContext, ?requestContext :: RequestContext, ?context :: ControllerContext, ?modelContext :: ModelContext) => Websocket.Connection -> IO ()
-startWSApp connection' = do
+startWSApp connection = do
     state <- newIORef (initialState @state)
-    lastPongAt <- getCurrentTime >>= newIORef
-
-
-    let connection = installPongHandler lastPongAt connection'
     let ?state = state
-    let ?connection = connection
-    let pingHandler = do
-            seconds <- secondsSinceLastPong lastPongAt
-            when (seconds > pingWaitTime * 2) (throwIO PongTimeout)
-            onPing @state
 
-    result <- Exception.try ((WebSocket.withPingThread connection pingWaitTime pingHandler (run @state)) `Exception.finally` onClose @state)
+    result <- Exception.try ((withPingPong defaultPingPongOptions connection (\connection -> let ?connection = connection in run @state)) `Exception.finally` (let ?connection = connection in onClose @state))
     case result of
         Left (e@Exception.SomeException{}) ->
             case Exception.fromException e of
@@ -117,26 +109,3 @@ instance Websocket.WebSocketsData UUID where
     fromLazyByteString byteString = UUID.fromLazyASCIIBytes byteString |> Maybe.fromJust
     toLazyByteString = UUID.toLazyASCIIBytes
 
-data PongTimeout
-    = PongTimeout
-    deriving (Show)
-
-instance Exception PongTimeout
-
-pingWaitTime :: Int
-pingWaitTime = 30
-
-installPongHandler :: IORef UTCTime -> WebSocket.Connection -> WebSocket.Connection
-installPongHandler lastPongAt connection =
-    connection { WebSocket.connectionOptions = connection.connectionOptions { WebSocket.connectionOnPong = connectionOnPong lastPongAt }  }
-
-connectionOnPong :: IORef UTCTime -> IO ()
-connectionOnPong lastPongAt = do
-    now <- getCurrentTime
-    writeIORef lastPongAt now
-
-secondsSinceLastPong :: IORef UTCTime -> IO Int
-secondsSinceLastPong lastPongAt = do
-    now <- getCurrentTime
-    last <- readIORef lastPongAt
-    pure $ ceiling $ nominalDiffTimeToSeconds $ diffUTCTime now last
diff --git a/NixSupport/haskell-packages/websockets.nix b/NixSupport/haskell-packages/websockets.nix
new file mode 100644
index 000000000..02c063040
--- /dev/null
+++ b/NixSupport/haskell-packages/websockets.nix
@@ -0,0 +1,33 @@
+{ mkDerivation, async, attoparsec, base, base64-bytestring, binary
+, bytestring, case-insensitive, containers, criterion, entropy
+, HUnit, lib, network, QuickCheck, random, SHA, streaming-commons
+, test-framework, test-framework-hunit, test-framework-quickcheck2
+, text
+}:
+mkDerivation {
+  pname = "websockets";
+  version = "0.13.0.0";
+  sha256 = "1da95b71akggyikbxdmja3gcaqrz8sp6ri5jrsyavc2ickvi9y4s";
+  isLibrary = true;
+  isExecutable = true;
+  libraryHaskellDepends = [
+    async attoparsec base base64-bytestring binary bytestring
+    case-insensitive containers entropy network random SHA
+    streaming-commons text
+  ];
+  testHaskellDepends = [
+    async attoparsec base base64-bytestring binary bytestring
+    case-insensitive containers entropy HUnit network QuickCheck random
+    SHA streaming-commons test-framework test-framework-hunit
+    test-framework-quickcheck2 text
+  ];
+  benchmarkHaskellDepends = [
+    async attoparsec base base64-bytestring binary bytestring
+    case-insensitive containers criterion entropy network random SHA
+    text
+  ];
+  doCheck = false;
+  homepage = "http://jaspervdj.be/websockets";
+  description = "A sensible and clean way to write WebSocket-capable servers in Haskell";
+  license = lib.licenses.bsd3;
+}
\ No newline at end of file