diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,10 @@ +# Version [0.1.0.0](https://github.com/DistRap/hocd/compare/6a16c2d...0.1.0.0) (2023-12-26) + +* Initial release + +--- + +`hocd` uses [PVP Versioning][1]. + +[1]: https://pvp.haskell.org + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright sorki (c) 2023 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.lhs b/README.lhs new file mode 100644 --- /dev/null +++ b/README.lhs @@ -0,0 +1,68 @@ +[![GitHub Workflow Status](https://img.shields.io/github/actions/workflow/status/DistRap/hocd/ci.yaml?branch=main)](https://github.com/DistRap/hocd/actions/workflows/ci.yaml) +[![Hackage version](https://img.shields.io/hackage/v/hocd.svg?color=success)](https://hackage.haskell.org/package/hocd) +[![Dependencies](https://img.shields.io/hackage-deps/v/hocd?label=Dependencies)](https://packdeps.haskellers.com/feed?needle=hocd) + +# hocd + +[OpenOCD] RPC service client. + +[OpenOCD]: https://openocd.org/ + +## API + +See Haddocks or [HOCD.Monad] + +[HOCD.Monad]: ./src/HOCD/Monad.hs + +## Example + +```haskell +{-# LANGUAGE TypeApplications #-} + +import Data.Word (Word32) +import HOCD + +main :: IO () +main = runOCD example >>= print + +-- | For STM32G474 +example + :: MonadOCD m + => m ([Word32], Word32) +example = do + halt' + + -- Read RCC.CR register + rccCr <- readMemCount @Word32 0x40021000 2 + + -- Read and increment GPIOA.ODR register + let gpioaOdr = 0x48000014 + odr <- readMem32 gpioaOdr + writeMem gpioaOdr [odr+1] + r <- readMem32 gpioaOdr + + pure (rccCr, r) +``` + +This example is runnable from git repository using: + +```sh +openocd -f nucleo.cfg +cabal run hocd-readme +``` + +## Executable + +`hocd-read-mem` can be used to read a single or multiple +addresses: + +```sh +cabal run hocd-read-mem -- 0x40021000 0x48000014 +``` + +Outputs: + +``` +0x40021000: 0x3030500 +0x48000014: 0x9 +``` diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,68 @@ +[![GitHub Workflow Status](https://img.shields.io/github/actions/workflow/status/DistRap/hocd/ci.yaml?branch=main)](https://github.com/DistRap/hocd/actions/workflows/ci.yaml) +[![Hackage version](https://img.shields.io/hackage/v/hocd.svg?color=success)](https://hackage.haskell.org/package/hocd) +[![Dependencies](https://img.shields.io/hackage-deps/v/hocd?label=Dependencies)](https://packdeps.haskellers.com/feed?needle=hocd) + +# hocd + +[OpenOCD] RPC service client. + +[OpenOCD]: https://openocd.org/ + +## API + +See Haddocks or [HOCD.Monad] + +[HOCD.Monad]: ./src/HOCD/Monad.hs + +## Example + +```haskell +{-# LANGUAGE TypeApplications #-} + +import Data.Word (Word32) +import HOCD + +main :: IO () +main = runOCD example >>= print + +-- | For STM32G474 +example + :: MonadOCD m + => m ([Word32], Word32) +example = do + halt' + + -- Read RCC.CR register + rccCr <- readMemCount @Word32 0x40021000 2 + + -- Read and increment GPIOA.ODR register + let gpioaOdr = 0x48000014 + odr <- readMem32 gpioaOdr + writeMem gpioaOdr [odr+1] + r <- readMem32 gpioaOdr + + pure (rccCr, r) +``` + +This example is runnable from git repository using: + +```sh +openocd -f nucleo.cfg +cabal run hocd-readme +``` + +## Executable + +`hocd-read-mem` can be used to read a single or multiple +addresses: + +```sh +cabal run hocd-read-mem -- 0x40021000 0x48000014 +``` + +Outputs: + +``` +0x40021000: 0x3030500 +0x48000014: 0x9 +``` diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE LambdaCase #-} +module Main where + +import qualified Control.Monad +import qualified Data.Text +import qualified Data.Text.Read +import qualified Text.Printf +import qualified System.Environment +import qualified HOCD + +main :: IO () +main = System.Environment.getArgs >>= \case + [] -> error "No address or multiple addresses to read specified" + [addr] -> do + HOCD.runOCD + $ HOCD.readMem32 + (parseMemAddr addr) + >>= \case + Left e -> error . show $ e + Right v -> + putStrLn + $ Text.Printf.printf "0x%x" v + + addrs -> do + HOCD.runOCD + $ Control.Monad.forM addrs + $ \a -> do + let parsed = parseMemAddr a + v <- HOCD.readMem32 parsed + pure (parsed, v) + >>= \case + Left e -> error . show $ e + Right vs -> + Control.Monad.forM_ + vs + $ \(a, v) -> + putStrLn + $ Text.Printf.printf + "0x%x: 0x%x" + (HOCD.unMemAddress a) + v + where + parseMemAddr a = + case Data.Text.Read.hexadecimal $ Data.Text.pack a of + Left e -> error e + Right (h, _) -> HOCD.memAddr h diff --git a/hocd.cabal b/hocd.cabal new file mode 100644 --- /dev/null +++ b/hocd.cabal @@ -0,0 +1,81 @@ +cabal-version: 2.2 +name: hocd +version: 0.1.0.0 +synopsis: OpenOCD Haskell interface +description: Support for OpenOCDs TCL interface +homepage: https://github.com/DistRap/hocd +license: BSD-3-Clause +license-file: LICENSE +author: sorki +maintainer: srk@48.io +copyright: 2023 sorki +category: Embedded +build-type: Simple + +extra-source-files: + LICENSE + README.md + +extra-doc-files: + CHANGELOG.md + +flag build-readme + default: + False + description: + Build README.lhs example + +library + ghc-options: -Wall + hs-source-dirs: src + exposed-modules: HOCD + , HOCD.Command + , HOCD.Error + , HOCD.Monad + , HOCD.Types + build-depends: base >= 4.7 && < 5 + , bytestring + , data-default-class + , exceptions + , mtl + , network + , transformers + , text + default-language: Haskell2010 + +executable hocd-read-mem + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , hocd + , text + default-language: Haskell2010 + +executable hocd-readme + if !flag(build-readme) + buildable: False + build-depends: + base >=4.12 && <5 + , hocd + build-tool-depends: + markdown-unlit:markdown-unlit + default-language: Haskell2010 + main-is: README.lhs + ghc-options: -pgmL markdown-unlit -Wall + +test-suite hocd-tests + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: ParseSpec + build-tool-depends: + hspec-discover:hspec-discover + build-depends: base >= 4.7 && < 5 + , hocd + , hspec + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/DistRap/hocd diff --git a/src/HOCD.hs b/src/HOCD.hs new file mode 100644 --- /dev/null +++ b/src/HOCD.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE RecordWildCards #-} + +module HOCD + ( runOCD + , module HOCD.Error + , module HOCD.Monad + , module HOCD.Types + ) where + +import Control.Monad.Catch (MonadMask) +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Data.Default.Class (Default(def)) + +import qualified Control.Monad.Catch +import qualified Network.Socket + +import HOCD.Error +import HOCD.Monad +import HOCD.Types + +-- | Run OpenOCD client +-- with defaults ("127.0.0.1:6666") +runOCD + :: ( MonadIO m + , MonadMask m + ) + => OCDT m a + -> m (Either OCDError a) +runOCD = runOCDConfig def + +-- | Run OpenOCD client with @OCDConfig@ +-- allowing to set custom host and port +runOCDConfig + :: ( MonadIO m + , MonadMask m + ) + => OCDConfig + -> OCDT m a + -> m (Either OCDError a) +runOCDConfig OCDConfig{..} act = do + addrInfo <- liftIO $ Network.Socket.getAddrInfo + (Just Network.Socket.defaultHints) + (Just ocdHost) + (Just $ show ocdPort) + + case addrInfo of + (sockAddr:_) -> + Control.Monad.Catch.bracket + (liftIO + $ open + (Network.Socket.addrFamily sockAddr) + (Network.Socket.addrAddress sockAddr) + ) + (liftIO . Network.Socket.close) + (\sock -> runOCDT sock act) + _ -> pure (Left OCDError_GetAddrInfoFailed) + where + open sockFamily sockAddr = do + soc <- + Network.Socket.socket + sockFamily + Network.Socket.Stream + Network.Socket.defaultProtocol + Network.Socket.connect soc sockAddr + pure soc diff --git a/src/HOCD/Command.hs b/src/HOCD/Command.hs new file mode 100644 --- /dev/null +++ b/src/HOCD/Command.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module HOCD.Command + ( Command(..) + , Halt(..) + , Capture(..) + , ReadMemory(..) + , WriteMemory(..) + , subChar + , parseMem + ) where + +import Data.Bits (FiniteBits(..)) +import Data.Kind (Type) +import Data.ByteString (ByteString) +import HOCD.Error (OCDError(..)) +import HOCD.Types (MemAddress(..)) +import Text.Printf (PrintfArg) + +import qualified Control.Monad +import qualified Data.ByteString.Char8 +import qualified Data.Either +import qualified Data.List +import qualified Data.Text +import qualified Data.Text.Read +import qualified Text.Printf + +class Command req where + type Reply req :: Type + + request + :: req + -> ByteString + + default request + :: Show req + => req + -> ByteString + request = + Data.ByteString.Char8.pack + . show + + reply + :: req + -> ByteString + -> Either OCDError (Reply req) + +data Halt = Halt + +instance Show Halt where + show = pure "halt" + +instance Command Halt where + type Reply Halt = ByteString + reply _ = ocdReply + +data Capture a = Capture a + +instance Show a => Show (Capture a) where + show (Capture x) = + unwords + ["capture" + , show $ show x -- escaping + ] + +instance (Command a, Show a) => Command (Capture a) where + type Reply (Capture a) = ByteString + reply _ = ocdReply + +data ReadMemory a = ReadMemory + { readMemoryAddr :: MemAddress + , readMemoryCount :: Int + } + +instance ( FiniteBits a + , Num a + ) => Show (ReadMemory a) where + show ReadMemory{..} = + unwords + [ "read_memory" + , show $ unMemAddress readMemoryAddr + , show $ finiteBitSize (0 :: a) + , show readMemoryCount + ] + +instance ( FiniteBits a + , Integral a + ) => Command (ReadMemory a) where + type Reply (ReadMemory a) = [a] + reply _ r = ocdReply r >>= parseMem + +parseMem + :: ( FiniteBits a + , Integral a + ) + => ByteString + -> Either OCDError [a] +parseMem = + (\case + xs | any Data.Either.isLeft xs -> + Left (OCDError_ParseMemory $ Data.Either.lefts xs) + xs | otherwise -> + pure (Data.Either.rights xs) + ) + . map + ( either + (Left . OCDError_CantReadHex) + (pure . fst) + . Data.Text.Read.hexadecimal + . Data.Text.pack + ) + . words + . Data.ByteString.Char8.unpack + +data WriteMemory a = WriteMemory + { writeMemoryAddr :: MemAddress + , writeMemoryData :: [a] + } + +instance ( FiniteBits a + , PrintfArg a + , Integral a + ) => Show (WriteMemory a) where + show WriteMemory{..} = + unwords + [ "write_memory" + , show $ unMemAddress writeMemoryAddr + , show $ finiteBitSize (0 :: a) + , asTCLList writeMemoryData + ] + where + asTCLList x = + "{" + <> Data.List.intercalate + "," + (map (formatHex @a) x) + <> "}" + formatHex :: PrintfArg t => t -> String + formatHex = Text.Printf.printf "0x%x" + +instance ( FiniteBits a + , Integral a + , PrintfArg a + ) => Command (WriteMemory a) where + type Reply (WriteMemory a) = () + reply _ = ocdReply >>= pure . Control.Monad.void + +ocdReply :: ByteString -> Either OCDError ByteString +ocdReply r | Data.ByteString.Char8.last r /= subChar = + Left $ OCDError_ReplyMissingSubOnEnd r +ocdReply r | otherwise = + Right $ Data.ByteString.Char8.init r + +subChar :: Char +subChar = '\SUB' diff --git a/src/HOCD/Error.hs b/src/HOCD/Error.hs new file mode 100644 --- /dev/null +++ b/src/HOCD/Error.hs @@ -0,0 +1,13 @@ +module HOCD.Error + ( OCDError(..) + ) where + +import Data.ByteString (ByteString) + +data OCDError + = OCDError_ReplyMissingSubOnEnd ByteString + | OCDError_CantReadHex String + | OCDError_GetAddrInfoFailed + | OCDError_ParseMemory [OCDError] + | OCDError_ExpectedOneButGotMore + deriving (Eq, Show) diff --git a/src/HOCD/Monad.hs b/src/HOCD/Monad.hs new file mode 100644 --- /dev/null +++ b/src/HOCD/Monad.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeApplications #-} + +module HOCD.Monad + ( OCDT + , runOCDT + , MonadOCD(..) + , halt + , halt' + , readMem + , readMem32 + , readMemCount + , writeMem + , writeMem32 + ) where + +import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) +import Control.Monad.Except (MonadError, throwError) +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Control.Monad.Reader (MonadReader, ask) +import Control.Monad.Trans (MonadTrans, lift) +import Control.Monad.Trans.Except (ExceptT, runExceptT) +import Control.Monad.Trans.Reader (ReaderT, runReaderT) +import Data.Bits (FiniteBits(..)) +import Data.ByteString (ByteString) +import Data.Word (Word32) +import HOCD.Command + ( Command(..) + , Capture(..) + , Halt(..) + , ReadMemory(..) + , WriteMemory(..) + , subChar + ) +import HOCD.Error (OCDError(..)) +import HOCD.Types (MemAddress) +import Network.Socket (Socket) +import Text.Printf (PrintfArg) + +import qualified Data.ByteString.Char8 +import qualified Network.Socket.ByteString + +newtype OCDT m a = OCDT + { _unOCDT + :: ExceptT OCDError + (ReaderT Socket m) a + } + deriving + ( Functor + , Applicative + , Monad + , MonadReader Socket + , MonadError OCDError + , MonadCatch + , MonadMask + , MonadThrow + , MonadIO + ) + +instance MonadTrans OCDT where + lift = OCDT . lift . lift + +-- | Run OCDT transformer +runOCDT + :: Monad m + => Socket + -> OCDT m a + -> m (Either OCDError a) +runOCDT sock = + (`runReaderT` sock) + . runExceptT + . _unOCDT + +class ( MonadIO m + , MonadError OCDError m + ) => MonadOCD m where + getSocket :: m Socket + +instance MonadIO m => MonadOCD (OCDT m) where + getSocket = ask + +-- | Perform RPC call +rpc + :: ( MonadOCD m + , Command req + ) + => req + -> m (Reply req) +rpc cmd = do + sock <- getSocket + liftIO $ + Network.Socket.ByteString.sendAll + sock + (rpcCmd $ request cmd) + reply cmd <$> recvTillSub sock + >>= either throwError pure + where + recvTillSub s = do + msg <- + liftIO + $ Network.Socket.ByteString.recv + s + 1024 + if Data.ByteString.Char8.last msg == subChar + then pure msg + else recvTillSub s >>= pure . (msg <>) + + -- | Terminate with \SUB + rpcCmd :: ByteString -> ByteString + rpcCmd = + (<> Data.ByteString.Char8.singleton subChar) + +-- | Halt target +halt + :: MonadOCD m + => m ByteString +halt = rpc $ Capture Halt + +-- | Halt target, discarding reply +halt' + :: MonadOCD m + => m () +halt' = halt >> pure () + +-- | Read multiple memory segments from @MemAddress@ +-- according to count argument. Segment size depends +-- on passed in Word type. +readMemCount + :: forall a m + . ( MonadOCD m + , FiniteBits a + , Integral a + ) + => MemAddress -- ^ Memory address to read from + -> Int -- ^ Count + -> m [a] +readMemCount ma c = + rpc + ReadMemory + { readMemoryAddr = ma + , readMemoryCount = c + } + +-- | Read single memory segment from @MemAddress@ +-- Segment size depends on passed in Word type. +readMem + :: forall a m + . ( MonadOCD m + , FiniteBits a + , Integral a + ) + => MemAddress -- ^ Memory address to read from + -> m a +readMem ma = + readMemCount ma 1 + >>= \case + [one] -> pure one + _ -> throwError OCDError_ExpectedOneButGotMore + +-- | Shorthand for reading @Word32@ sized segment +readMem32 + :: MonadOCD m + => MemAddress -- ^ Memory address to read from + -> m Word32 +readMem32 = readMem @Word32 + +-- | Write multiple memory segments to @MemAddress@ +writeMem + :: forall a m + . ( MonadOCD m + , FiniteBits a + , PrintfArg a + , Integral a + ) + => MemAddress -- ^ Memory address to write to + -> [a] -- ^ Data to write + -> m () +writeMem ma xs = + rpc + WriteMemory + { writeMemoryAddr = ma + , writeMemoryData = xs + } + +-- | Shorthand for writing @Word32@ sized segment +writeMem32 + :: MonadOCD m + => MemAddress -- ^ Memory address to write to + -> [Word32] -- ^ Data to write + -> m () +writeMem32 = writeMem @Word32 diff --git a/src/HOCD/Types.hs b/src/HOCD/Types.hs new file mode 100644 --- /dev/null +++ b/src/HOCD/Types.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module HOCD.Types + ( MemAddress(..) + , memAddr + , OCDConfig(..) + ) where + +import Data.Default.Class (Default(def)) +import Data.Word (Word32) + +newtype MemAddress = MemAddress + { unMemAddress :: Word32 } + deriving (Eq, Ord, Show, Num) + +-- | Shorthand constructor +memAddr :: Word32 -> MemAddress +memAddr = MemAddress + +data OCDConfig = OCDConfig + { ocdHost :: String + , ocdPort :: Int + } deriving (Eq, Ord, Show) + +instance Default OCDConfig where + def = + OCDConfig + { ocdHost = "127.0.0.1" + , ocdPort = 6666 + } + + diff --git a/test/ParseSpec.hs b/test/ParseSpec.hs new file mode 100644 --- /dev/null +++ b/test/ParseSpec.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} + +module ParseSpec where + +import Data.Word (Word32) +import HOCD.Command (parseMem) +import Test.Hspec (Spec, it, shouldBe) + +spec :: Spec +spec = do + it "parses read-memory sample" $ do + parseMem "ABCDFF 001122" + `shouldBe` + (Right [0xABCDFF, 0x1122 :: Word32]) + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}