Ensures we generate the automation name based on the port we parse from the websocket URL vs. hardcoding it to 8080

Author: ddellacosta

generate-allure-site/app/Main.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 module Main (main) where
 
 import Control.Lens ((^?), to)
@@ -72,8 +70,8 @@ localizedTimestamp branch suite ts idx' = H.td $ do
 -- and I need to check the data or make this more robust. For now it's
 -- not worth the effort.
 --
-branchRunRowHtml :: String -> String -> String -> Int -> ByteString -> Maybe (Integer, [Html])
-branchRunRowHtml rootPrefix branch suite idx fileData = do
+branchRunHtml :: String -> String -> String -> Int -> ByteString -> Maybe (Integer, [Html])
+branchRunHtml rootPrefix branch suite idx fileData = do
   runUniqueId <- fileData ^? nth idx . key "runUniqueId" . _String
 
   let
@@ -112,7 +110,7 @@ branchRunRowHtml rootPrefix branch suite idx fileData = do
 --
 -- Does the majority of the heavy lifting with stuffing branch rows
 -- into Html (tr) and extracting the most recent timestamp from each
--- branch so we can compare later for sorting.
+-- branch -> suite run so we can compare later for sorting.
 --
 branchesRunsHtml :: String -> [String] -> IO [(Integer, String, [(String, [Html])])]
 branchesRunsHtml rootPrefix branches =
@@ -140,7 +138,7 @@ branchesRunsHtml rootPrefix branches =
               let
                 (newTimestamp, branchSuiteRowHtml) =
                   fromMaybe (0, []) $
-                    branchRunRowHtml rootPrefix branch suite idx fileData
+                    branchRunHtml rootPrefix branch suite idx fileData
               in
                 (max newTimestamp maxTimestamp, branchSuiteHtml <> branchSuiteRowHtml)
 
@@ -223,14 +221,6 @@ branchesPage branches = do
         H.h2 ! A.class_ "m-2 p-1" $ "automation-service - Branch Test Runs"
         branches
 
-getRootPrefix :: IO String
-getRootPrefix = do
-  args <- getArgs
-  pure $ 
-    case args of
-      (rp:_) -> rp
-      _     -> ""
-
 --
 -- this is hacky test page generation code and I'm not being very
 -- careful about configuration, so keep in mind how many assumptions
@@ -255,6 +245,15 @@ generateSite = do
         branchesRuns'
   writeFile "test-runs/index.html" (renderMarkup $ branchesPage $ fold branchesRunsOutput)
 
+  where
+    getRootPrefix :: IO String
+    getRootPrefix = do
+      args <- getArgs
+      pure $
+        case args of
+          (rp:_) -> rp
+          _     -> ""
+
 serve :: IO ()
 serve = do
   args <- getArgs

ui/src/AutomationService/DeviceView.purs

@@ -69,18 +69,19 @@ init = pure <<< initState
 update
   :: forall ws. WebSocket ws
   => Maybe ws
+  -> String
   -> State
   -> Message
   -> Transition Message State
-update ws s = case _ of
+update ws wsPort s = case _ of
   LoadDevices newDevices -> do
     forkVoid $ liftEffect $ debug $ "loaded devices: " <> show newDevices
     forkVoid $ do
       liftEffect $ for_ newDevices $ \d -> do
         let
           -- this needs to get passed in from parent state as config, or something
           subscribeMsg =
-            MQTT.subscribe (deviceTopic (_.name <<< details $ d)) "HTTP 8080"
+            MQTT.subscribe (deviceTopic (_.name <<< details $ d)) $ "HTTP " <> wsPort
           pingStateMsg =
             MQTT.publish (getTopic (_.name <<< details $ d)) $ MQTT.state ""
 
@@ -338,7 +339,7 @@ view { devices, deviceStates } dispatch =
 
         Just cap
           | not (canSet cap.access) ->
-            H.div "" $ H.text "Not allowed to turn this one on chief"
+            H.div "" $ H.text "Not allowed to turn this one on"
 
           | otherwise ->
             H.div "form-check form-switch"

ui/src/AutomationService/Message.purs

@@ -17,7 +17,7 @@ import Data.String.Pattern (Pattern(..), Replacement(..))
 data Message ws
   = SetPage Page
   | DeviceMsg Devices.Message
-  | InitWS ws
+  | InitWS String ws
   | PublishMsgChanged String
   | Publish
 

ui/src/AutomationService/WebSocket.purs

@@ -20,7 +20,7 @@ import Effect.Class (liftEffect)
 import Elmish.Component (Command)
 import Foreign (unsafeFromForeign)
 import Parsing (runParser)
