[ws] implement jwt token authorization

src/Gargantext/API/Admin/Auth/Types.hs

@@ -48,7 +48,7 @@ data CheckAuth = InvalidUser | InvalidPassword | Valid Token TreeId UserId
 data AuthenticatedUser = AuthenticatedUser
   { _auth_node_id :: NodeId
   , _auth_user_id :: UserId
-  } deriving (Generic)
+  } deriving (Generic, Show, Eq)
 
 makeLenses ''AuthenticatedUser
 

src/Gargantext/API/Admin/Settings.hs

@@ -205,7 +205,7 @@ newEnv logger port file = do
 
   !central_exchange <- forkIO CE.gServer
 
-  !dispatcher <- D.dispatcher
+  !dispatcher <- D.dispatcher settings'
 
 {-  An 'Env' by default doesn't have strict fields, but when constructing one in production
   we want to force them to WHNF to avoid accumulating unnecessary thunks.

src/Gargantext/Core/AsyncUpdates/Dispatcher.hs

@@ -26,6 +26,9 @@ import Data.Aeson.Types (prependFailure, typeMismatch)
 import Data.ByteString.Char8 qualified as C
 import Data.ByteString.Lazy qualified as BSL
 import Data.List (nubBy)
+import Data.UUID.V4 as UUID
+import Gargantext.API.Admin.Auth.Types (AuthenticatedUser(_auth_user_id))
+import Gargantext.API.Admin.Types (jwtSettings, Settings, jwtSettings)
 import Gargantext.Core.AsyncUpdates.CentralExchange.Types qualified as CETypes
 import Gargantext.Core.Types (NodeId, UserId)
 import Gargantext.Prelude
@@ -34,6 +37,7 @@ import Nanomsg
 import Network.WebSockets qualified as WS
 import Servant
 import Servant.API.WebSocket qualified as WS
+import Servant.Auth.Server (verifyJWT)
 
 {-
 
@@ -101,6 +105,9 @@ showSub sub =
 subKey :: Subscription -> ByteString
 subKey sub = wsKey $ s_ws_key_connection sub
 
+
+type Token = Text
+    
 {-
 We accept requests for subscription/unsubscription via websocket.
 
@@ -115,6 +122,8 @@ browser.
 data WSRequest =
     WSSubscribe Topic
   | WSUnsubscribe Topic
+  | WSAuthorize Token
+  | WSDeauthorize
   | WSPing
   | WSPong
   deriving (Eq, Show)
@@ -128,6 +137,10 @@ instance FromJSON WSRequest where
       "unsubscribe" -> do
         topic <- o .: "topic"
         pure $ WSUnsubscribe topic
+      "authorize" -> do
+         token <- o .: "token"
+         pure $ WSAuthorize token
+      "deauthorize" -> pure $ WSDeauthorize
       "ping" -> pure WSPing
       "pong" -> pure WSPong
       s -> prependFailure "parsing request type failed, " (typeMismatch "request" s)
@@ -139,11 +152,11 @@ data Dispatcher =
             }
     
 
-dispatcher :: IO Dispatcher
-dispatcher = do
+dispatcher :: Settings -> IO Dispatcher
+dispatcher authSettings = do
   subscriptions <- newTVarIO ([] :: [Subscription])
 
-  let server = wsServer subscriptions
+  let server = wsServer authSettings subscriptions
 
   d_ce_listener <- forkIO (ce_listener subscriptions)
 
@@ -181,8 +194,8 @@ removeSubscriptionsForWSKey subscriptions ws =
     
 type WSAPI = "ws" :> WS.WebSocketPending
 
-wsServer :: TVar [Subscription] -> Server WSAPI
-wsServer subscriptions = streamData
+wsServer :: Settings -> TVar [Subscription] -> Server WSAPI
+wsServer authSettings subscriptions = streamData
  where
   streamData :: MonadIO m => WS.PendingConnection -> m ()
   streamData pc = do
@@ -191,7 +204,11 @@ wsServer subscriptions = streamData
     -- some unique, Sec-WebSocket-Key string. We use this to compare
     -- connections (WS.Connection doesn't implement an Eq instance).
     let mKey = head $ filter (\(k, _) -> k == "Sec-WebSocket-Key") $ WS.requestHeaders reqHead
-    let key = snd $ fromMaybe (panicTrace "Sec-WebSocket-Key not found!") mKey
+    let key' = snd $ fromMaybe (panicTrace "Sec-WebSocket-Key not found!") mKey
+    -- Unfortunately, a single browsers sends the same
+    -- Sec-WebSocket-Key so we want to make that even more unique.
+    uuid <- liftIO $ UUID.nextRandom
+    let key = key' <> "-" <> show uuid
     putText $ show $ WS.requestHeaders reqHead
     c <- liftIO $ WS.acceptRequest pc
     let ws = WSKeyConnection (key, c)
@@ -206,19 +223,26 @@ wsServer subscriptions = streamData
     
   wsLoop ws = flip finally disconnect $ do
       putText "[wsLoop] connecting"
-      forever $ do
+      wsLoop' CUPublic
+
+    where
+      wsLoop' user = do
         dm <- WS.receiveDataMessage (wsConn ws)
-        case dm of
+        
+        newUser <- case dm of
           WS.Text dm' _ -> do
             case Aeson.decode dm' of
-              Nothing -> putText "[wsLoop] unknown message"
+              Nothing -> do
+                putText "[wsLoop] unknown message"
+                return user
               Just (WSSubscribe topic) -> do
                 -- TODO Fix s_connected_user based on header
-                let sub = Subscription { s_connected_user = CUPublic
+                let sub = Subscription { s_connected_user = user
                                        , s_ws_key_connection = ws
                                        , s_topic = topic }
                 ss <- insertSubscription subscriptions sub
                 putText $ "[wsLoop] subscriptions: " <> show (showSub <$> ss)
+                return user
               Just (WSUnsubscribe topic) -> do
                 -- TODO Fix s_connected_user based on header
                 let sub = Subscription { s_connected_user = CUPublic
@@ -226,12 +250,31 @@ wsServer subscriptions = streamData
                                       , s_topic = topic }
                 ss <- removeSubscription subscriptions sub
                 putText $ "[wsLoop] subscriptions: " <> show (showSub <$> ss)
+                return user
+              Just (WSAuthorize token) -> do
+                let jwtS = authSettings ^. jwtSettings
+                mUser <- liftBase $ verifyJWT jwtS (encodeUtf8 token)
+
+                putText $ "[wsLoop] authorized user: " <> show mUser
+
+                -- TODO Update my subscriptions!
+
+                return $ fromMaybe user (CUUser . _auth_user_id <$> mUser)
+              Just WSDeauthorize -> do
+                -- TODO Update my subscriptions!
+                pure CUPublic
               Just WSPing -> do
                 WS.sendDataMessage (wsConn ws) (WS.Text (Aeson.encode Pong) Nothing)
+                return user
               Just WSPong -> do
                 putText $ "[wsLoop] pong received"
-          _ -> putText "[wsLoop] binary ws messages not supported"
-    where
+                return user
+          _ -> do
+            putText "[wsLoop] binary ws messages not supported"
+            return user
+          
+        wsLoop' newUser
+
       disconnect = do
         putText "[wsLoop] disconnecting..."
         ss <- removeSubscriptionsForWSKey subscriptions ws