From e2d8f74823c7139ce1ccd0831876e361fcd6c419 Mon Sep 17 00:00:00 2001
From: Paul Oliver <contact@pauloliver.dev>
Date: Sat, 3 Jan 2026 16:05:41 +0000
Subject: Adds motor control to frontend

---
 hsm-drive/Hsm/Drive.hs          | 10 ++---
 hsm-web/Client/src/App.vue      |  5 ++-
 hsm-web/Client/src/MotorCtl.vue | 98 +++++++++++++++++++++++++++++++++--------
 hsm-web/Hsm/Web.hs              | 48 +++++++++++++++-----
 hsm-web/Main.hs                 | 29 +++++++-----
 hsm-web/hsm-web.cabal           |  8 ++++
 6 files changed, 150 insertions(+), 48 deletions(-)

diff --git a/hsm-drive/Hsm/Drive.hs b/hsm-drive/Hsm/Drive.hs
index 0114f4c..3f6a071 100644
--- a/hsm-drive/Hsm/Drive.hs
+++ b/hsm-drive/Hsm/Drive.hs
@@ -40,12 +40,12 @@ data Direction
   | SW
   | W
   | NW
-  deriving Show
+  deriving (Read, Show)
 
 data Angle
   = CCW
   | CW
-  deriving Show
+  deriving (Read, Show)
 
 data Speed
   = Slow8
@@ -54,7 +54,7 @@ data Speed
   | Slow
   | Fast
   | Top
-  deriving Show
+  deriving (Read, Show)
 
 type Duration = Float
 
@@ -62,7 +62,7 @@ data Action
   = Move Direction Speed Duration
   | Tilt Angle Speed Duration
   | Stop Duration
-  deriving Show
+  deriving (Read, Show)
 
 -- Maps a `Speed` value to a corresponding PWM cycle duration.
 -- It assumes a stepper motor with 200 steps per revolution, using a 1/16
@@ -117,7 +117,7 @@ step = PWM3
 -- Executes a sequence of drive actions with interruption support
 -- Wakes motors from SLEEP mode during execution and guarantees return to SLEEP
 -- mode upon completion or interruption.