-import Prelude (Unit, (<<<), ($), (<>), (=<<), bind, const, flip, identity, pure)
+import Prelude (Unit, (<<<), ($), (<>), (=<<), bind, const, discard, flip, identity, pure)
 import URI.Authority (_hosts)
 import URI.HierarchicalPart (_authority)
 import URI.Host as Host
@@ -61,32 +61,40 @@ instance WebSocket WS.WebSocket where
 
 connectToWS :: Command Aff (Main.Message WS.WebSocket)
 connectToWS { dispatch } = do
-  wsUrl <- liftEffect getWsUrl
+  {port, wsUrl} <- liftEffect getWsUrl
   ws <- liftEffect $ create wsUrl []
-  liftEffect $ dispatch (Main.InitWS ws)
+  liftEffect $ dispatch (Main.InitWS port ws)
 
 -- URI parsing util
 
-getWsUrl :: Effect String
+getWsUrl :: Effect ({ port :: String, wsUrl :: String })
 getWsUrl = do
   htmlDocument <- Window.document =<< HTML.window
   uriStr <- Document.documentURI <<< HTMLDocument.toDocument $ htmlDocument
   let
     protocolStr = "ws://"
     localhostStr = "localhost"
-    defaultWsUrl = protocolStr <> localhostStr
+    defaultPortAndWsUrl = { port: "", wsUrl: protocolStr <> localhostStr }
     parseUriResult = runParser uriStr $ URI.parser options
   -- this is all very tedious
-  pure $ flip (either $ const defaultWsUrl) parseUriResult $ \uri ->
+  pure $ flip (either $ const defaultPortAndWsUrl) parseUriResult $ \uri ->
     let
       hosts = uri ^? _hierPart <<< _authority <<< _hosts <<< _Just
     in
-     flip (maybe defaultWsUrl) hosts $ case _ of
-       This hostName -> protocolStr <> Host.print hostName
+     flip (maybe defaultPortAndWsUrl) hosts $ case _ of
+       This hostName ->
+         { port: ""
+         , wsUrl: (protocolStr <> Host.print hostName)
+         }
        -- this would be strange ¯\_(ツ)_/¯
-       That port -> defaultWsUrl <> Port.print port
+       That port ->
+         { port: Port.print port
+         , wsUrl: (defaultPortAndWsUrl.wsUrl <> Port.print port)
+         }
        Both hostName port ->
-         protocolStr <> Host.print hostName <> Port.print port
+         { port: Port.print port
+         , wsUrl: (protocolStr <> Host.print hostName <> Port.print port)
+         }
 
 options :: Record (URIOptions UserInfo (HostPortPair Host Port) Path HierPath Query Fragment)
 options =

ui/src/Main.purs

@@ -40,6 +40,7 @@ type State ws =
   , publishMsg :: String
   , lastSentMsg :: Maybe String
   , websocket :: Maybe ws
+  , websocketPort :: String
   }
 
 init
@@ -58,6 +59,7 @@ init newDsUpdateTimers connectToWS = do
     , publishMsg: "{}"
     , lastSentMsg: Nothing
     , websocket: Nothing
+    , websocketPort: ""
     }
 
 update
@@ -70,10 +72,10 @@ update s = case _ of
     pure $ s { currentPage = newPage }
 
   DeviceMsg deviceMsg -> do
-    Devices.update s.websocket s.devices deviceMsg #
+    Devices.update s.websocket s.websocketPort s.devices deviceMsg #
       bimap DeviceMsg (s { devices = _ })
 
-  InitWS ws -> do
+  InitWS wsPort ws -> do
     forks $ \{ dispatch: msgSink } -> do
       let
         msgSink' = msgSink <<< DeviceMsg
@@ -136,7 +138,7 @@ update s = case _ of
 
       liftEffect $ addWSEventListener ws messageHandler
 
-    pure $ s { websocket = Just ws }
+    pure $ s { websocket = Just ws, websocketPort = wsPort }
 
   PublishMsgChanged msg -> do
     pure $ s { publishMsg = msg }

ui/test/src/Test/Main.purs

@@ -73,7 +73,7 @@ instance WebSocket TestWS where
 
 connectToWS :: TestWS -> Command Aff (Message TestWS)
 connectToWS wsState { dispatch: msgSink } =
-  liftEffect <<< msgSink <<< InitWS $ wsState
+  liftEffect <<< msgSink <<< InitWS "" $ wsState
 
 sendMessage :: EventTarget -> String -> Effect Unit
 sendMessage ws msg = do