From 9bdcbc315f9d60c9aeb1c0191aab2d00c44a6077 Mon Sep 17 00:00:00 2001
From: Dennis Frieberg <nerfingen@yahoo.de>
Date: Sat, 5 Sep 2020 02:22:22 +0200
Subject: [PATCH] exceptions are evil, catch them if you can

---
 app/WebSocketApp.hs    | 101 ++++++++++++++++++++++++++++++++++++++++-
 package.yaml           |   3 ++
 tickLeisteServer.cabal |   9 ++++
 3 files changed, 111 insertions(+), 2 deletions(-)

diff --git a/app/WebSocketApp.hs b/app/WebSocketApp.hs
index cfbce16..7eb8fa7 100644
--- a/app/WebSocketApp.hs
+++ b/app/WebSocketApp.hs
@@ -1,5 +1,102 @@
-module WebSocketApp () where
+{-# LANGUAGE OverloadedStrings #-}
 
+module WebSocketApp (newServerState, ServerState) where
 
+-- Maybe strict MVar?? but then we need NFData instenaces for TickLeiste
+import Control.Concurrent.MVar
+import Control.Exception
 import Data.Aeson.TickLeiste
-import
+import qualified Data.ByteString as B
+import qualified Data.Map.Strict as M
+import Data.Maybe
+import qualified Data.Text as T
+import qualified Data.TickLeiste as TL
+import qualified Data.UUID as U
+import qualified Data.UUID.V4 as U
+import qualified Network.WebSockets as WS
+import System.IO
+
+----------------------------------------------------------------------------------
+------------------------ NEVER USE putMVar OR takeMVar ---------------------------
+----------------------------------------------------------------------------------
+
+-- if use ask yourself why this warning above me exists, this code relies upon the
+-- atomicity of modifyMVar, which is only the case if no one produces MVar. It is
+-- realy easy to archive this using putMVar. So not using it will make reasoning
+-- about the code much simpler. takeMVar on the other hand may produce deadlocks
+-- as an MVar is gone and nobody will produce a new one.
+-- putMVar and takeMVar are not evil in general, but it contradicts the way this
+-- code uses MVar to synchronize.
+-- In theory you could write fine code using them, but then you need to make sure
+-- to use them as a pair and mask yourself from asynchronous exceptions. But
+-- that is basically a reimplementation of modifyMVar
+
+-- maybe this should be T.Text instead, but right now I try
+-- to get away without the need of parsing the request Path
+-- in any way. If we need, then we should probably change this to T.Text
+type SessionId = B.ByteString
+
+-- we only use the uuids here, because 'WS.WS.Connection' has no Eq, and we need
+-- to delete clients
+type Client = (U.UUID, WS.Connection)
+
+type SessionState = (TL.TickLeiste, [Client], Integer)
+
+type ServerState = M.Map SessionId (MVar SessionState)
+
+newServerState :: ServerState
+newServerState = M.empty
+
+application :: MVar ServerState -> WS.ServerApp
+application ssMV pending = do
+  -- maybe we want to check that the Path has a maximum length or something
+  let requestPath = WS.requestPath $ WS.pendingRequest pending
+  if B.null requestPath
+    then do
+      -- TODO reject Body should probably not empty...
+      -- this may need a better logic
+      WS.rejectRequestWith pending WS.defaultRejectRequest
+    else do
+      conn <- WS.acceptRequest pending
+      WS.withPingThread conn 30 (return ()) $ do
+        clientUUID <- U.nextRandom
+        bracket
+          (addClient requestPath (clientUUID, conn) ssMV)
+          (const $ removeClient requestPath (clientUUID, conn) ssMV)
+          (eventHandler conn)
+
+eventHandler :: WS.Connection -> MVar SessionState -> IO ()
+eventHandler = undefined
+
+addClient :: SessionId -> Client -> MVar ServerState -> IO (MVar SessionState)
+addClient sessionId client serverStateMVar = modifyMVar serverStateMVar $ \serverState ->
+  maybe
+    ( do
+        let sessionState = (TL.newTickLeiste, [client], 1)
+        sessionStateMVar <- newMVar sessionState
+        let serverState' = M.insert sessionId sessionStateMVar serverState
+        return (serverState', sessionStateMVar)
+    )
+    ( \sessionStateMVar -> do
+        modifyMVar_ sessionStateMVar (\(tl, cls, sem) -> return (tl, client : cls, sem + 1))
+        return (serverState, sessionStateMVar)
+    )
+    (serverState M.!? sessionId)
+
+removeClient :: SessionId -> Client -> MVar ServerState -> IO ()
+removeClient sessionId client serverStateMVar = modifyMVar_ serverStateMVar $ \serverState ->
+  maybe
+    ( do
+        hPutStrLn stderr "Tried to remove client, but the session didn't exist anymore, THIS IS A BUG"
+        return serverState
+    )
+    ( \sessionStateMVar -> do
+        modifyMVar sessionStateMVar $ \(tl, cls, sem) -> do
+          let sem' = sem - 1
+              removedClient = (tl, filter ((/= fst client) . fst) cls, sem')
+          if sem - 1 == 0
+            then return (removedClient, sessionId `M.delete` serverState)
+            else do
+              return (removedClient, serverState)
+    )
+    (serverState M.!? sessionId)
diff --git a/package.yaml b/package.yaml
index 2878a7a..538bfd1 100644
--- a/package.yaml
+++ b/package.yaml
@@ -25,6 +25,9 @@ dependencies:
 - aeson
 - uuid
 - text
+- websockets
+- strict-concurrency
+- bytestring
 
 library:
   source-dirs: src
diff --git a/tickLeisteServer.cabal b/tickLeisteServer.cabal
index c6ff64a..f65c514 100644
--- a/tickLeisteServer.cabal
+++ b/tickLeisteServer.cabal
@@ -34,9 +34,12 @@ library
   build-depends:
       aeson
     , base >=4.7 && <5
+    , bytestring
+    , strict-concurrency
     , text
     , tickLeiste
     , uuid
+    , websockets
   default-language: Haskell2010
 
 executable tickLeisteServer
@@ -50,10 +53,13 @@ executable tickLeisteServer
   build-depends:
       aeson
     , base >=4.7 && <5
+    , bytestring
+    , strict-concurrency
     , text
     , tickLeiste
     , tickLeisteServer
     , uuid
+    , websockets
   default-language: Haskell2010
 
 test-suite tickLeisteServer-test
@@ -67,8 +73,11 @@ test-suite tickLeisteServer-test
   build-depends:
       aeson
     , base >=4.7 && <5
+    , bytestring
+    , strict-concurrency
     , text
     , tickLeiste
     , tickLeisteServer
     , uuid
+    , websockets
   default-language: Haskell2010