------------------------------------------------------------------------------- -- | -- Module : System.Hardware.Arduino.Comm -- Copyright : (c) Levent Erkok -- License : BSD3 -- Maintainer : erkokl@gmail.com -- Stability : experimental -- -- Basic serial communication routines ------------------------------------------------------------------------------- {-# LANGUAGE NamedFieldPuns #-} module System.Hardware.Arduino.Comm where import Control.Monad (when, forever) import Control.Concurrent (myThreadId, throwTo, newChan, newMVar, putMVar, writeChan, readChan, forkIO, modifyMVar_) import Control.Exception (tryJust, AsyncException(UserInterrupt)) import Control.Monad.State (runStateT, gets, liftIO, modify) import Data.Bits (testBit) import System.Posix.Signals (installHandler, keyboardSignal, Handler(Catch)) import qualified Data.ByteString as B (unpack, length) import qualified Data.Map as M (empty, mapWithKey) import qualified Data.Set as S (empty) import qualified System.Hardware.Serialport as S (withSerial, defaultSerialSettings, CommSpeed(CS57600), commSpeed, recv, send) import System.Hardware.Arduino.Data import System.Hardware.Arduino.Utils import System.Hardware.Arduino.Protocol -- | Run the Haskell program to control the board: -- -- * The file path argument should point to the device file that is -- associated with the board. ('COM1' on Windows, -- '/dev/cu.usbmodemfd131' on Mac, etc.) -- -- * The boolean argument controls verbosity. It should remain -- 'False' unless you have communication issues. The print-out -- is typically less-than-useful, but it might point to the root -- cause of the problem. -- -- See "System.Hardware.Arduino.Examples.Blink" for a simple example. withArduino :: Bool -- ^ If 'True', debugging info will be printed -> FilePath -- ^ Path to the USB port -> Arduino () -- ^ The Haskell controller program to run -> IO () withArduino verbose fp program = do tid <- myThreadId _ <- installHandler keyboardSignal (Catch (throwTo tid UserInterrupt)) Nothing debugger <- mkDebugPrinter verbose debugger $ "Accessing arduino located at: " ++ show fp let Arduino controller = do initialize program S.withSerial fp S.defaultSerialSettings{S.commSpeed = S.CS57600} $ \port -> do let initBoardState = BoardState { analogReportingPins = S.empty , digitalReportingPins = S.empty , pinStates = M.empty , digitalWakeUpQueue = [] } bs <- newMVar initBoardState dc <- newChan let initState = ArduinoState { message = debugger , port = port , firmataID = "Unknown" , capabilities = BoardCapabilities M.empty , boardState = bs , deviceChannel = dc } res <- tryJust catchCtrlC $ runStateT controller initState case res of Left () -> putStrLn "hArduino: Caught Ctrl-C, quitting.." _ -> return () where catchCtrlC UserInterrupt = Just () catchCtrlC _ = Nothing -- | Send down a request. send :: Request -> Arduino () send req = do debug $ "Sending: " ++ show req ++ " <" ++ unwords (map showByte (B.unpack p)) ++ ">" serial <- gets port sent <- liftIO $ S.send serial p when (sent /= lp) (debug $ "Send failed. Tried: " ++ show lp ++ "bytes, reported: " ++ show sent) where p = package req lp = B.length p -- | Receive a sys-ex response. This is a blocking call. recv :: Arduino Response recv = do ch <- gets deviceChannel liftIO $ readChan ch -- | Start a thread to listen to the board and populate the channel with incoming queries. -- NB. This function is run in a thread; so be careful not to throw error or die otherwise -- in here. setupListener :: Arduino () setupListener = do serial <- gets port dbg <- gets message chan <- gets deviceChannel let getBytes n = do let go need sofar | need <= 0 = return $ reverse sofar | True = do b <- S.recv serial need case B.length b of 0 -> go need sofar l -> go (need - l) (b : sofar) chunks <- go n [] return $ concatMap B.unpack chunks collectSysEx sofar = do [b] <- getBytes 1 if b == firmataCmdVal END_SYSEX then return $ reverse sofar else collectSysEx (b : sofar) listener bs = do [cmd] <- getBytes 1 resp <- case getFirmataCmd cmd of Left unknown -> return $ Unimplemented (Just (show unknown)) [] Right START_SYSEX -> unpackageSysEx `fmap` collectSysEx [] Right nonSysEx -> unpackageNonSysEx getBytes nonSysEx case resp of Unimplemented{} -> dbg $ "Ignoring the received response: " ++ show resp DigitalMessage p l h -> do dbg $ "Updating port " ++ show p ++ " values with " ++ showByteList [l,h] modifyMVar_ bs $ \bst -> do let upd o od | p /= pinPort o = od -- different port, no change | pinMode od `notElem` [INPUT] = od -- not an input pin, ignore | True = od{pinValue = Just (Left newVal)} where idx = pinPortIndex o newVal | idx <= 6 = l `testBit` fromIntegral idx | True = h `testBit` fromIntegral (idx - 7) let wakeUpQ = digitalWakeUpQueue bst bst' = bst{ pinStates = M.mapWithKey upd (pinStates bst) , digitalWakeUpQueue = [] } mapM_ (`putMVar` ()) wakeUpQ return bst' _ -> do dbg $ "Received " ++ show resp writeChan chan resp bs <- gets boardState tid <- liftIO $ forkIO $ forever (listener bs) debug $ "Started listener thread: " ++ show tid -- | Initialize our board, get capabilities, etc initialize :: Arduino () initialize = do -- Step 1: Set up the listener thread setupListener -- Step 2: Send query-firmware, and wait until we get a response handshake QueryFirmware (\r -> case r of {Firmware{} -> True; _ -> False}) (\(Firmware v1 v2 m) -> modify (\s -> s{firmataID = "Firmware v" ++ show v1 ++ "." ++ show v2 ++ "(" ++ m ++ ")"})) -- Step 3: Send a capabilities request handshake CapabilityQuery (\r -> case r of {Capabilities{} -> True; _ -> False}) (\(Capabilities c) -> modify (\s -> s{capabilities = c})) -- Step 4: Send analog-mapping query handshake AnalogMappingQuery (\r -> case r of {AnalogMapping{} -> True; _ -> False}) (\(AnalogMapping bs) -> do BoardCapabilities m <- gets capabilities modify (\s -> s{capabilities = BoardCapabilities (M.mapWithKey (mapAnalog bs) m)})) -- We're done, print capabilities in debug mode cs <- gets capabilities dbg <- gets message liftIO $ dbg $ "Handshake complete. Board capabilities:\n" ++ show cs where handshake msg isOK process = do dbg <- gets message send msg let wait = do resp <- recv if isOK resp then process resp else do liftIO $ dbg $ "Skpping unexpected response: " ++ show resp wait wait mapAnalog bs p c | i < rl && m /= 0x7f = (Just m, snd c) | True -- out-of-bounds, or not analog; ignore = c where rl = length bs i = fromIntegral (pinNo p) m = bs !! i