[websockets] refactor (make a Notifications.Types module)

src/Gargantext/Components/App/App.purs

@@ -7,6 +7,7 @@ import Data.Tuple.Nested ((/\))
 import Gargantext.AsyncTasks as GAT
 import Gargantext.Components.App.Store as AppStore
 import Gargantext.Components.Notifications as Notifications
+import Gargantext.Components.Notifications.Types as NotificationsT
 import Gargantext.Components.Router (router)
 import Gargantext.Hooks (useHashRouter)
 import Gargantext.Hooks.FirstEffect (useFirstEffect')
@@ -59,7 +60,7 @@ hydrateStoreCpt = here.component "hydrateStore" cpt where
       } _ = do
     -- | Computed
     -- |
-    wsNotification <- RU.hook $ \_ -> Notifications.emptyWSNotification
+    wsNotification <- RU.hook $ \_ -> NotificationsT.emptyWSNotification
     
     (state :: Record AppStore.State) <- pure $
       -- (cache options)
@@ -107,7 +108,8 @@ mainAppCpt = here.component "main" cpt where
       -- here.log2 "[mainApp] sessions" sessions'
       Notifications.connect ws "ws://localhost:8008/ws" session
       -- T.write_ ws boxes.wsNotification
-      let action = Notifications.InsertCallback (Notifications.UpdateTree (-1)) "some-uuid" (\_ -> here.log "callback!")
-      Notifications.performAction ws action
+      -- NOTE: Dummy subscription
+      -- let action = NotificationsT.InsertCallback (NotificationsT.UpdateTree (-1)) "some-uuid" (\_ -> here.log "callback!")
+      -- Notifications.performAction ws action
     useHashRouter Router.router boxes.route -- Install router to window
     pure $ router { boxes }          -- Render router component

src/Gargantext/Components/App/Store.purs

@@ -21,7 +21,7 @@ import Gargantext.AsyncTasks as GAT
 import Gargantext.Components.Lang as Lang
 import Gargantext.Components.Nodes.Lists.SidePanel as ListsSP
 import Gargantext.Components.Nodes.Texts.Types as TextsT
-import Gargantext.Components.Notifications as Notifications
+import Gargantext.Components.Notifications.Types as Notifications
 import Gargantext.Components.Themes as Themes
 import Gargantext.Ends (Backend)
 import Gargantext.Routes (AppRoute(Home), Tile)

src/Gargantext/Components/Forest/Tree.purs