-drive :: (GPIO :> es, IOE :> es, Logs '["drive", "gpio", "pwm"] es, PWM :> es) => [Action] -> Eff es ()
+drive :: (GPIO :> es, Logs '["drive", "gpio", "pwm"] es, PWM :> es) => [Action] -> Eff es ()
 drive actions =
   bracket_ awaken sleep . handle handler . forM_ actions $ \action -> do
     logMsg @"drive" Trace $ "Running action: " <> show action
diff --git a/hsm-web/Client/src/App.vue b/hsm-web/Client/src/App.vue
index a4c8338..4645034 100644
--- a/hsm-web/Client/src/App.vue
+++ b/hsm-web/Client/src/App.vue
@@ -54,7 +54,10 @@ button {
   padding:          0;
 }
 button:active {
-  background-color: #0a414b;
+  opacity: 0.5;
+}
+button:disabled {
+  opacity: 0.5;
 }
 input {
   background-color: transparent;
diff --git a/hsm-web/Client/src/MotorCtl.vue b/hsm-web/Client/src/MotorCtl.vue
index b1c53b2..d7d026e 100644
--- a/hsm-web/Client/src/MotorCtl.vue
+++ b/hsm-web/Client/src/MotorCtl.vue
@@ -4,27 +4,37 @@
     <tbody>
       <tr>
         <td>
-          <button :id='ccw' class='bmot'>{{ dirIcons.ccw }}</button>
+          <button :class='bdirClass("ccw")' @click='nextDir = "ccw"' :disabled='armed'>
+            {{ dirIcons.ccw }}
+          </button>
         </td>
         <td>
           <table id='tmot'>
             <tbody>
               <tr v-for='ds in [["nw", "n", "ne"], ["w", "", "e"], ["sw", "s", "se"]]' :key='ds.id'>
                 <td v-for='d in ds' :key='d.id'>
-                  <button v-if='d' :id='d' class='bmot'>{{ dirIcons[d] }}</button>
+                  <button v-if='d' :class='bdirClass(d)' @click='nextDir = d' :disabled='armed'>
+                    {{ dirIcons[d] }}
+                  </button>
                 </td>
               </tr>
             </tbody>
           </table>
         </td>
         <td>
-          <button :id='cw' class='bmot'>{{ dirIcons.cw }}</button>
+          <button :class='bdirClass("cw")' @click='nextDir = "cw"' :disabled='armed'>
+            {{ dirIcons.cw }}
+          </button>
         </td>
         <td>
           <table id='tspeed'>
             <tbody>
-              <tr v-for='s in ["Top", "Fast", "Slow", "Slow2", "Slow4"]' :key='s.id'>
-                <td><button id='s{{ s.toLowerCase() }}'>{{ s }}</button></td>
+              <tr v-for='s in ["top", "fast", "slow", "slow2", "slow4"]' :key='s.id'>
+                <td>
+                  <button :class='bspeedClass(s)' @click='nextSpeed = s' :disabled='armed'>
+                    {{ s }}
+                  </button>
+                </td>
               </tr>
             </tbody>
           </table>
@@ -32,8 +42,12 @@
         <td>
           <table id='ttime'>
             <tbody>
-              <tr v-for='t in ["4s", "2s", "1s", "hs", "qs"]' :key='t.id'>
-                <td><button id='t{{ t }}'>{{ t }}</button></td>
+              <tr v-for='t in ["4s", "2s", "1s", "0.5s", "0.25s"]' :key='t.id'>
+                <td>
+                  <button :class='btimeClass(t)' @click='nextTime = t' :disabled='armed'>
+                    {{ t }}
+                  </button>
+                </td>
               </tr>
             </tbody>
           </table>
@@ -41,28 +55,27 @@
       </tr>
     </tbody>
   </table>
-  <table id='thist'>
+  <table id='tcmd'>
     <tbody>
       <tr>
-        <td><input id='ihist' placeholder='command' disabled /></td>
-        <td v-for='h in ["hup", "hdown"]' :key='h.id'>
-          <button id='{{ h }}'>{{ h }}</button>
-        </td>
+        <td><input id='ihist' :value='renderCommand()' disabled /></td>
       </tr>
     </tbody>
   </table>
   <table id='tarm'>
     <tbody>
       <tr>
-        <td v-for='a in ["arm", "dispatch"]' :key='a.id'>
-          <button id='{{ a }}'>{{ a }}</button>
-        </td>
+        <td><button id='arm' @click='armed = !armed' :disabled='running'>{{ armed ? 'disarm' : 'arm' }}</button></td>
+        <td><button id='dispatch' @click='dispatch()' :disabled='!armed || running'>dispatch</button></td>
       </tr>
     </tbody>
   </table>
 </template>
 
 <script>
+import axios  from 'axios'
+import config from './config'
+
 export default {
   data() {
     return {
@@ -77,12 +90,42 @@ export default {
         nw:  '↖',
         ccw: '↺',
         cw:  '↻'
-      }
+      },
+      nextDir:   'n',
+      nextSpeed: 'slow',
+      nextTime:  '1s',
+      armed:     false,
+      running:   false
     }
   },
-  mounted() {
-  },
   methods: {
+    bdirClass(d) {
+      return 'bmot' + (d == this.nextDir ? ' bhigh' : '')
+    },
+    bspeedClass(d) {
+      return d == this.nextSpeed ? 'bhigh' : ''
+    },
+    btimeClass(t) {
+      return t == this.nextTime ? 'bhigh' : ''
+    },
+    renderCommand() {
+      const cmd   =  ['ccw', 'cw'].includes(this.nextDir) ? 'Tilt' : 'Move'
+      const dir   = this.nextDir.toUpperCase()
+      const speed = this.nextSpeed.charAt(0).toUpperCase() + this.nextSpeed.slice(1)
+      const time  = this.nextTime.slice(0, -1)
+
+      return `${cmd} ${dir} ${speed} ${time}`
+    },
+    async dispatch() {
+      this.running = true
+
+      const res = await axios.get(config.api + '/command?cmd=' + this.renderCommand())
+
+      if (res.status == 200) {
+        this.armed   = false
+        this.running = false
+      }
+    }
   }
 }
 </script>
@@ -92,11 +135,28 @@ export default {
   height: 33%;
   width:  33%;
 }
-#tmain td, #thist td {
+#tmain td, #tcmd td {
   background-color: #2aa198;
 }
 .bmot {
   font-size:   16px;
   font-weight: bold;
 }
+.bhigh {
+  background-color: #b58900;
+  color:            #073642;
+}
+#tarm td:nth-child(1) {
+  width: 30%;
+}
+#arm {
+  background-color: #dc322f;
+}
+#dispatch {
+  background-color: #859900;
+}
+#arm, #dispatch {
+  color:       #073642;
+  font-weight: bold;
+}
 </style>
