Reject duplicate usernames

haskell/src/Monpad.hs

@@ -43,7 +43,11 @@ import Data.Maybe
 import Data.Monoid
 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
@@ -120,6 +124,7 @@ serverAddress port = do
 
 data UsernameError
     = EmptyUsername
+    | DuplicateUsername ClientID
 loginHtml :: Maybe UsernameError -> Maybe Text -> Html ()
 loginHtml err imageUrl = doctypehtml_ . body_ imageStyle . form_ [action_ $ symbolValT @Root] . mconcat $
     [ title_ "monpad: login"
@@ -132,10 +137,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
@@ -259,9 +267,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 ::
@@ -276,27 +285,33 @@ 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
             if u == ClientID ""
                 then pure $ loginHtml (Just EmptyUsername) loginImage
-                else pure $ mainHtml layouts wsPort
+                else do
+                    isNew <- liftIO $ modifyMVar users $ pure . setInsert' u
+                    if isNew then
+                        pure $ mainHtml layouts wsPort
+                    else
+                        pure $ loginHtml (Just $ DuplicateUsername u) loginImage
     assets :: Server AssetsApi
     assets = maybe
         (pure $ const ($ responseLBS status404 [] "no asset directory specified"))
         serveDirectoryWebApp
         assetsDir
 
-websocketServer :: Int -> Layouts a b -> ServerConfig e s a b -> Server WsApi
-websocketServer pingFrequency layouts ServerConfig{..} mu pending0 = liftIO case mu of
+websocketServer :: Int -> Layouts a b -> ServerConfig e s a b -> MVar (Set ClientID) -> Server WsApi
+websocketServer pingFrequency layouts ServerConfig{..} users mu pending0 = liftIO case mu of
     Nothing -> T.putStrLn ("Rejecting WS connection: " <> err) >> WS.rejectRequest pending0 (encodeUtf8 err)
       where err = "no username parameter"
     Just clientId -> do
@@ -398,7 +413,11 @@ websocketServer pingFrequency layouts ServerConfig{..} mu pending0 = liftIO case
                         ServerUpdate s -> Just s
                         ClientUpdate _ -> Nothing
         WS.withPingThread conn pingFrequency onPing
-            . (=<<) (either (flip (onDroppedConnection clientId) e) pure)
+            . (=<<)
+                ( either
+                    (\err -> onDroppedConnection clientId err e >> modifyMVar_ users (pure . Set.delete clientId))
+                    pure
+                )
             . runMonpad layouts clientId e s0
             . SP.drain
             $ SP.mapM handleUpdates allUpdates

haskell/src/Util.hs

@@ -19,6 +19,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)
@@ -130,3 +132,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