Add higher-order component for connecting to global state

src/Component/HOC/Connect.purs

@@ -0,0 +1,84 @@
+-- | This higher-order component exists to wrap other components which
+-- | need to connect to the user data in global application state and 
+-- | stay in sync with changes to that data.
+module Component.HOC.Connect where
+
+import Prelude
+
+import Conduit.Component.Utils (busEventSource)
+import Conduit.Data.Profile (Profile)
+import Conduit.Env (UserEnv)
+import Control.Monad.Reader (class MonadAsk, asks)
+import Data.Maybe (Maybe(..))
+import Data.Symbol (SProxy(..))
+import Effect.Aff.Class (class MonadAff)
+import Effect.Ref as Ref
+import Halogen (liftEffect)
+import Halogen as H
+import Halogen.HTML as HH
+import Prim.Row as Row
+import Record as Record
+
+data Action output
+  = Initialize
+  | HandleUserBus (Maybe Profile)
+  | Emit output
+
+type WithCurrentUser r =
+  ( currentUser :: Maybe Profile | r )
+
+type ChildSlots query output =
+  ( inner :: H.Slot query output Unit )
+
+_inner = SProxy :: SProxy "inner"
+
+-- | This component can re-use the query type and output type of its child
+-- | component because it has no queries or outputs of its own. That makes
+-- | it a transparent wrapper around the inner component.
+component
+  :: forall query input output m r
+   . MonadAff m
+  => MonadAsk { userEnv :: UserEnv | r } m
+  => Row.Lacks "currentUser" input 
+  => H.Component HH.HTML query { | WithCurrentUser input } output m
+  -> H.Component HH.HTML query { | input } output m
+component innerComponent = 
+  H.mkComponent
+    -- here, we'll insert the current user into the wrapped component's input 
+    -- minus the current user
+    { initialState: Record.insert (SProxy :: _ "currentUser") Nothing
+    , render
+    , eval: H.mkEval $ H.defaultEval
+        { handleAction = handleAction
+        , handleQuery = handleQuery
+        , initialize = Just Initialize
+        }
+    }
+  where
+  handleAction = case _ of
+    -- On initialization we'll read the current value of the user in
+    -- state; we'll also subscribe to any updates so we can always 
+    -- stay in sync.
+    Initialize -> do
+      { currentUser, userBus } <- asks _.userEnv
+      _ <- H.subscribe (HandleUserBus <$> busEventSource userBus)
+      mbProfile <- liftEffect $ Ref.read currentUser
+      H.modify_ _ { currentUser = mbProfile }
+
+    -- When the user in global state changes, this event will occur
+    -- and we need to update our local state to stay in sync.
+    HandleUserBus mbProfile ->
+      H.modify_ _ { currentUser = mbProfile }
+
+    Emit output ->
+      H.raise output
+
+  -- We'll simply defer all queries to the existing H.query function, sending
+  -- to the correct slot.
+  handleQuery :: forall a. query a -> H.HalogenM _ _ _ _ _ (Maybe a)
+  handleQuery = H.query _inner unit
+
+  -- We'll simply render the inner component as-is, except with the augmented
+  -- input containing the current user.
+  render state = 
+    HH.slot _inner unit innerComponent state (Just <<< Emit)

src/Component/Router.purs

@@ -7,14 +7,16 @@ module Conduit.Component.Router where
 
 import Prelude
 
+import Component.HOC.Connect (WithCurrentUser)
+import Component.HOC.Connect as Connect
 import Conduit.Capability.LogMessages (class LogMessages)
 import Conduit.Capability.Navigate (class Navigate, navigate)
 import Conduit.Capability.Now (class Now)
 import Conduit.Capability.Resource.Article (class ManageArticle)
 import Conduit.Capability.Resource.Comment (class ManageComment)
 import Conduit.Capability.Resource.Tag (class ManageTag)
 import Conduit.Capability.Resource.User (class ManageUser)
-import Conduit.Component.Utils (OpaqueSlot, busEventSource)
+import Conduit.Component.Utils (OpaqueSlot)
 import Conduit.Data.Profile (Profile)
 import Conduit.Data.Route (Route(..), routeCodec)
 import Conduit.Env (UserEnv)