diff --git a/hsm-web/Hsm/Web.hs b/hsm-web/Hsm/Web.hs
index f7fddad..a99ba5b 100644
--- a/hsm-web/Hsm/Web.hs
+++ b/hsm-web/Hsm/Web.hs
@@ -9,6 +9,7 @@ module Hsm.Web
 where
 
 import Data.Aeson (encode)
+import Data.Maybe (fromJust, isJust)
 import Effectful (Dispatch (Static), DispatchOf, Eff, IOE, liftIO, (:>))
 import Effectful.Concurrent (Concurrent)
 import Effectful.Dispatch.Static
@@ -22,13 +23,29 @@ import Effectful.Dispatch.Static
 import Effectful.Dispatch.Static.Primitive (Env)
 import Effectful.Exception (finally)
 import Effectful.Fail (Fail)
+import Hsm.Drive (Action, Drive, drive)
+import Hsm.GPIO (GPIO)
 import Hsm.INA226 (I2CINA226, INA226, readINA226State)
 import Hsm.Log (Logs, Severity (Info, Trace), logMsg, makeLoggerIO)
+import Hsm.PWM (PWM)
 import Hsm.Stream (Stream, isStreaming, startStream, stopStream)
+import Network.HTTP.Types.Status (status400)
 import Network.Wai.Handler.Warp (defaultSettings, setLogger)
 import Network.Wai.Middleware.Static (addBase, noDots, staticPolicy, (>->))
 import Paths_hsm_web (getDataFileName)
-import Web.Scotty (Options (settings, verbose), defaultOptions, file, get, middleware, raw, scottyOpts, setHeader)
+import Text.Read (readMaybe)
+import Web.Scotty
+  ( Options (settings, verbose)
+  , defaultOptions
+  , file
+  , get
+  , middleware
+  , queryParamMaybe
+  , raw
+  , scottyOpts
+  , setHeader
+  , status
+  )
 
 data Web (a :: * -> *) (b :: *)
 
@@ -39,10 +56,13 @@ newtype instance StaticRep Web
 
 server
   :: ( Concurrent :> es
+     , Drive :> es
      , Fail :> es
+     , GPIO :> es
      , I2CINA226 :> es
      , INA226 :> es
-     , Logs '["gst", "i2c", "ina226", "stream"] es
+     , Logs '["drive", "gpio", "gst", "i2c", "ina226", "pwm", "stream"] es
+     , PWM :> es
      , Stream :> es
      )
   => Options
@@ -54,30 +74,34 @@ server options env = do
     -- Index and static files
     middleware . staticPolicy $ noDots >-> addBase dist
     get "/" . file $ dist <> "index.html"
+    -- Battery status
     get "/ina226" $ do
       setHeader "Content-Type" "application/json"
       res <- liftIO $ unEff readINA226State env
       raw $ encode res
     -- Camera stream control endpoints
-    get "/startStream" $ do
-      setHeader "Content-Type" "text/plain"
-      liftIO $ unEff startStream env
-      raw "Started stream"
-    get "/stopStream" $ do
-      setHeader "Content-Type" "text/plain"
-      liftIO $ unEff stopStream env
-      raw "Stopped stream"
+    get "/startStream" . liftIO $ unEff startStream env
+    get "/stopStream" $ liftIO $ unEff stopStream env
     get "/isStreaming" $ do
       setHeader "Content-Type" "text/plain"
       res <- liftIO $ unEff isStreaming env
       raw $ encode res