@@ -30,6 +30,7 @@ import Gargantext.Components.Forest.Tree.Node.Action.WriteNodesDocuments (docume
 import Gargantext.Components.Forest.Tree.Node.Tools.FTree (FTree, LNode(..), NTree(..), fTreeID)
 import Gargantext.Components.Forest.Tree.Node.Tools.SubTree.Types (SubTreeOut(..))
 import Gargantext.Components.Notifications as Notifications
+import Gargantext.Components.Notifications.Types as NotificationsT
 import Gargantext.Config.REST (AffRESTError, logRESTError)
 import Gargantext.Config.Utils (handleRESTError)
 import Gargantext.Ends (Frontends)
@@ -325,7 +326,7 @@ childLoaderCpt = R2.hereComponent here "childLoader" hCpt where
             here.log2 "callback!" p.id
             -- The modal window has some problems closing when we refresh too early. This is a HACK
             void $ setTimeout 400 $ T2.reload reload
-      let action = Notifications.InsertCallback (Notifications.UpdateTree p.id) ("tree-" <> show p.id) cb
+      let action = NotificationsT.InsertCallback (NotificationsT.UpdateTree p.id) ("tree-" <> show p.id) cb
       here.log2 "[childLoader] action" action
       ws <- T.read boxes.wsNotification
       Notifications.performAction ws action

src/Gargantext/Components/Notifications.purs

@@ -18,6 +18,7 @@ import Effect.Timer (setTimeout)
 import Effect.Var (($=))
 import Effect.Var as Var
 import Foreign as F
+import Gargantext.Components.Notifications.Types
 import Gargantext.Sessions.Types (Session(..))
 import Gargantext.Types as GT
 import Gargantext.Utils.Reactix as R2
@@ -31,96 +32,6 @@ import WebSocket as WS
 here :: R2.Here
 here = R2.here "Gargantext.Components.Notifications"
 
-
-type NodeId = Int
--- Data.UUID.UUID is not Hashable
-type UUID = String
-
-data Topic =
-    UpdateJobProgress GT.AsyncTaskID
-  | UpdateTree NodeId
-derive instance Generic Topic _
-instance Eq Topic where eq = genericEq
-instance Show Topic where show = genericShow
-instance Hashable Topic where
-  hash t = hash $ show t
-instance JSON.ReadForeign Topic where
-  readImpl f = do
-    { type: type_ } <- JSON.readImpl f :: F.F { type :: String }
-    case type_ of
-      "update_job_progress" -> do
-        { j_id } <- JSON.readImpl f :: F.F { j_id :: GT.AsyncTaskID }
-        pure $ UpdateJobProgress j_id
-      "update_tree" -> do
-        { node_id } <- JSON.readImpl f :: F.F { node_id :: NodeId }
-        pure $ UpdateTree node_id
-      s -> F.fail $ F.ErrorAtProperty "type" $ F.ForeignError $ "unknown Topic type: " <> s
-instance JSON.WriteForeign Topic where
-  writeImpl (UpdateJobProgress j_id) = JSON.writeImpl { "type": "update_job_progress"
-                                                      , j_id }
-  writeImpl (UpdateTree node_id) = JSON.writeImpl { "type": "update_tree"
-                                                  , node_id }
-
-data WSRequest =
-    WSSubscribe Topic
-  | WSUnsubscribe Topic
-  | WSAuthorize String
-  | WSDeauthorize
-derive instance Generic WSRequest _
-instance Eq WSRequest where eq = genericEq
-instance JSON.WriteForeign WSRequest where
-  writeImpl (WSSubscribe topic) = JSON.writeImpl { request: "subscribe"
-                                                 , topic }
-  writeImpl (WSUnsubscribe topic) = JSON.writeImpl { request: "unsubscribe"
-                                                   , topic }
-  writeImpl (WSAuthorize token) = JSON.writeImpl { request: "authorize"
-                                                 , token }
-  writeImpl WSDeauthorize = JSON.writeImpl { request: "deauthorize" }
-
-
-
-data Message =
-    -- TODO
-    -- MJobProgress GT.AsyncProgress
-    MJobProgress GT.AsyncTaskLog
-  | MEmpty
-derive instance Generic Message _
-instance JSON.ReadForeign Message where
-  readImpl f = do
-    { type: type_ } <- JSON.readImpl f :: F.F { type :: String }
-    case type_ of
-      "MJobProgress" -> do
-        -- TODO
-        -- { job_progress } <- JSON.readImpl f :: F.F { job_progress :: GT.AsyncProgress }
-        { job_progress } <- JSON.readImpl f :: F.F { job_progress :: GT.AsyncTaskLog }
-        pure $ MJobProgress job_progress
-      "MEmpty" -> do
-        pure MEmpty
-      s -> do F.fail $ F.ErrorAtProperty "type" $ F.ForeignError $ "unknown Message type: " <> s
-
-data Notification =
-    Notification Topic Message
-derive instance Generic Notification _
-instance JSON.ReadForeign Notification where
-  readImpl f = do
-    let str = JSON.read_ f :: Maybe String
-    case str of
-      Nothing -> do
-        { notification } <- JSON.readImpl f :: F.F { notification :: { topic :: Topic, message :: Message } }
-        pure $ Notification notification.topic notification.message
-      Just s -> F.fail $ F.ErrorAtProperty "_" $ F.ForeignError $ "unkown string: " <> s
-
-
-type Callback = Message -> Effect Unit
-
-type CallbacksHM = HM.HashMap UUID Callback
-
-data State =
-  State { callbacks :: HM.HashMap Topic CallbacksHM }
-
-emptyState :: State
-emptyState = State { callbacks : HM.empty }
-
 insertCallback :: State -> Topic -> UUID -> Callback -> State
 insertCallback (State state@{ callbacks }) topic uuid cb =
   State $ state { callbacks = HM.alter alterCallbacksHM topic callbacks }
@@ -151,24 +62,6 @@ callNotification (State { callbacks }) (Notification topic message) = do
     topicCallbacks = fromMaybe HM.empty $ HM.lookup topic callbacks
 
 
-data WSNotification =
-  WSNotification { state :: Ref.Ref State
-
-                 -- TODO Implement a WS connection
-                 , connection :: Ref.Ref (Maybe WS.Connection)
-                   
-                 -- This calls R.setRef :: R.Ref State -> Effect Unit
-                 -- , insertCallback :: Topic -> UUID -> Effect Unit
-                 -- This calls R.setRef :: R.Ref State -> Effect Unit
-                 -- , removeCallback :: Topic -> UUID -> Effect Unit
-                 }
-
-emptyWSNotification :: Effect WSNotification
-emptyWSNotification = do
-  state <- Ref.new emptyState
-  connection <- Ref.new Nothing
-  pure $ WSNotification { state
-                        , connection }
 
 isConnected :: WSNotification -> Effect Boolean
 isConnected (WSNotification { connection }) =do
@@ -220,11 +113,6 @@ allSubscriptionsWS (WSNotification ws') = do
   state <- Ref.read ws'.state
   pure $ allSubscriptions state
 
--- | Actions to be called on the websocket connection
-data Action =
-    InsertCallback Topic UUID Callback
-  | RemoveCallback Topic UUID
-  | Call Notification
 
 performAction :: WSNotification -> Action -> Effect Unit
 performAction ws (InsertCallback topic uuid cb) = do
@@ -304,50 +192,6 @@ connect ws@(WSNotification ws') url session = do
 
       pure unit
 
--- | NOTE This is very ugly. WebSockets events are asychronous. We
--- | should wrap this similar as is done in 0MQ/nanomsg: make an
--- | infinite loop and just wait for an incoming message. This should
--- | reduce (to zero?) the need for SettableVar's etc (which is not
--- | the functional way to do things).
--- connect' :: WSNotification -> String -> (Maybe Session) -> Effect WSNotification
--- connect' ws@(WSNotification { connection: Just _conn }) _ _ = pure ws
--- connect' (WSNotification ws') url session = do
---   connection@(WS.Connection conn) <- WS.newWebSocket (WS.URL url) []
---   let ws = WSNotification $ ws' { connection = Just connection } 
---   conn.onopen $= (\_ -> do
---                      -- authorize user first
---                      here.log2 "[connect] session" session
---                      case session of
---                        Just (Session { token }) ->
---                          send ws $ WSAuthorize token
---                        Nothing -> pure unit
---                      -- send pending subscriptions
---                      void $ for (allSubscriptions ws) $ \(Tuple topic _) -> do
---                        let subscription = WSSubscribe topic
---                        here.log2 "[connect] pending subscription" subscription
---                        send ws subscription)
---   conn.onmessage $= (onmessage ws)
-
---   pure ws
-
---   where
---     onmessage ws me = do
---       -- WARNING mutable state
---       s <- runExceptT $ F.readString (ME.data_ me)
---       case s of
---         Left err -> do
---           here.log2 "[connect] data received is not a string - was expecting a JSON string!" err
---         Right s' -> do
---           let parsed = JSON.readJSON s' :: JSON.E Notification
---           case parsed of
---             Left err -> do
---               here.log2 "[connect] Can't parse message" err
---             Right (Notification topic) -> do
---               here.log2 "[connect] notification" topic
---               performAction ws (Call topic)
---             Right parsed' -> do
---               here.log2 "[connect] onmessage, F.readString" parsed'
-
 mkWSNotification :: String -> Effect WSNotification
 mkWSNotification url = do
   ws <- emptyWSNotification

src/Gargantext/Components/Notifications/Types.purs

+module Gargantext.Components.Notifications.Types where
+
+import Control.Monad.Except.Trans (runExceptT)
+import Data.Array as A
+import Data.Either (Either(..))
+import Data.Eq.Generic (genericEq)
+import Data.FoldableWithIndex (foldlWithIndex, foldMapWithIndex)
+import Data.Generic.Rep (class Generic)
+import Data.Hashable (class Hashable, hash)
+import Data.HashMap as HM
+import Data.Maybe (Maybe(..), fromMaybe, isJust)
+import Data.Show.Generic (genericShow)
+import Data.Traversable (for, traverse)
+import Data.Tuple (Tuple(..))
+import Effect (Effect)
+import Effect.Ref as Ref
+import Effect.Timer (setTimeout)
+import Effect.Var (($=))
+import Effect.Var as Var
+import Foreign as F
+import Gargantext.Sessions.Types (Session(..))
+import Gargantext.Types as GT
+import Gargantext.Utils.Reactix as R2
+import Prelude
+import Reactix as R
+import Simple.JSON as JSON
+import Web.Socket.Event.MessageEvent as ME
+import WebSocket as WS
+
+
+here :: R2.Here
+here = R2.here "Gargantext.Components.Notifications.Types"
+
+
+type NodeId = Int
+-- Data.UUID.UUID is not Hashable
+type UUID = String
+
+data Topic =
+    UpdateJobProgress GT.AsyncTaskID
+  | UpdateTree NodeId
+derive instance Generic Topic _
+instance Eq Topic where eq = genericEq
+instance Show Topic where show = genericShow
+instance Hashable Topic where
+  hash t = hash $ show t
+instance JSON.ReadForeign Topic where
+  readImpl f = do
+    { type: type_ } <- JSON.readImpl f :: F.F { type :: String }
+    case type_ of
+      "update_job_progress" -> do
+        { j_id } <- JSON.readImpl f :: F.F { j_id :: GT.AsyncTaskID }
+        pure $ UpdateJobProgress j_id
+      "update_tree" -> do
+        { node_id } <- JSON.readImpl f :: F.F { node_id :: NodeId }
+        pure $ UpdateTree node_id
+      s -> F.fail $ F.ErrorAtProperty "type" $ F.ForeignError $ "unknown Topic type: " <> s
+instance JSON.WriteForeign Topic where
+  writeImpl (UpdateJobProgress j_id) = JSON.writeImpl { "type": "update_job_progress"
+                                                      , j_id }
+  writeImpl (UpdateTree node_id) = JSON.writeImpl { "type": "update_tree"
+                                                  , node_id }
+
+data WSRequest =
+    WSSubscribe Topic
+  | WSUnsubscribe Topic
+  | WSAuthorize String
+  | WSDeauthorize
+derive instance Generic WSRequest _
+instance Eq WSRequest where eq = genericEq
+instance JSON.WriteForeign WSRequest where
+  writeImpl (WSSubscribe topic) = JSON.writeImpl { request: "subscribe"
+                                                 , topic }
+  writeImpl (WSUnsubscribe topic) = JSON.writeImpl { request: "unsubscribe"
+                                                   , topic }
+  writeImpl (WSAuthorize token) = JSON.writeImpl { request: "authorize"
+                                                 , token }
+  writeImpl WSDeauthorize = JSON.writeImpl { request: "deauthorize" }
+
+
+
+data Message =
+    -- TODO
+    -- MJobProgress GT.AsyncProgress
+    MJobProgress GT.AsyncTaskLog
+  | MEmpty
+derive instance Generic Message _
+instance JSON.ReadForeign Message where
+  readImpl f = do
+    { type: type_ } <- JSON.readImpl f :: F.F { type :: String }
+    case type_ of
+      "MJobProgress" -> do
+        -- TODO
+        -- { job_progress } <- JSON.readImpl f :: F.F { job_progress :: GT.AsyncProgress }
+        { job_progress } <- JSON.readImpl f :: F.F { job_progress :: GT.AsyncTaskLog }
+        pure $ MJobProgress job_progress
+      "MEmpty" -> do
+        pure MEmpty
+      s -> do F.fail $ F.ErrorAtProperty "type" $ F.ForeignError $ "unknown Message type: " <> s
+
+data Notification =
+    Notification Topic Message
+derive instance Generic Notification _
+instance JSON.ReadForeign Notification where
+  readImpl f = do
+    let str = JSON.read_ f :: Maybe String
+    case str of
+      Nothing -> do
+        { notification } <- JSON.readImpl f :: F.F { notification :: { topic :: Topic, message :: Message } }
+        pure $ Notification notification.topic notification.message
+      Just s -> F.fail $ F.ErrorAtProperty "_" $ F.ForeignError $ "unkown string: " <> s
+
+
+type Callback = Message -> Effect Unit
+
+type CallbacksHM = HM.HashMap UUID Callback
+
+data State =
+  State { callbacks :: HM.HashMap Topic CallbacksHM }
+
+emptyState :: State
+emptyState = State { callbacks : HM.empty }
+
+
+
+data WSNotification =
+  WSNotification { state :: Ref.Ref State
+
+                 -- TODO Implement a WS connection
+                 , connection :: Ref.Ref (Maybe WS.Connection)
+                   
+                 -- This calls R.setRef :: R.Ref State -> Effect Unit
+                 -- , insertCallback :: Topic -> UUID -> Effect Unit
+                 -- This calls R.setRef :: R.Ref State -> Effect Unit
+                 -- , removeCallback :: Topic -> UUID -> Effect Unit
+                 }
+
+emptyWSNotification :: Effect WSNotification
+emptyWSNotification = do
+  state <- Ref.new emptyState
+  connection <- Ref.new Nothing
+  pure $ WSNotification { state
+                        , connection }
+
+
+
+-- | Actions to be called on the websocket connection
+data Action =
+    InsertCallback Topic UUID Callback
+  | RemoveCallback Topic UUID
+  | Call Notification

src/Gargantext/Context/Progress.purs

@@ -15,6 +15,7 @@ import Gargantext.AsyncTasks as GAT
 import Gargantext.Components.App.Store as AppStore
 import Gargantext.Components.Forest.Tree.Node.Tools.ProgressBar (QueryProgressData, queryProgress)
 import Gargantext.Components.Notifications as Notifications
+import Gargantext.Components.Notifications.Types as NotificationsT
 import Gargantext.Config.Utils (handleErrorInAsyncProgress, handleRESTError)
 import Gargantext.Hooks.FirstEffect (useFirstEffect')
 import Gargantext.Prelude
@@ -52,6 +53,8 @@ asyncProgressCpt = R2.hereComponent here "asyncProgress" hCpt where
 
     -- Methods
     let
+      -- TODO Manage somehow to get the whole job status sent here via
+      -- websockets, then we can remove the 'Maybe'
       exec :: Maybe GT.AsyncProgress -> Effect Unit
       exec Nothing = launchAff_ do
         let rdata = (RX.pick props :: Record QueryProgressData)
@@ -102,14 +105,14 @@ asyncProgressCpt = R2.hereComponent here "asyncProgress" hCpt where
       let cb msg = do
             here.log2 "callback! for job update" taskId
             case msg of
-              Notifications.MJobProgress jobProgress -> do
+              NotificationsT.MJobProgress jobProgress -> do
                 -- TODO With jobProgress we could avoid polling here
                 -- exec (Just jobProgress)
                 exec Nothing
-              Notifications.MEmpty -> exec Nothing
+              NotificationsT.MEmpty -> exec Nothing
             -- The modal window has some problems closing when we refresh too early. This is a HACK
             -- void $ setTimeout 400 $ T2.reload reload
-      let action = Notifications.InsertCallback (Notifications.UpdateJobProgress taskId) ("task-" <> show taskId) cb
+      let action = NotificationsT.InsertCallback (NotificationsT.UpdateJobProgress taskId) ("task-" <> show taskId) cb
       ws <- T.read wsNotification
       Notifications.performAction ws action
       exec Nothing