From fee479b47d192338133a22b1a267838f71ddbd55 Mon Sep 17 00:00:00 2001 From: George Thomas Date: Fri, 13 Aug 2021 15:19:53 +0100 Subject: [PATCH 1/7] Reject duplicate usernames --- haskell/src/Monpad.hs | 50 +++++++++++++++++++++++++++++-------------- haskell/src/Util.hs | 11 ++++++++++ 2 files changed, 45 insertions(+), 16 deletions(-) diff --git a/haskell/src/Monpad.hs b/haskell/src/Monpad.hs index 04bf366..16af1a1 100644 --- a/haskell/src/Monpad.hs +++ b/haskell/src/Monpad.hs @@ -35,6 +35,8 @@ import Data.Aeson (FromJSON, ToJSON, eitherDecode, encode) import Data.Aeson.Text (encodeToLazyText) import Data.Bifunctor import Data.ByteString.Char8 qualified as BS +import Data.Either.Combinators +import Data.Either.Extra import Data.Functor import Data.IORef import Data.List.NonEmpty (NonEmpty) @@ -44,7 +46,11 @@ import Data.Map qualified as Map import Data.Maybe import Data.Proxy import Data.Semigroup.Monad +import Data.Set (Set) +import Data.Set qualified as Set +import Data.String (fromString) import Data.Text (Text) +import Data.Text qualified as T import Data.Text.Encoding (encodeUtf8) import Data.Text.IO qualified as T import Data.Text.Lazy qualified as TL @@ -84,12 +90,14 @@ import Util newtype ClientID = ClientID Text deriving (Eq, Ord, Show) deriving newtype FromHttpApiData -validateUsername :: ClientID -> Maybe UsernameError -validateUsername u - | u == ClientID "" = Just EmptyUsername - | otherwise = Nothing +validateUsername :: MVar (Set ClientID) -> ClientID -> IO (Maybe UsernameError) +validateUsername users u = eitherToMaybe . swapEither <$> runExceptT do + when (u == ClientID "") $ throwError EmptyUsername + isNew <- liftIO $ modifyMVar users $ pure . setInsert' u + when isNew . throwError $ DuplicateUsername u data UsernameError = EmptyUsername + | DuplicateUsername ClientID deriving (Show) data Update a b @@ -141,10 +149,13 @@ loginHtml err imageUrl = doctypehtml_ . body_ imageStyle . form_ [action_ $ symb ] <> case err of Nothing -> [] Just EmptyUsername -> - [ p_ - [ style_ "color: red" ] + [ p_ [ style_ "color: red" ] "Empty usernames are not allowed!" ] + Just (DuplicateUsername (ClientID u)) -> + [ p_ [ style_ "color: red" ] $ + "The username " <> fromString (T.unpack u) <> " is already in use!" + ] where nameBoxId = "name" imageStyle = maybe [] (pure . style_ . ("background-image: url(" <>) . (<> ")")) imageUrl @@ -267,9 +278,10 @@ combineConfs sc1 sc2 = ServerConfig server :: Int -> Port -> Maybe Text -> Maybe FilePath -> Layouts a b -> ServerConfig e s a b -> IO () server pingFrequency port loginImage assetsDir (uniqueNames (_1 % #name % coerced) -> layouts) conf = do + users <- newMVar Set.empty onStart conf =<< serverAddress port run port . serve (Proxy @(HttpApi :<|> WsApi)) $ - httpServer port loginImage assetsDir layouts :<|> websocketServer pingFrequency layouts conf + httpServer port loginImage assetsDir layouts users :<|> websocketServer pingFrequency layouts conf users -- | Runs HTTP server only. Expected that an external websocket server will be run from another program. serverExtWs :: @@ -284,17 +296,18 @@ serverExtWs :: Layouts a b -> IO () serverExtWs onStart httpPort wsPort loginImage assetsDir layouts = do + users <- newMVar Set.empty onStart =<< serverAddress httpPort - run httpPort . serve (Proxy @HttpApi) $ httpServer wsPort loginImage assetsDir layouts + run httpPort . serve (Proxy @HttpApi) $ httpServer wsPort loginImage assetsDir layouts users -httpServer :: Port -> Maybe Text -> Maybe FilePath -> Layouts a b -> Server HttpApi -httpServer wsPort loginImage assetsDir layouts = core :<|> assets +httpServer :: Port -> Maybe Text -> Maybe FilePath -> Layouts a b -> MVar (Set ClientID) -> Server HttpApi +httpServer wsPort loginImage assetsDir layouts users = core :<|> assets where core :: Server CoreApi core = \case Nothing -> pure $ loginHtml Nothing loginImage Just u -> -- there is a username query param in the URL - case validateUsername u of + liftIO (validateUsername users u) >>= \case Nothing -> pure $ mainHtml layouts wsPort Just err -> pure $ loginHtml (Just err) loginImage assets :: Server AssetsApi @@ -303,12 +316,13 @@ httpServer wsPort loginImage assetsDir layouts = core :<|> assets serveDirectoryWebApp assetsDir -websocketServer :: forall e s a b. Int -> Layouts a b -> ServerConfig e s a b -> Server WsApi -websocketServer pingFrequency layouts ServerConfig{..} mu pending = liftIO case mu of +websocketServer :: forall e s a b. Int -> Layouts a b -> ServerConfig e s a b -> MVar (Set ClientID) -> Server WsApi +websocketServer pingFrequency layouts ServerConfig{..} users mu pending = liftIO case mu of Nothing -> T.putStrLn ("Rejecting WS connection: " <> err) >> WS.rejectRequest pending (encodeUtf8 err) where err = "no username parameter" - Just clientId | Just err <- validateUsername clientId -> WS.rejectRequest pending . BS.pack $ show err - Just clientId -> do + Just clientId -> validateUsername users clientId >>= \case + Just err -> WS.rejectRequest pending . BS.pack $ show err + Nothing -> do lastPing <- newIORef Nothing (e, s0, u0) <- onNewConnection layouts clientId extraUpdates <- newEmptyMVar @@ -404,7 +418,11 @@ websocketServer pingFrequency layouts ServerConfig{..} mu pending = liftIO case ServerUpdate s -> Just s ClientUpdate _ -> Nothing WS.withPingThread conn pingFrequency onPing - . (=<<) (either (\err -> onDroppedConnection err clientId e) pure) + . (=<<) + ( either + (\err -> onDroppedConnection err clientId e >> modifyMVar_ users (pure . Set.delete clientId)) + pure + ) . runMonpad layouts clientId e s0 . SP.drain . SP.mapM (handleUpdates <=< either throwError pure) diff --git a/haskell/src/Util.hs b/haskell/src/Util.hs index fabe55c..ec99713 100644 --- a/haskell/src/Util.hs +++ b/haskell/src/Util.hs @@ -21,6 +21,8 @@ import Control.Monad.Trans.Maybe (MaybeT) import Data.Either.Validation (validationToEither) import Data.List.NonEmpty (NonEmpty) import Data.Map qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T import Data.Void (Void) @@ -135,3 +137,12 @@ uniqueNames l xs = flip evalState allNames $ for xs \x -> -- the state map stores the number of occurrences of each name seen so far allNames = Map.fromList $ zip (view l <$> toList xs) (repeat (0 :: Int)) err = error "broken invariant in `uniqueNames` - all names should be in map by construction" + +{- | Returns 'True' iff element is new. +'Set.size' is O(1), so this is quicker than checking membership first. +--TODO add to `containers`? https://github.com/haskell/containers/issues/31 +-} +setInsert' :: Ord a => a -> Set a -> (Set a, Bool) +setInsert' x s = (s', Set.size s /= Set.size s') + where + s' = Set.insert x s From 82561a2577e217bba01f0cdd54adf4d60d3a0261 Mon Sep 17 00:00:00 2001 From: George Thomas Date: Fri, 20 Aug 2021 02:05:45 +0100 Subject: [PATCH 2/7] Formatting --- haskell/src/Monpad.hs | 223 +++++++++++++++++++++--------------------- 1 file changed, 112 insertions(+), 111 deletions(-) diff --git a/haskell/src/Monpad.hs b/haskell/src/Monpad.hs index 16af1a1..2f7f403 100644 --- a/haskell/src/Monpad.hs +++ b/haskell/src/Monpad.hs @@ -321,118 +321,119 @@ websocketServer pingFrequency layouts ServerConfig{..} users mu pending = liftIO Nothing -> T.putStrLn ("Rejecting WS connection: " <> err) >> WS.rejectRequest pending (encodeUtf8 err) where err = "no username parameter" Just clientId -> validateUsername users clientId >>= \case - Just err -> WS.rejectRequest pending . BS.pack $ show err - Nothing -> do - lastPing <- newIORef Nothing - (e, s0, u0) <- onNewConnection layouts clientId - extraUpdates <- newEmptyMVar - let onPing = writeIORef lastPing . Just =<< getPOSIXTime - onPong' = readIORef lastPing >>= \case - Nothing -> warn "pong before ping" - Just t0 -> do - t1 <- getPOSIXTime - us <- onPong (t1 - t0) clientId e - putMVar extraUpdates us - conn <- WS.acceptRequest $ pending & (#pendingOptions % #connectionOnPong) %~ (<> onPong') - let {- We have to take care here not to attempt a parallel composition in a stateful monad. - This is not supported by Streamly, but the types don't do anything to disallow it. - See: https://github.com/composewell/streamly/issues/1203. - We instead use an ad-hoc, simpler, monad stack, and only lift to `Monpad` once we're back to `Serial`. - -} - allUpdates :: SP.SerialT (ReaderT (MonpadEnv e a b) IO) (Either MonpadException [Update a b]) - allUpdates = SP.fromAsync $ - (pure . ClientUpdate <<$>> clientUpdates) - <> (pure . map ServerUpdate <$> serverUpdates) - clientUpdates = SP.fromSerial . SP.hoist liftIO . SP.repeatM $ getUpdate conn - serverUpdates = SP.cons u0 $ - (SP.fromSerial . SP.hoist liftIO . updates =<< ask) - <> SP.repeatM (liftIO $ takeMVar extraUpdates) - handleUpdates = sendUpdates conn . map biVoid . concat <=< traverse (go . pure) - where - go us = if null us - then mempty - else fmap (sus ++) $ go . map ServerUpdate . concat =<< for us \u -> do - case u of - -- this needs to be equivalent to the same handling in the Elm code - ServerUpdate su -> case su of - PlayAudioURL{} -> mempty - Vibrate{} -> mempty - SetImageURL i x -> - (currentLayout % el i % #image % _Just % #url) .= x - AddImage i x -> - (currentLayout % el i % #image) .= Just x - DeleteImage i -> - (currentLayout % el i % #image) .= Nothing - SetText i x -> - (currentLayout % el i % #text % _Just % #text) .= x - AddText i x -> - (currentLayout % el i % #text) .= Just x - DeleteText i -> - (currentLayout % el i % #text) .= Nothing - SetLayout l -> - currentLayout .= l - SwitchLayout i -> - #layout .= i - HideElement i -> - (currentLayout % el i % #hidden) .= True - ShowElement i -> - (currentLayout % el i % #hidden) .= False - AddElement x -> - (currentLayout % #elements) %= (x :) - RemoveElement i -> - (currentLayout % #elements) %= filter ((/= i) . view #name) - SetBackgroundColour x -> - (currentLayout % #backgroundColour) .= x - SetIndicatorHollowness i x -> - (currentLayout % el i % #element % #_Indicator % #hollowness) .= x - SetIndicatorArcStart i x -> - (currentLayout % el i % #element % #_Indicator % #arcStart) .= x - SetIndicatorArcEnd i x -> - (currentLayout % el i % #element % #_Indicator % #arcEnd) .= x - SetIndicatorShape i x -> - (currentLayout % el i % #element % #_Indicator % #shape) .= x - SetIndicatorCentre i x -> - (currentLayout % el i % #element % #_Indicator % #centre) .= x - SetIndicatorColour i x -> - (currentLayout % el i % #element % #_Indicator % #colour) .= x - SetSliderPosition{} -> mempty - SetButtonColour i x -> - (currentLayout % el i % #element % #_Button % #colour) .= x - SetButtonPressed{} -> mempty - ResetLayout x -> case x of - StateReset -> mempty -- this only affects the frontend - FullReset -> do - i <- gets $ view #layout - l <- asks $ maybe currentLayoutError fst . Map.lookup i . view #initialLayouts - currentLayout .= l - ClientUpdate _ -> mempty - onUpdate u + Just err -> WS.rejectRequest pending . BS.pack $ show err + Nothing -> do + lastPing <- newIORef Nothing + (e, s0, u0) <- onNewConnection layouts clientId + extraUpdates <- newEmptyMVar + let onPing = writeIORef lastPing . Just =<< getPOSIXTime + onPong' = readIORef lastPing >>= \case + Nothing -> warn "pong before ping" + Just t0 -> do + t1 <- getPOSIXTime + us <- onPong (t1 - t0) clientId e + putMVar extraUpdates us + conn <- WS.acceptRequest $ pending & (#pendingOptions % #connectionOnPong) %~ (<> onPong') + let {- We have to take care here not to attempt a parallel composition in a stateful monad. + This is not supported by Streamly, but the types don't do anything to disallow it. + See: https://github.com/composewell/streamly/issues/1203. + We instead use an ad-hoc, simpler, monad stack, and only lift to `Monpad` once we're back to `Serial`. + -} + allUpdates :: SP.SerialT (ReaderT (MonpadEnv e a b) IO) (Either MonpadException [Update a b]) + allUpdates = SP.fromAsync $ + (pure . ClientUpdate <<$>> clientUpdates) + <> (pure . map ServerUpdate <$> serverUpdates) + clientUpdates = SP.fromSerial . SP.hoist liftIO . SP.repeatM $ getUpdate conn + serverUpdates = SP.cons u0 $ + (SP.fromSerial . SP.hoist liftIO . updates =<< ask) + <> SP.repeatM (liftIO $ takeMVar extraUpdates) + handleUpdates = sendUpdates conn . map biVoid . concat <=< traverse (go . pure) where - -- traverse all elements whose names match - el :: ElementID -> Traversal' (Layout a b) (FullElement a b) - el i = #elements % traversed % elMaybe i % _Just - elMaybe i = lens - (\x -> guard (view #name x == i) $> x) - (\x my -> fromMaybe x $ guard (view #name x == i) >> my) - sus = us & mapMaybe \case - ServerUpdate s -> Just s - ClientUpdate _ -> Nothing - WS.withPingThread conn pingFrequency onPing - . (=<<) - ( either - (\err -> onDroppedConnection err clientId e >> modifyMVar_ users (pure . Set.delete clientId)) - pure - ) - . runMonpad layouts clientId e s0 - . SP.drain - . SP.mapM (handleUpdates <=< either throwError pure) - . SP.hoist (\x -> liftIO . runReaderT x =<< ask) - $ allUpdates - where - sendUpdates conn = liftIO . WS.sendTextData conn . encode - getUpdate conn = - (first UpdateDecodeException . eitherDecode <=< first WebSocketException) - <$> liftIO (try $ WS.receiveData conn) + go us = if null us + then mempty + else fmap (sus ++) $ go . map ServerUpdate . concat =<< for us \u -> do + case u of + -- this needs to be equivalent to the same handling in the Elm code + ServerUpdate su -> case su of + PlayAudioURL{} -> mempty + Vibrate{} -> mempty + SetImageURL i x -> + (currentLayout % el i % #image % _Just % #url) .= x + AddImage i x -> + (currentLayout % el i % #image) .= Just x + DeleteImage i -> + (currentLayout % el i % #image) .= Nothing + SetText i x -> + (currentLayout % el i % #text % _Just % #text) .= x + AddText i x -> + (currentLayout % el i % #text) .= Just x + DeleteText i -> + (currentLayout % el i % #text) .= Nothing + SetLayout l -> + currentLayout .= l + SwitchLayout i -> + #layout .= i + HideElement i -> + (currentLayout % el i % #hidden) .= True + ShowElement i -> + (currentLayout % el i % #hidden) .= False + AddElement x -> + (currentLayout % #elements) %= (x :) + RemoveElement i -> + (currentLayout % #elements) %= filter ((/= i) . view #name) + SetBackgroundColour x -> + (currentLayout % #backgroundColour) .= x + SetIndicatorHollowness i x -> + (currentLayout % el i % #element % #_Indicator % #hollowness) .= x + SetIndicatorArcStart i x -> + (currentLayout % el i % #element % #_Indicator % #arcStart) .= x + SetIndicatorArcEnd i x -> + (currentLayout % el i % #element % #_Indicator % #arcEnd) .= x + SetIndicatorShape i x -> + (currentLayout % el i % #element % #_Indicator % #shape) .= x + SetIndicatorCentre i x -> + (currentLayout % el i % #element % #_Indicator % #centre) .= x + SetIndicatorColour i x -> + (currentLayout % el i % #element % #_Indicator % #colour) .= x + SetSliderPosition{} -> mempty + SetButtonColour i x -> + (currentLayout % el i % #element % #_Button % #colour) .= x + SetButtonPressed{} -> mempty + ResetLayout x -> case x of + StateReset -> mempty -- this only affects the frontend + FullReset -> do + i <- gets $ view #layout + l <- asks $ maybe currentLayoutError fst . Map.lookup i + . view #initialLayouts + currentLayout .= l + ClientUpdate _ -> mempty + onUpdate u + where + -- traverse all elements whose names match + el :: ElementID -> Traversal' (Layout a b) (FullElement a b) + el i = #elements % traversed % elMaybe i % _Just + elMaybe i = lens + (\x -> guard (view #name x == i) $> x) + (\x my -> fromMaybe x $ guard (view #name x == i) >> my) + sus = us & mapMaybe \case + ServerUpdate s -> Just s + ClientUpdate _ -> Nothing + WS.withPingThread conn pingFrequency onPing + . (=<<) + ( either + (\err -> onDroppedConnection err clientId e >> modifyMVar_ users (pure . Set.delete clientId)) + pure + ) + . runMonpad layouts clientId e s0 + . SP.drain + . SP.mapM (handleUpdates <=< either throwError pure) + . SP.hoist (\x -> liftIO . runReaderT x =<< ask) + $ allUpdates + where + sendUpdates conn = liftIO . WS.sendTextData conn . encode + getUpdate conn = + (first UpdateDecodeException . eitherDecode <=< first WebSocketException) + <$> liftIO (try $ WS.receiveData conn) --TODO colours warn :: MonadIO m => Text -> m () From 4294046854744a15e9cff7466da907ff09883f9e Mon Sep 17 00:00:00 2001 From: George Thomas Date: Fri, 20 Aug 2021 02:07:53 +0100 Subject: [PATCH 3/7] DRY username error display code --- haskell/src/Monpad.hs | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/haskell/src/Monpad.hs b/haskell/src/Monpad.hs index 2f7f403..fe3a09e 100644 --- a/haskell/src/Monpad.hs +++ b/haskell/src/Monpad.hs @@ -148,13 +148,12 @@ loginHtml err imageUrl = doctypehtml_ . body_ imageStyle . form_ [action_ $ symb , input_ [type_ "submit", value_ "Go!"] ] <> case err of Nothing -> [] - Just EmptyUsername -> - [ p_ [ style_ "color: red" ] - "Empty usernames are not allowed!" - ] - Just (DuplicateUsername (ClientID u)) -> - [ p_ [ style_ "color: red" ] $ - "The username " <> fromString (T.unpack u) <> " is already in use!" + Just e -> + [ p_ [ style_ "color: red" ] case e of + EmptyUsername -> + "Empty usernames are not allowed!" + (DuplicateUsername (ClientID u)) -> + "The username " <> fromString (T.unpack u) <> " is already in use!" ] where nameBoxId = "name" From 6f46c285f432aba19e98e7e603986c00f47162cc Mon Sep 17 00:00:00 2001 From: George Thomas Date: Fri, 20 Aug 2021 02:10:02 +0100 Subject: [PATCH 4/7] Bug fix - invert duplicate username check --- haskell/src/Monpad.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haskell/src/Monpad.hs b/haskell/src/Monpad.hs index fe3a09e..caafcb4 100644 --- a/haskell/src/Monpad.hs +++ b/haskell/src/Monpad.hs @@ -94,7 +94,7 @@ validateUsername :: MVar (Set ClientID) -> ClientID -> IO (Maybe UsernameError) validateUsername users u = eitherToMaybe . swapEither <$> runExceptT do when (u == ClientID "") $ throwError EmptyUsername isNew <- liftIO $ modifyMVar users $ pure . setInsert' u - when isNew . throwError $ DuplicateUsername u + unless isNew . throwError $ DuplicateUsername u data UsernameError = EmptyUsername | DuplicateUsername ClientID From eb0b334fa157e325dcddc0e0ec30d74bb08baf7a Mon Sep 17 00:00:00 2001 From: George Thomas Date: Fri, 20 Aug 2021 02:11:55 +0100 Subject: [PATCH 5/7] Minor refactor - use fmap rather than bind I guess this case is just slightly too complex for HLint. --- haskell/src/Monpad.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/haskell/src/Monpad.hs b/haskell/src/Monpad.hs index caafcb4..1084073 100644 --- a/haskell/src/Monpad.hs +++ b/haskell/src/Monpad.hs @@ -306,9 +306,9 @@ httpServer wsPort loginImage assetsDir layouts users = core :<|> assets core = \case Nothing -> pure $ loginHtml Nothing loginImage Just u -> -- there is a username query param in the URL - liftIO (validateUsername users u) >>= \case - Nothing -> pure $ mainHtml layouts wsPort - Just err -> pure $ loginHtml (Just err) loginImage + liftIO (validateUsername users u) <&> \case + Nothing -> mainHtml layouts wsPort + Just err -> loginHtml (Just err) loginImage assets :: Server AssetsApi assets = maybe (pure $ const ($ responseLBS status404 [] "no asset directory specified")) From 69f79b6d03a5791d8e367aa90dec085040786104 Mon Sep 17 00:00:00 2001 From: George Thomas Date: Fri, 20 Aug 2021 14:59:32 +0100 Subject: [PATCH 6/7] Validate usernames once, then use a waiting set for valid WS usernames Old version is broken because we try to modify the set of users twice. The second time, when opening the websocket, we fail because it's already in the set. So we change our approach to avoid any awkward concurrency issues. We go beyond the original purpose of this PR in that we also defend against differences between the WS and HTTP username params. e.g. if a user modifies the served JS. --- haskell/monpad.cabal | 1 + haskell/src/Monpad.hs | 85 ++++++++++++++++++++++++++++--------------- haskell/src/Util.hs | 8 ++++ 3 files changed, 65 insertions(+), 29 deletions(-) diff --git a/haskell/monpad.cabal b/haskell/monpad.cabal index eb624cd..63d15c0 100644 --- a/haskell/monpad.cabal +++ b/haskell/monpad.cabal @@ -145,6 +145,7 @@ library servant-server ^>= 0.18, servant-websockets ^>= 2.0, streamly-fsnotify ^>= 1.1.1.0, + stm ^>= 2.5, transformers-base ^>= 0.4.5.2, wai ^>= 3.2.2, warp ^>= 3.3.9, diff --git a/haskell/src/Monpad.hs b/haskell/src/Monpad.hs index 1084073..c5b82d5 100644 --- a/haskell/src/Monpad.hs +++ b/haskell/src/Monpad.hs @@ -24,6 +24,7 @@ module Monpad ( ) where import Control.Concurrent +import Control.Concurrent.STM import Control.Exception import Control.Monad.Base import Control.Monad.Catch (MonadThrow) @@ -34,9 +35,6 @@ import Control.Monad.Trans.Control import Data.Aeson (FromJSON, ToJSON, eitherDecode, encode) import Data.Aeson.Text (encodeToLazyText) import Data.Bifunctor -import Data.ByteString.Char8 qualified as BS -import Data.Either.Combinators -import Data.Either.Extra import Data.Functor import Data.IORef import Data.List.NonEmpty (NonEmpty) @@ -87,18 +85,23 @@ import Orphans.Generic () import ServerUpdate import Util -newtype ClientID = ClientID Text +newtype ClientID = ClientID {unwrap :: Text} deriving (Eq, Ord, Show) deriving newtype FromHttpApiData -validateUsername :: MVar (Set ClientID) -> ClientID -> IO (Maybe UsernameError) -validateUsername users u = eitherToMaybe . swapEither <$> runExceptT do - when (u == ClientID "") $ throwError EmptyUsername - isNew <- liftIO $ modifyMVar users $ pure . setInsert' u - unless isNew . throwError $ DuplicateUsername u data UsernameError = EmptyUsername - | DuplicateUsername ClientID + | DuplicateUsername + Bool + -- ^ is the user with this name fully connected? as opposed to being in the waiting set + ClientID deriving (Show) +data Clients = Clients + { connected :: TVar (Set ClientID) + -- ^ full WS connection + , waiting :: TVar (Set ClientID) + -- ^ HTTP connection but not yet WS + } + deriving (Generic) data Update a b = ClientUpdate ClientUpdate @@ -152,8 +155,9 @@ loginHtml err imageUrl = doctypehtml_ . body_ imageStyle . form_ [action_ $ symb [ p_ [ style_ "color: red" ] case e of EmptyUsername -> "Empty usernames are not allowed!" - (DuplicateUsername (ClientID u)) -> + (DuplicateUsername fully (ClientID u)) -> "The username " <> fromString (T.unpack u) <> " is already in use!" + <> if fully then mempty else " (though not fully connected)" ] where nameBoxId = "name" @@ -277,10 +281,11 @@ combineConfs sc1 sc2 = ServerConfig server :: Int -> Port -> Maybe Text -> Maybe FilePath -> Layouts a b -> ServerConfig e s a b -> IO () server pingFrequency port loginImage assetsDir (uniqueNames (_1 % #name % coerced) -> layouts) conf = do - users <- newMVar Set.empty + clients <- Clients <$> newTVarIO Set.empty <*> newTVarIO Set.empty onStart conf =<< serverAddress port run port . serve (Proxy @(HttpApi :<|> WsApi)) $ - httpServer port loginImage assetsDir layouts users :<|> websocketServer pingFrequency layouts conf users + httpServer port loginImage assetsDir layouts (Just clients) + :<|> websocketServer pingFrequency layouts conf clients -- | Runs HTTP server only. Expected that an external websocket server will be run from another program. serverExtWs :: @@ -295,33 +300,41 @@ serverExtWs :: Layouts a b -> IO () serverExtWs onStart httpPort wsPort loginImage assetsDir layouts = do - users <- newMVar Set.empty onStart =<< serverAddress httpPort - run httpPort . serve (Proxy @HttpApi) $ httpServer wsPort loginImage assetsDir layouts users + run httpPort . serve (Proxy @HttpApi) $ httpServer wsPort loginImage assetsDir layouts clients + where + -- we can't detect duplicates when we don't control the websocket, since we don't know when a client disconnects + clients = Nothing -httpServer :: Port -> Maybe Text -> Maybe FilePath -> Layouts a b -> MVar (Set ClientID) -> Server HttpApi -httpServer wsPort loginImage assetsDir layouts users = core :<|> assets +httpServer :: Port -> Maybe Text -> Maybe FilePath -> Layouts a b -> Maybe Clients -> Server HttpApi +httpServer wsPort loginImage assetsDir layouts mclients = core :<|> assets where core :: Server CoreApi core = \case Nothing -> pure $ loginHtml Nothing loginImage - Just u -> -- there is a username query param in the URL - liftIO (validateUsername users u) <&> \case - Nothing -> mainHtml layouts wsPort - Just err -> loginHtml (Just err) loginImage + -- there is a username query param in the URL - validate it, and add to waiting list + Just u -> liftIO $ atomically $ + either (\err -> loginHtml (Just err) loginImage) (\() -> mainHtml layouts wsPort) <$> runExceptT do + when (u == ClientID "") $ throwError EmptyUsername + case mclients of + Just Clients{waiting, connected} -> do + alreadyConnected <- lift $ Set.member u <$> readTVar connected + when alreadyConnected $ throwError $ DuplicateUsername True u + isNew <- lift $ stateTVar waiting $ swap . setInsert' u + unless isNew $ throwError $ DuplicateUsername False u + Nothing -> pure () assets :: Server AssetsApi assets = maybe (pure $ const ($ responseLBS status404 [] "no asset directory specified")) serveDirectoryWebApp assetsDir -websocketServer :: forall e s a b. Int -> Layouts a b -> ServerConfig e s a b -> MVar (Set ClientID) -> Server WsApi -websocketServer pingFrequency layouts ServerConfig{..} users mu pending = liftIO case mu of - Nothing -> T.putStrLn ("Rejecting WS connection: " <> err) >> WS.rejectRequest pending (encodeUtf8 err) - where err = "no username parameter" - Just clientId -> validateUsername users clientId >>= \case - Just err -> WS.rejectRequest pending . BS.pack $ show err - Nothing -> do +websocketServer :: forall e s a b. Int -> Layouts a b -> ServerConfig e s a b -> Clients -> Server WsApi +websocketServer pingFrequency layouts ServerConfig{..} clients mu pending = liftIO case mu of + Nothing -> rejectAndLog "no username parameter" + Just clientId -> registerConnection clientId >>= \case + False -> rejectAndLog $ "username not in the waiting set: " <> clientId.unwrap + True -> do lastPing <- newIORef Nothing (e, s0, u0) <- onNewConnection layouts clientId extraUpdates <- newEmptyMVar @@ -420,7 +433,10 @@ websocketServer pingFrequency layouts ServerConfig{..} users mu pending = liftIO WS.withPingThread conn pingFrequency onPing . (=<<) ( either - (\err -> onDroppedConnection err clientId e >> modifyMVar_ users (pure . Set.delete clientId)) + ( \err -> do + onDroppedConnection err clientId e + atomically $ modifyTVar clients.connected $ Set.delete clientId + ) pure ) . runMonpad layouts clientId e s0 @@ -433,6 +449,17 @@ websocketServer pingFrequency layouts ServerConfig{..} users mu pending = liftIO getUpdate conn = (first UpdateDecodeException . eitherDecode <=< first WebSocketException) <$> liftIO (try $ WS.receiveData conn) + where + rejectAndLog err = do + T.putStrLn $ "Rejecting WS connection: " <> err + WS.rejectRequest pending $ encodeUtf8 err + -- attempt to move client from the waiting set to the connected set + registerConnection clientId = atomically do + success <- stateTVar clients.waiting $ swap . setDelete' clientId + when success do + isNew <- stateTVar clients.connected $ swap . setInsert' clientId + unless isNew $ error $ "logic error - username in waiting and connected set: " <> show clientId + pure success --TODO colours warn :: MonadIO m => Text -> m () diff --git a/haskell/src/Util.hs b/haskell/src/Util.hs index ec99713..a25887b 100644 --- a/haskell/src/Util.hs +++ b/haskell/src/Util.hs @@ -146,3 +146,11 @@ setInsert' :: Ord a => a -> Set a -> (Set a, Bool) setInsert' x s = (s', Set.size s /= Set.size s') where s' = Set.insert x s + +{- | Returns 'True' iff element was present. +'Set.size' is O(1), so this is quicker than checking membership first. +-} +setDelete' :: Ord a => a -> Set a -> (Set a, Bool) +setDelete' x s = (s', Set.size s /= Set.size s') + where + s' = Set.delete x s From 78841021e3180c614fc1bce7c33359b1b60ff59d Mon Sep 17 00:00:00 2001 From: George Thomas Date: Fri, 20 Aug 2021 15:01:16 +0100 Subject: [PATCH 7/7] Swap result tuple order in `setInsert'` etc. Matches `state` and STM stuff. MVars are the outlier. --- haskell/src/Monpad.hs | 6 +++--- haskell/src/Util.hs | 8 ++++---- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/haskell/src/Monpad.hs b/haskell/src/Monpad.hs index c5b82d5..f43c577 100644 --- a/haskell/src/Monpad.hs +++ b/haskell/src/Monpad.hs @@ -320,7 +320,7 @@ httpServer wsPort loginImage assetsDir layouts mclients = core :<|> assets Just Clients{waiting, connected} -> do alreadyConnected <- lift $ Set.member u <$> readTVar connected when alreadyConnected $ throwError $ DuplicateUsername True u - isNew <- lift $ stateTVar waiting $ swap . setInsert' u + isNew <- lift $ stateTVar waiting $ setInsert' u unless isNew $ throwError $ DuplicateUsername False u Nothing -> pure () assets :: Server AssetsApi @@ -455,9 +455,9 @@ websocketServer pingFrequency layouts ServerConfig{..} clients mu pending = lift WS.rejectRequest pending $ encodeUtf8 err -- attempt to move client from the waiting set to the connected set registerConnection clientId = atomically do - success <- stateTVar clients.waiting $ swap . setDelete' clientId + success <- stateTVar clients.waiting $ setDelete' clientId when success do - isNew <- stateTVar clients.connected $ swap . setInsert' clientId + isNew <- stateTVar clients.connected $ setInsert' clientId unless isNew $ error $ "logic error - username in waiting and connected set: " <> show clientId pure success diff --git a/haskell/src/Util.hs b/haskell/src/Util.hs index a25887b..0ccfd27 100644 --- a/haskell/src/Util.hs +++ b/haskell/src/Util.hs @@ -142,15 +142,15 @@ uniqueNames l xs = flip evalState allNames $ for xs \x -> 'Set.size' is O(1), so this is quicker than checking membership first. --TODO add to `containers`? https://github.com/haskell/containers/issues/31 -} -setInsert' :: Ord a => a -> Set a -> (Set a, Bool) -setInsert' x s = (s', Set.size s /= Set.size s') +setInsert' :: Ord a => a -> Set a -> (Bool, Set a) +setInsert' x s = (Set.size s /= Set.size s', s') where s' = Set.insert x s {- | Returns 'True' iff element was present. 'Set.size' is O(1), so this is quicker than checking membership first. -} -setDelete' :: Ord a => a -> Set a -> (Set a, Bool) -setDelete' x s = (s', Set.size s /= Set.size s') +setDelete' :: Ord a => a -> Set a -> (Bool, Set a) +setDelete' x s = (Set.size s /= Set.size s', s') where s' = Set.delete x s