+    -- Motion control
+    get "/command" $ do
+      cmd <- (>>= readMaybe @Action) <$> queryParamMaybe "cmd"
+      if isJust cmd
+        then liftIO $ unEff (drive [fromJust cmd]) env
+        else status status400
 
 runServer
   :: ( Concurrent :> es
+     , Drive :> es
      , Fail :> es
+     , GPIO :> es
      , I2CINA226 :> es
      , INA226 :> es
-     , Logs '["gst", "i2c", "ina226", "stream", "web"] es
+     , Logs '["drive", "gpio", "gst", "i2c", "ina226", "pwm", "stream", "web"] es
+     , PWM :> es
      , Stream :> es
      , Web :> es
      )
@@ -96,5 +120,5 @@ runWeb action = do
   scottyLogger <- logRequest <$> makeLoggerIO @"scotty"
   evalStaticRep (Web $ options scottyLogger) action
   where
-    logRequest loggerIO request status fileSize = loggerIO Trace $ unwords [show request, show status, show fileSize]
+    logRequest loggerIO request code fileSize = loggerIO Trace $ unwords [show request, show code, show fileSize]
     options logger = defaultOptions{verbose = 0, settings = setLogger logger defaultSettings}
diff --git a/hsm-web/Main.hs b/hsm-web/Main.hs
index 0eb5237..6a9b452 100644
--- a/hsm-web/Main.hs
+++ b/hsm-web/Main.hs
@@ -6,28 +6,35 @@ import Effectful (runEff)
 import Effectful.Concurrent (runConcurrent)
 import Effectful.Fail (runFailIO)
 import Hsm.Core.App (bootstrapAppNoEcho)
+import Hsm.Drive (runDrive)
+import Hsm.GPIO (runGPIO)
 import Hsm.I2C (runI2C)
 import Hsm.INA226 (runINA226)
 import Hsm.Log (Severity (Info), runLogsOpt)
 import Hsm.Log.Options (makeLoggerOptionParser)
+import Hsm.PWM (runPWM)
 import Hsm.Stream (runStream)
 import Hsm.Web (runServer, runWeb)
 -- Import full module for cleaner `-ddump-splices` output
 -- Avoids package/module qualifiers in generated code
 import Options.Applicative
 
-type Logs = '["gst", "i2c", "ina226", "scotty", "stream", "web"]
+type Logs = '["drive", "gpio", "gst", "i2c", "ina226", "pwm", "scotty", "stream", "web"]
 
 $(makeLoggerOptionParser @Logs "Options" "parser" 'Info)
 
 main :: IO ()
-main = bootstrapAppNoEcho parser "Launch HsMouse Web Server" $ \opts ->
-  runServer
-    & runWeb
-    & runStream
-    & runINA226
-    & runI2C
-    & runLogsOpt @Options @Logs opts
-    & runConcurrent
-    & runFailIO
-    & runEff
+main =
+  bootstrapAppNoEcho parser "Launch HsMouse Web Server" $ \opts ->
+    runServer
+      & runWeb
+      & runStream
+      & runINA226
+      & runI2C
+      & runDrive
+      & runGPIO @"hsm-web"
+      & runPWM
+      & runLogsOpt @Options @Logs opts
+      & runConcurrent
+      & runFailIO
+      & runEff
diff --git a/hsm-web/hsm-web.cabal b/hsm-web/hsm-web.cabal
index 4c2a9b8..1eb1136 100644
--- a/hsm-web/hsm-web.cabal
+++ b/hsm-web/hsm-web.cabal
@@ -15,9 +15,13 @@ library
     , effectful
     , effectful-core
     , effectful-plugin
+    , hsm-drive
+    , hsm-gpio
     , hsm-ina226
     , hsm-log
+    , hsm-pwm
     , hsm-stream
+    , http-types
     , scotty
     , wai-middleware-static
     , warp
@@ -38,10 +42,14 @@ executable hsm-web
     , effectful-core
     , effectful-plugin
     , hsm-core
+    , hsm-drive
+    , hsm-gpio
     , hsm-i2c
     , hsm-ina226
     , hsm-log
+    , hsm-pwm
     , hsm-stream
+    , http-types
     , optparse-applicative
     , scotty
     , wai-middleware-static
-- 
cgit v1.2.1