@@ -26,13 +28,12 @@ import Conduit.Page.Profile as Profile
 import Conduit.Page.Register as Register
 import Conduit.Page.Settings as Settings
 import Conduit.Page.ViewArticle as ViewArticle
-import Control.Monad.Reader (class MonadAsk, asks)
+import Control.Monad.Reader (class MonadAsk)
 import Data.Either (hush)
 import Data.Foldable (elem)
 import Data.Maybe (Maybe(..), fromMaybe, isJust)
 import Data.Symbol (SProxy(..))
 import Effect.Aff.Class (class MonadAff)
-import Effect.Ref as Ref
 import Halogen (liftEffect)
 import Halogen as H
 import Halogen.HTML as HH
@@ -49,7 +50,7 @@ data Query a
 
 data Action 
   = Initialize 
-  | HandleUserBus (Maybe Profile)
+  | Receive { | WithCurrentUser () }
 
 type ChildSlots = 
   ( home :: OpaqueSlot Unit
@@ -72,33 +73,28 @@ component
   => ManageArticle m
   => ManageComment m
   => ManageTag m
-  => H.Component HH.HTML Query Unit Void m
-component = H.mkComponent
-  { initialState: \_ -> { route: Nothing, currentUser: Nothing } 
+  => H.Component HH.HTML Query {} Void m
+component = Connect.component $ H.mkComponent
+  { initialState: \{ currentUser } -> { route: Nothing, currentUser } 
   , render
   , eval: H.mkEval $ H.defaultEval 
       { handleQuery = handleQuery 
       , handleAction = handleAction
+      , receive = Just <<< Receive
       , initialize = Just Initialize
       }
   }
   where 
   handleAction :: Action -> H.HalogenM State Action ChildSlots Void m Unit
   handleAction = case _ of
     Initialize -> do
-      -- first, we'll get the value of the current user and subscribe to updates any time the
-      -- value changes
-      { currentUser, userBus } <- asks _.userEnv
-      _ <- H.subscribe (HandleUserBus <$> busEventSource userBus)
-      mbProfile <- liftEffect (Ref.read currentUser) 
-      H.modify_ _ { currentUser = mbProfile }
-      -- then, we'll get the route the user landed on
+      -- first we'll get the route the user landed on
       initialRoute <- hush <<< (RD.parse routeCodec) <$> liftEffect getHash
-      -- and, finally, we'll navigate to the new route (also setting the hash)
+      -- then we'll navigate to the new route (also setting the hash)
       navigate $ fromMaybe Home initialRoute
 
-    HandleUserBus mbProfile -> do
-      H.modify_ _ { currentUser = mbProfile }
+    Receive { currentUser } ->
+      H.modify_ _ { currentUser = currentUser }
 
   handleQuery :: forall a. Query a -> H.HalogenM State Action ChildSlots Void m (Maybe a)
   handleQuery = case _ of
@@ -126,7 +122,7 @@ component = H.mkComponent
   render { route, currentUser } = case route of
     Just r -> case r of
       Home -> 
-        HH.slot (SProxy :: _ "home") unit Home.component unit absurd
+        HH.slot (SProxy :: _ "home") unit Home.component {} absurd
       Login -> 
         HH.slot (SProxy :: _ "login") unit Login.component { redirect: true } absurd
       Register -> 

src/Main.purs

@@ -122,7 +122,7 @@ main = HA.runHalogenAff do
   --
   -- Let's put it all together. With `hoist`, `runAppM`, our environment, and our router component,
   -- we can produce a proper root component for Halogen to run.  
-    rootComponent :: H.Component HH.HTML Router.Query Unit Void Aff
+    rootComponent :: H.Component HH.HTML Router.Query {} Void Aff
     rootComponent = H.hoist (runAppM environment) Router.component
 
   -- Now we have the two things we need to run a Halogen application: a reference to an HTML element
@@ -138,7 +138,7 @@ main = HA.runHalogenAff do
   -- Note: Since our root component is our router, the "queries" and "messages" above refer to the 
   -- `Query` and `Message` types defined in the `Conduit.Router` module. Only those queries and 
   -- messages can be used, or else you'll get a compiler error.
-  halogenIO <- runUI rootComponent unit body
+  halogenIO <- runUI rootComponent {} body
 
   -- Fantastic! Our app is running and we're almost done. All that's left is to notify the router
   -- any time the location changes in the URL. 

src/Page/Editor.purs

@@ -5,31 +5,29 @@ module Conduit.Page.Editor where
 
 import Prelude
 
+import Component.HOC.Connect as Connect
 import Conduit.Capability.Navigate (class Navigate, navigate)
 import Conduit.Capability.Resource.Article (class ManageArticle, createArticle, getArticle, updateArticle)
 import Conduit.Component.HTML.Header (header)
 import Conduit.Component.HTML.Utils (css, maybeElem)
 import Conduit.Component.TagInput (Tag(..))
 import Conduit.Component.TagInput as TagInput
-import Conduit.Component.Utils (busEventSource)
 import Conduit.Data.Article (ArticleWithMetadata, Article)
 import Conduit.Data.Profile (Profile)
 import Conduit.Data.Route (Route(..))
 import Conduit.Env (UserEnv)
 import Conduit.Form.Field as Field
 import Conduit.Form.Validation (errorToString)
 import Conduit.Form.Validation as V
-import Control.Monad.Reader (class MonadAsk, asks)
+import Control.Monad.Reader (class MonadAsk)
 import Data.Const (Const)
 import Data.Foldable (for_)
 import Data.Maybe (Maybe(..), isJust)
 import Data.Newtype (class Newtype, unwrap)
 import Data.Set as Set
 import Data.Symbol (SProxy(..))
 import Effect.Aff.Class (class MonadAff)
-import Effect.Ref as Ref
 import Formless as F
-import Halogen (liftEffect)
 import Halogen as H
 import Halogen.HTML as HH
 import Halogen.HTML.Events as HE
@@ -39,7 +37,7 @@ import Slug (Slug)
 
 data Action
   = Initialize
-  | HandleUserBus (Maybe Profile)
+  | Receive { slug :: Maybe Slug, currentUser :: Maybe Profile }
   | HandleEditor Article
 
 type State =
@@ -61,22 +59,22 @@ component
   => Navigate m
   => ManageArticle m
   => H.Component HH.HTML (Const Void) Input Void m
-component = H.mkComponent
-  { initialState: \{ slug } -> { article: NotAsked, currentUser: Nothing, slug }
+component = Connect.component $ H.mkComponent
+  -- due to the use of `Connect.component`, our input now also has `currentUser`
+  -- in it, even though this component's only input is a slug.
+  { initialState: \{ currentUser, slug } -> { article: NotAsked, currentUser, slug }
   , render
   , eval: H.mkEval $ H.defaultEval
       { handleAction = handleAction
+      , receive = Just <<< Receive
       , initialize = Just Initialize
       }
   }
   where
   handleAction :: Action -> H.HalogenM State Action ChildSlots Void m Unit
   handleAction = case _ of
-    Initialize ->  do
-      { currentUser, userBus } <- asks _.userEnv
-      _ <- H.subscribe (HandleUserBus <$> busEventSource userBus)
-      mbProfile <- liftEffect $ Ref.read currentUser
-      st <- H.modify _ { currentUser = mbProfile }
+    Initialize -> do
+      st <- H.get
       for_ st.slug \slug -> do
         H.modify_ _ { article = Loading }
         mbArticle <- getArticle slug
@@ -88,16 +86,15 @@ component = H.mkComponent
           _ <- H.query F._formless unit $ F.asQuery $ F.loadForm newFields
           pure unit
 
-    HandleUserBus mbProfile ->
-      H.modify_ _ { currentUser = mbProfile }
+    Receive { currentUser } ->
+      H.modify_ _ { currentUser = currentUser }
 
     HandleEditor article -> do
       st <- H.get
       mbArticleWithMetadata <- case st.slug of
         Nothing -> createArticle article
         Just s -> updateArticle s article
-      let
-        slug = _.slug <$> mbArticleWithMetadata
+      let slug = _.slug <$> mbArticleWithMetadata
       H.modify_ _ { article = fromMaybe mbArticleWithMetadata, slug = slug }
       for_ slug (navigate <<< ViewArticle)
 

src/Page/Home.purs

@@ -4,6 +4,7 @@ module Conduit.Page.Home where
 
 import Prelude
 
+import Component.HOC.Connect as Connect
 import Conduit.Api.Endpoint (ArticleParams, Pagination, noArticleParams)
 import Conduit.Capability.Navigate (class Navigate)
 import Conduit.Capability.Resource.Article (class ManageArticle, getArticles, getCurrentUserFeed)
@@ -13,13 +14,12 @@ import Conduit.Component.HTML.Footer (footer)
 import Conduit.Component.HTML.Header (header)
 import Conduit.Component.HTML.Utils (css, maybeElem, whenElem)
 import Conduit.Component.Part.FavoriteButton (favorite, unfavorite)
-import Conduit.Component.Utils (busEventSource)
 import Conduit.Data.Article (ArticleWithMetadata)
 import Conduit.Data.PaginatedArray (PaginatedArray)
 import Conduit.Data.Profile (Profile)
 import Conduit.Data.Route (Route(..))
 import Conduit.Env (UserEnv)
-import Control.Monad.Reader (class MonadAsk, asks)
+import Control.Monad.Reader (class MonadAsk)
 import Data.Const (Const)
 import Data.Lens (Traversal')
 import Data.Lens.Index (ix)
@@ -28,8 +28,6 @@ import Data.Maybe (Maybe(..), isJust, isNothing)
 import Data.Monoid (guard)
 import Data.Symbol (SProxy(..))
 import Effect.Aff.Class (class MonadAff)
-import Effect.Ref as Ref
-import Halogen (liftEffect)
 import Halogen as H
 import Halogen.HTML as HH
 import Halogen.HTML.Events as HE
@@ -40,7 +38,7 @@ import Web.UIEvent.MouseEvent (MouseEvent, toEvent)
 
 data Action
   = Initialize
-  | HandleUserBus (Maybe Profile)
+  | Receive { currentUser :: Maybe Profile }
   | ShowTab Tab
   | LoadFeed Pagination
   | LoadArticles ArticleParams
@@ -53,8 +51,8 @@ type State =
   { tags :: RemoteData String (Array String)
   , articles :: RemoteData String (PaginatedArray ArticleWithMetadata)
   , tab :: Tab
-  , currentUser :: Maybe Profile
   , page :: Int
+  , currentUser :: Maybe Profile
   }
 
 data Tab
@@ -75,40 +73,39 @@ component
   => Navigate m
   => ManageTag m
   => ManageArticle m
-  => H.Component HH.HTML (Const Void) Unit Void m
-component = H.mkComponent
+  => H.Component HH.HTML (Const Void) {} Void m
+component = Connect.component $ H.mkComponent
   { initialState
   , render
   , eval: H.mkEval $ H.defaultEval
       { handleAction = handleAction
+      , receive = Just <<< Receive
       , initialize = Just Initialize
       }
   }
   where
-  initialState :: Unit -> State
-  initialState _ =
+  initialState { currentUser } =
     { tags: NotAsked
     , articles: NotAsked
     , tab: Global
-    , currentUser: Nothing
+    , currentUser
     , page: 1
     }
 
   handleAction :: Action -> H.HalogenM State Action () Void m Unit
   handleAction = case _ of
     Initialize -> do
-      { currentUser, userBus } <- asks _.userEnv
-      _ <- H.subscribe (HandleUserBus <$> busEventSource userBus)
       void $ H.fork $ handleAction LoadTags
-      liftEffect (Ref.read currentUser) >>= case _ of
+      state <- H.get
+      case state.currentUser of
         Nothing ->
           void $ H.fork $ handleAction $ LoadArticles noArticleParams
         profile -> do
           void $ H.fork $ handleAction $ LoadFeed { limit: Just 20, offset: Nothing }
-          H.modify_ _ { currentUser = profile, tab = Feed }
+          H.modify_ _ { tab = Feed }
 
-    HandleUserBus profile ->
-      H.modify_ _ { currentUser = profile }
+    Receive { currentUser } ->
+      H.modify_ _ { currentUser = currentUser }
 
     LoadTags -> do
       H.modify_ _ { tags = Loading}