packages feed

STLinkUSB (empty) → 0.1.0

raw patch · 13 files changed

+1046/−0 lines, 13 filesdep +basedep +binarydep +bytestringsetup-changed

Dependencies added: base, binary, bytestring, transformers, usb, vector

Files

+ README.md view
@@ -0,0 +1,9 @@+# STLinkUSB++This package contains a Haskell driver for ST-Link USB dongles.+My use case for this driver is the STM32-Zombie library.+The STM32-Zombie library turns a STM32 micro-controller+into a powerful Haskell-hackable hardware interface.+The library is a based on information from the openocd library.++## [Haddock documentation](http://hackage.haskell.org/package/STLinkUSB)
+ STLinkUSB.cabal view
@@ -0,0 +1,41 @@+Name:          STLinkUSB+Version:       0.1.0+Category:      Hardware, STM32, Microcontroller+Synopsis:      STLink USB interface in Haskell+Description:   This package contains a Haskell driver for ST-Link USB dongles.+               My use case for this driver is the STM32-Zombie library.+               The STM32-Zombie library turns a STM32 micro-controller+               into a powerful Haskell-hackable hardware interface.+               The library is a based on information from the openocd library.++License:       BSD3+Author:        2015-2017 Marc Fontaine <Marc.Fontaine@gmx.de>+Stability:     Experimental+Tested-With:   GHC == 8.2.1+Build-Type:    Simple+Cabal-Version: >= 1.24+Extra-Source-Files:  README.md+                    +Source-Repository head+  type:     git+  location: git://github.com/MarcFontaine/STLinkUSB++library+  default-language  : Haskell2010+  ghc-options       : -Wall+  Build-depends     : base  >= 4.10 && < 5+                    , bytestring >= 0.10 && < 0.11+                    , usb >= 1.3 && < 1.4+                    , vector >= 0.12 && < 0.13+                    , binary >= 0.8 && < 0.9+                    , transformers >= 0.5 && < 0.6+  Exposed-modules:  STM32.STLinkUSB+                  , STM32.STLinkUSB.Commands+                  , STM32.STLinkUSB.Env+                  , STM32.STLinkUSB.USBXfer+                  , STM32.STLinkUSB.MemRW+                  , STM32.STLinkUSB.Dongle+                  , STM32.STLinkUSB.Test+                  , STM32.STLinkUSB.CortexM+                  , STM32.STLinkUSB.USBUtils+                  , STM32.STLinkUSB.TwoBoards
+ STM32/STLinkUSB.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE RankNTypes #-}+----------------------------------------------------------------------------+-- |+-- Module      :  STM32.STLinkUSB+-- Copyright   :  (c) Marc Fontaine 2017+-- License     :  BSD3+-- +-- Maintainer  :  Marc.Fontaine@gmx.de+-- Stability   :  experimental+-- Portability :  GHC-only+--+-- This module exports a small driver for the STLink dongles. +-- The focus of this API is on reading and writing+-- to the memory of and attached STM32 controller.+-- The STM32 architecture use memory mapped IO registers to program+-- IO ports a hardware peripherals.+-- Therefor a STLink dongle with an attached STM32 board in combination with this+-- library makes a nice Haskell-controlled IO extension board.+++module STM32.STLinkUSB+(+   test+  ,STLT+  ,STL+  ,STLinkEnv+  ,runSTLink+  ,initDongle+  ,resetHalt+  ,writeDebugReg+  ,writeMem8+  ,writeMem32+  ,readMem8+  ,readMem32+  ,LogLevel+  ,Logger+  ,xfer+  )+where+import STM32.STLinkUSB.Env+import STM32.STLinkUSB.USBXfer+import STM32.STLinkUSB.MemRW+import STM32.STLinkUSB.Dongle+import STM32.STLinkUSB.Test+import STM32.STLinkUSB.CortexM
+ STM32/STLinkUSB/Commands.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE RecordWildCards #-}+----------------------------------------------------------------------------+-- |+-- Module      :  STM32.Commands+-- Copyright   :  (c) Marc Fontaine 2017+-- License     :  BSD3+-- +-- Maintainer  :  Marc.Fontaine@gmx.de+-- Stability   :  experimental+-- Portability :  GHC-only+--+-- The bits, bytes and constants of the STLink protocoll.+-- The constants have been looked up a corresponding driver that is+-- part of the openocd library.+-- Some parts have been added for completeness (but have not been tested so far). +module STM32.STLinkUSB.Commands+where+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL (toStrict)+import Data.Binary+import Data.Binary.Put+import Data.Binary.Get+import Data.Bits+       +data Version = Version {+   stlink :: Word16+  ,jtag   :: Word16+  ,swim   :: Word16+  } deriving Show++instance Binary Version where+  put _ = error "Version put not implemented"+  get = do+    v <- getWord16be+    let+      stlink = (v `shiftR` 12) .&. 0x0f +      jtag   = (v `shiftR` 6)  .&. 0x3f +      swim   = v .&. 0x3f+    return $ Version {..}++-- | APIV1 is NOT supported ! Todo remove old APIV1 stuff.+-- | todo +data API = APIV1 | APIV2+  deriving (Show,Eq)++type Addr = Word32+data DebugCmd+  = ENTER_JTAG+  | GETSTATUS+  | FORCEDEBUG+  | READMEM_32BIT  Addr Word16+  | WRITEMEM_32BIT Addr Word16+  | RUNCORE+  | STEPCORE+  | READMEM_8BIT  Addr Word16+  | WRITEMEM_8BIT Addr Word16+  | APIV1_CLEARFP+  | APIV1_SETWATCHPOINT+  | ENTER_SWD+  | EXIT+  | READCOREID+  | APIV1_SETFP+  | ENTER API+  | APIV2_READ_IDCODES+  | RESETSYS API+  | READREG API+  | WRITEREG API+  | WRITEDEBUGREG API Addr Word32+  | APIV2_READDEBUGREG Addr+  | READALLREGS API+  | GETLASTRWSTATUS+  | APIV2_DRIVE_NRST+  | APIV2_START_TRACE_RX Word16 Word32+  | APIV2_STOP_TRACE_RX+  | APIV2_GET_TRACE_NB+  | APIV2_SWD_SET_FREQ+  | APIV2_DRIVE_NRST_LOW+  | APIV2_DRIVE_NRST_HIGH+  | APIV2_DRIVE_NRST_PULSE+  deriving (Show,Eq)++instance Binary DebugCmd where+  get = error "no Binary get for debugCMD"+  put cmd = case cmd of+    ENTER_JTAG            -> putWord8 0x00+    GETSTATUS             -> putWord8 0x01+    FORCEDEBUG            -> putWord8 0x02+    READALLREGS APIV1     -> putWord8 0x04+    READALLREGS APIV2     -> putWord8 0x3A+    READREG APIV1         -> putWord8 0x05+    READREG APIV2         -> putWord8 0x33+    WRITEREG APIV1        -> putWord8 0x06+    WRITEREG APIV2        -> putWord8 0x34+    READMEM_32BIT addr len+      -> putWord8 0x07 >> putWord32le addr >> putWord16le len+    WRITEMEM_32BIT addr len+      -> putWord8 0x08  >> putWord32le addr >> putWord16le len+    RUNCORE               -> putWord8 0x09+    STEPCORE              -> putWord8 0x0a+    APIV1_SETFP           -> putWord8 0x0b+    READMEM_8BIT addr len+      -> putWord8 0x0c >> putWord32le addr >> putWord16le len+    WRITEMEM_8BIT addr len+      -> putWord8 0x0d >> putWord32le addr >> putWord16le len+    APIV1_CLEARFP         -> putWord8 0x0e+    APIV1_SETWATCHPOINT   -> putWord8 0x10+    ENTER_SWD             -> putWord8 0xa3+    (ENTER APIV1)         -> putWord8 0x20+    EXIT                  -> putWord8 0x21+    READCOREID            -> putWord8 0x22+    ENTER APIV2           -> putWord8 0x30+    APIV2_READ_IDCODES    -> putWord8 0x31+    (RESETSYS APIV2)      -> putWord8 0x32+    (RESETSYS APIV1)      -> putWord8 0x03+    (WRITEDEBUGREG APIV1 w1 w2)+         -> putWord8 0x0f >> putWord32le w1 >> putWord32le w2+    (WRITEDEBUGREG APIV2 w1 w2)+         -> putWord8 0x35 >> putWord32le w1 >> putWord32le w2+    APIV2_READDEBUGREG  w -> putWord8 0x36 >> putWord32le w+    GETLASTRWSTATUS -> putWord8 0x3B+    APIV2_DRIVE_NRST      -> putWord8 0x3C+    APIV2_START_TRACE_RX  size speed+          -> putWord8 0x40   >> putWord16le size >> putWord32le speed+    APIV2_STOP_TRACE_RX   -> putWord8 0x41+    APIV2_GET_TRACE_NB    -> putWord8 0x42+    APIV2_SWD_SET_FREQ    -> putWord8 0x43+    APIV2_DRIVE_NRST_LOW   -> putWord8 0x00+    APIV2_DRIVE_NRST_HIGH  -> putWord8 0x01+    APIV2_DRIVE_NRST_PULSE -> putWord8 0x02++data Cmd+  = GET_VERSION+  | DEBUG_COMMAND DebugCmd+  | DEBUG_COMMANDs [DebugCmd]+  | DFU_COMMAND_EXIT+  | SWIM_COMMAND SWIM_Cmd+  | GET_CURRENT_MODE+  | GET_TARGET_VOLTAGE+  deriving Show++data SWIM_Cmd = SWIM_ENTER | SWIM_EXIT+  deriving Show+  +instance Binary Cmd where+  get = error "no Binary get for debugCMD"+  put cmd = case cmd of+    GET_VERSION               -> putWord8 0xF1+    DEBUG_COMMAND  c          -> putWord8 0xF2 >> put c+    DEBUG_COMMANDs l+      -> putWord8 0xF2 >> mapM_ put l+    DFU_COMMAND_EXIT          -> putWord8 0xF3 >> putWord8 0x07+    (SWIM_COMMAND SWIM_ENTER) -> putWord8 0xF4 >> putWord8 0x00+    (SWIM_COMMAND SWIM_EXIT)  -> putWord8 0xF4 >> putWord8 0x01+    GET_CURRENT_MODE          -> putWord8 0xF5+    GET_TARGET_VOLTAGE        -> putWord8 0xF7+  +cmdToByteString :: Cmd -> BS.ByteString+cmdToByteString cmd+  = BS.take 16 $ BSL.toStrict $ runPut (put cmd >> padding)+  where+    padding = putWord64le 0 >> putWord64le 0++data DevMode+  = DEV_DFU_MODE+  | DEV_MASS_MODE+  | DEV_DEBUG_MODE+  | DEV_SWIM_MODE+  | DEV_BOOTLOADER_MODE+  deriving (Show,Eq,Ord,Enum)++data Status+  = DEBUG_ERR_OK+  | DEBUG_ERR_FAULT+  | SWD_AP_WAIT+  | SWD_AP_FAULT+  | SWD_AP_ERROR+  | SWD_AP_PARITY_ERROR+  | JTAG_WRITE_ERROR+  | JTAG_WRITE_VERIF_ERROR+  | SWD_DP_WAIT+  | SWD_DP_FAULT+  | SWD_DP_ERROR+  | SWD_DP_PARITY_ERROR+  | SWD_AP_WDATA_ERROR+  | SWD_AP_STICKY_ERROR+  | SWD_AP_STICKYORUN_ERROR+  | UnknownStatus Word8+  deriving (Show,Eq,Ord)++toStatus :: Word8 -> Status+toStatus w = case w of+  0x80 -> DEBUG_ERR_OK+  0x81 -> DEBUG_ERR_FAULT+  0x10 -> SWD_AP_WAIT+  0x11 -> SWD_AP_FAULT+  0x12 -> SWD_AP_ERROR+  0x13 -> SWD_AP_PARITY_ERROR+  0x0c -> JTAG_WRITE_ERROR+  0x0d -> JTAG_WRITE_VERIF_ERROR+  0x14 -> SWD_DP_WAIT+  0x15 -> SWD_DP_FAULT+  0x16 -> SWD_DP_ERROR+  0x17 -> SWD_DP_PARITY_ERROR+  0x18 -> SWD_AP_WDATA_ERROR+  0x19 -> SWD_AP_STICKY_ERROR+  0x1a -> SWD_AP_STICKYORUN_ERROR+  other -> UnknownStatus other
+ STM32/STLinkUSB/CortexM.hs view
@@ -0,0 +1,78 @@+-- |+-- Module      :  STM32.STLinkUSB.CortexM+-- Copyright   :  (c) Marc Fontaine 2017+-- License     :  BSD3+-- +-- Maintainer  :  Marc.Fontaine@gmx.de+-- Stability   :  experimental+-- Portability :  GHC-only+--+-- Starting and stopping the attached CPU++module STM32.STLinkUSB.CortexM+where++import Data.Word+import Data.Bits+import qualified Data.ByteString as BS+import Control.Monad++import STM32.STLinkUSB.Commands+import STM32.STLinkUSB.Dongle+import STM32.STLinkUSB.Env+import STM32.STLinkUSB.USBXfer+import STM32.STLinkUSB.MemRW+  +halt :: STL ()+halt = do+  debugSTL Info "halting CPU"+  api <- asksDongleAPI              +  case api of+     APIV2 -> writeDebugReg _DCB_DHCSR (_DBGKEY .|. _C_HALT .|. _C_DEBUGEN)+     APIV1 -> void $ xfer (DEBUG_COMMAND FORCEDEBUG)++{-- TODO: does this work ?+-- The intended application is to use the micro controller as an IO extension+-- board and write to the hardware register over the SWD interface.+-- It is essential that the micro controller cpu does not interfere,+-- i.e. it is halted.+-- (fancy stuff could be possible by running a custom micro controller firmware)+-}+resetHalt :: STL ()+resetHalt = halt >> reset++run :: STL ()+run = do+  debugSTL Info "starting CPU"+  api <- asksDongleAPI              +  case api of+     APIV2 -> writeDebugReg _DCB_DHCSR (_DBGKEY .|. _C_DEBUGEN)+     APIV1 -> void $ xfer (DEBUG_COMMAND RUNCORE)++readCpuID :: STL BS.ByteString+readCpuID = do+  debugSTL Info ("trying to read CPU ID")+  cpuID <- readMem32 _CPUID 4+  debugSTL Info ("CPU ID : " ++ (show $ BS.unpack cpuID))+  return cpuID++_CPUID :: Word32+_CPUID = 0xE000ED00++_DCB_DHCSR :: Word32+_DCB_DCRSR :: Word32+_DCB_DCRDR :: Word32+_DCB_DEMCR :: Word32++_DCB_DHCSR = 0xE000EDF0+_DCB_DCRSR = 0xE000EDF4+_DCB_DCRDR = 0xE000EDF8+_DCB_DEMCR = 0xE000EDFC++_DBGKEY :: Word32+_DBGKEY = 0xA05F0000++_C_DEBUGEN :: Word32+_C_DEBUGEN = 1+_C_HALT :: Word32+_C_HALT = 2
+ STM32/STLinkUSB/Dongle.hs view
@@ -0,0 +1,130 @@+----------------------------------------------------------------------------+-- |+-- Module      :  STM32.STLinkUSB.Dongle+-- Copyright   :  (c) Marc Fontaine 2017+-- License     :  BSD3+-- +-- Maintainer  :  Marc.Fontaine@gmx.de+-- Stability   :  experimental+-- Portability :  GHC-only+--+-- Functions for initializing, reseting and mode-change of the STLink dongle.++{-# LANGUAGE RankNTypes #-}+module STM32.STLinkUSB.Dongle+where+import Control.Monad+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL (fromStrict)+import Data.Binary+import Data.Binary.Get+import Control.Monad.Trans.Reader+import Control.Monad.IO.Class+import System.USB (Status(..))++import STM32.STLinkUSB.Commands+import STM32.STLinkUSB.Env+import STM32.STLinkUSB.USBXfer++-- | Init the dongle and set debug mode.+-- A Haskell translation of the same function in the openocd library.++initDongle :: STL ()+initDongle = do+  debugSTL Debug "starting initDongle"+  v <- readVersion+  debugSTL Info ("dongle version : " ++ show v)+  devMode <- readCurrentMode+  case devMode of+    DEV_DFU_MODE   -> modeLeave MODE_DFU+    DEV_DEBUG_MODE -> modeLeave MODE_DEBUG_SWD+    DEV_SWIM_MODE  -> modeLeave MODE_DEBUG_SWIM+    _ -> return ()+  _nMode <- readCurrentMode+  when (_nMode /= DEV_DFU_MODE) $ do+    voltage <- readVoltage+    debugSTL Info ("dongle voltage : " ++ show voltage)+  debugSTL Info "entering SWD Mode // connection to controller"+  modeEnter MODE_DEBUG_SWD+  newMode <- readCurrentMode+  when (newMode /= DEV_DEBUG_MODE) $ do+    let err = ("cannot set dongle mode DEV_DEBUG_MODE. Mode is : "++ show newMode)+    debugSTL Error err                    +    error err+  return ()++reset :: STL ()+reset = do+  debugSTL Info "resetting dongle"+  api <- asks dongleAPI+  void $ xferRetry (DEBUG_COMMAND $ RESETSYS api)++readVersion :: STL Version+readVersion = do+  debugSTL Debug "reading dongle version"+  msg <- xfer GET_VERSION+  return $ decode $ BSL.fromStrict msg+  +readVoltage :: STL Float+readVoltage = do+  debugSTL Debug "reading dongle voltage"+  msg <- xfer GET_TARGET_VOLTAGE+  let    (a,b) = runGet ((,) <$> getWord32le <*> getWord32le) $ BSL.fromStrict msg+  return $+    2.4 * (realToFrac b) / (realToFrac a)++readCurrentMode :: STL DevMode+readCurrentMode = do+  debugSTL Debug "reading dongle mode"+  msg <- xfer GET_CURRENT_MODE+  let mode = toEnum $ fromIntegral $ BS.head msg+  debugSTL Debug $ "dongle mode : " ++ show mode+  return mode++data Mode+  = MODE_DFU+  | MODE_MASS+  | MODE_DEBUG_JTAG+  | MODE_DEBUG_SWD+  | MODE_DEBUG_SWIM+  deriving (Show,Eq,Ord,Enum)+  +modeEnter :: Mode ->STL ()+modeEnter mode = do+  api <- asks dongleAPI+  case mode of+    MODE_DEBUG_JTAG -> void $ xferRetry $ DEBUG_COMMANDs [ ENTER api , ENTER_JTAG ]+    MODE_DEBUG_SWD  -> void $ xferRetry $ DEBUG_COMMANDs [ ENTER api , ENTER_SWD  ]+    MODE_DEBUG_SWIM -> void $ xferRetry $ SWIM_COMMAND SWIM_ENTER+    MODE_DFU   -> return ()+    MODE_MASS  -> return ()++modeLeave :: Mode -> STL ()+modeLeave mode = do+  case mode of+    MODE_DEBUG_JTAG -> xferCheck $ DEBUG_COMMAND EXIT+    MODE_DEBUG_SWD  -> xferCheck $ DEBUG_COMMAND EXIT+    MODE_DEBUG_SWIM -> xferCheck $ SWIM_COMMAND SWIM_EXIT+    MODE_DFU        -> xferCheck $ DFU_COMMAND_EXIT+    _ -> return ()+  where+      xferCheck cmd = do+        (_ret,err) <- xferStatus cmd+        case err of+           Right TimedOut  -> return () -- this is what happens : timeout+           Right Completed -> return () -- this case was not seen+           Left usbExcept -> do+             let msg = "leaveMode : USB exception : " ++ show usbExcept+             debugSTL Error msg+             error msg+             +writeDebugReg :: Word32 -> Word32 -> STL()+writeDebugReg addr val = do+  api <- asks dongleAPI+  void $ xfer (DEBUG_COMMAND $ WRITEDEBUGREG api addr val)++dumpTrace :: STL ()+dumpTrace = forever $ do+   (msg,err) <- xferReadTrace+   liftIO $ print ("trace: ",err,msg)+
+ STM32/STLinkUSB/Env.hs view
@@ -0,0 +1,83 @@+----------------------------------------------------------------------------+-- |+-- Module      :  STM32.STLinkUSB.Env+-- Copyright   :  (c) Marc Fontaine 2017+-- License     :  BSD3+-- +-- Maintainer  :  Marc.Fontaine@gmx.de+-- Stability   :  experimental+-- Portability :  GHC-only+--+-- The STLT Monad is just a reader transformer of STLinkEnv.+++{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RankNTypes #-}++module STM32.STLinkUSB.Env+where++import System.USB+import Control.Monad.Trans.Reader+import Control.Monad.IO.Class++import STM32.STLinkUSB.USBUtils+import STM32.STLinkUSB.Commands (API(..))++type STLT m a = ReaderT STLinkEnv m a       +type STL a = forall m. MonadIO m => ReaderT STLinkEnv m a++runSTLink :: STLT IO a  -> IO a+runSTLink = runSTLink' defaultDebugLogger . runReaderT++runSTLink_verbose :: STLT IO a  -> IO a+runSTLink_verbose = runSTLink' verboseDebugLogger . runReaderT++runSTLink' :: Logger -> (STLinkEnv -> IO a) -> IO a+runSTLink' logger action = do+  usb <- findDefaultEndpoints+  runSTLinkWith logger usb action++runSTLinkWith ::+      Logger+   -> (Ctx, Device, EndpointAddress, EndpointAddress, EndpointAddress)+   -> (STLinkEnv -> IO a)+   -> IO a+runSTLinkWith+     debugLogger+     (usbCtx, device, rxEndpoint, txEndpoint, traceEndpoint)+     action+  =  withUSB device $ \deviceHandle -> (action STLinkEnv {..})+  where+    dongleAPI = APIV2++data STLinkEnv = STLinkEnv {+   usbCtx :: Ctx+  ,rxEndpoint :: EndpointAddress+  ,txEndpoint :: EndpointAddress+  ,traceEndpoint :: EndpointAddress+  ,deviceHandle ::  DeviceHandle+  ,dongleAPI  :: API+  ,debugLogger :: Logger+  }++asksDongleAPI :: STL API+asksDongleAPI = asks dongleAPI++data LogLevel = Debug | Info | Warn | Error deriving (Show,Eq,Ord)+type Logger = LogLevel -> String -> IO ()+  +debugSTL :: LogLevel -> String -> STL ()+debugSTL ll msg = do+  logger <- asks debugLogger+  liftIO $ logger ll msg++defaultDebugLogger :: Logger+defaultDebugLogger logLevel msg = case logLevel of+  Debug -> return ()+  Info  -> return ()+  _ -> putStrLn (show logLevel ++ " : " ++ msg )++verboseDebugLogger :: Logger+verboseDebugLogger logLevel msg+  = putStrLn (show logLevel ++ " : " ++ msg )
+ STM32/STLinkUSB/MemRW.hs view
@@ -0,0 +1,134 @@+----------------------------------------------------------------------------+-- |+-- Module      :  STM32.STLinkUSB.MemRW+-- Copyright   :  (c) Marc Fontaine 2017+-- License     :  BSD3+-- +-- Maintainer  :  Marc.Fontaine@gmx.de+-- Stability   :  experimental+-- Portability :  GHC-only+--+-- Read and Write to the memory of an attached STM32 controller.++{-# LANGUAGE RankNTypes #-}+module STM32.STLinkUSB.MemRW+where+import Control.Monad+import qualified Data.ByteString as BS+import Data.Binary+import Control.Monad.Trans.Reader++import STM32.STLinkUSB.Commands+import STM32.STLinkUSB.Env+import STM32.STLinkUSB.USBXfer++checkRWStatus :: STL ()+checkRWStatus = do+  api <- asks dongleAPI              +  case api of+    APIV1 -> return ()+    APIV2 -> do+      msg <- xfer (DEBUG_COMMAND GETLASTRWSTATUS)+      let dongleStatus = toStatus $ BS.head msg+      if (dongleStatus == DEBUG_ERR_OK)+         then return ()+         else do+           let err = show ("checkRWStatus", dongleStatus)+           debugSTL Error err+           error err++maxTransferBlocksize :: Word16+maxTransferBlocksize = 64++newtype TransferBlock+  = TransferBlock {_unTransferBlock :: BS.ByteString} deriving Show++unsafeToTransferBlock :: BS.ByteString -> TransferBlock+unsafeToTransferBlock bs+  = if len <= fromIntegral maxTransferBlocksize+       then TransferBlock bs+       else error msg+  where+    msg = "unsafeToTransferBlock :" ++ show len ++ "> maxTransferBlockSize"+    len = BS.length bs                   ++newtype TransferLen = TransferLen {_unTransferLen :: Word16} deriving Show++unsafeToTransferLen :: Word16 -> TransferLen+unsafeToTransferLen len+  = if len <= maxTransferBlocksize+       then TransferLen len+       else error msg+  where+    msg = "unsafeToTransferLen :" ++ show len ++ "> maxTransferBlocksize"+  +writeMem8' :: Addr -> TransferBlock -> STL ()+writeMem8' addr (TransferBlock block) = do+  void $ xferBulkWrite (DEBUG_COMMAND $ WRITEMEM_8BIT addr len) block+  checkRWStatus+  where+    len = fromIntegral $ BS.length block++writeMem32' :: Addr -> TransferBlock -> STL ()+writeMem32' addr (TransferBlock block) = do+  void $ xferBulkWrite (DEBUG_COMMAND $ WRITEMEM_32BIT addr len) block+  checkRWStatus+  where+    len = fromIntegral $ BS.length block+  +readMem8' :: Addr -> TransferLen -> STL BS.ByteString+readMem8' addr (TransferLen len) = do+  bs <- xfer (DEBUG_COMMAND $ READMEM_8BIT addr len)+  checkRWStatus+  return bs+      +readMem32' :: Addr -> TransferLen -> STL BS.ByteString+readMem32' addr (TransferLen len) = do+  bs <- xfer (DEBUG_COMMAND $ READMEM_32BIT addr len)+  checkRWStatus+  return bs++writeMem8 :: Addr -> BS.ByteString -> STL ()+writeMem8 = writeChunks writeMem8'++writeMem32 :: Addr -> BS.ByteString -> STL ()+writeMem32 = writeChunks writeMem32'++writeChunks+  :: (Addr -> TransferBlock -> STL () ) -> Addr -> BS.ByteString -> STL ()+writeChunks action addr bs+  = forM_ (chunkBS addr bs) $ uncurry action+++chunkBS :: Addr -> BS.ByteString -> [(Addr,TransferBlock)]+chunkBS addr bs+  = if BS.length bs <= chunkSize+       then [h]+       else h : (chunkBS (addr + fromIntegral chunkSize)     +                      (BS.drop chunkSize bs))+   where+    h = (addr, unsafeToTransferBlock $ BS.take chunkSize bs)+    chunkSize = fromIntegral maxTransferBlocksize++chunkAddr :: Addr -> Int -> [(Addr,TransferLen)]+chunkAddr addr len+  = if len <= chunkSize+       then [h]+       else h : (chunkAddr (addr + fromIntegral chunkSize)+                      (len - chunkSize))+   where+    h = (addr, unsafeToTransferLen+                    (min (fromIntegral len) (fromIntegral maxTransferBlocksize)))+    chunkSize = fromIntegral maxTransferBlocksize++readChunks+  :: (Addr -> TransferLen -> STL BS.ByteString )+      -> Addr -> Int -> STL BS.ByteString+readChunks action addr len+  = liftM BS.concat $ forM (chunkAddr addr len) $ uncurry action++readMem8 :: Addr -> Int -> STL BS.ByteString+readMem8 = readChunks readMem8'++readMem32 :: Addr -> Int -> STL BS.ByteString+readMem32 = readChunks readMem32'
+ STM32/STLinkUSB/Test.hs view
@@ -0,0 +1,28 @@+----------------------------------------------------------------------------+-- |+-- Module      :  STM32.STLinkUSB.Test+-- Copyright   :  (c) Marc Fontaine 2017+-- License     :  BSD3+-- +-- Maintainer  :  Marc.Fontaine@gmx.de+-- Stability   :  experimental+-- Portability :  GHC-only+--+-- Test the connetion to the STLink dongle+-- and read the CPU ID of the attached controller.++{-# LANGUAGE RankNTypes #-}+module STM32.STLinkUSB.Test+where++import STM32.STLinkUSB.Env+import STM32.STLinkUSB.Dongle+import STM32.STLinkUSB.CortexM++-- | Test the dongle and connection to the board.+-- This test fails if no board is attached+test :: IO ()+test = runSTLink_verbose $ do+  initDongle+  _<-readCpuID+  return ()
+ STM32/STLinkUSB/TwoBoards.hs view
@@ -0,0 +1,106 @@+----------------------------------------------------------------------------+-- |+-- Module      :  STM32.STLinkUSB.TwoBoards+-- Copyright   :  (c) Marc Fontaine 2017+-- License     :  BSD3+-- +-- Maintainer  :  Marc.Fontaine@gmx.de+-- Stability   :  experimental+-- Portability :  GHC-only+--+-- Using two Boards/Dongles in parallel.++{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RankNTypes #-}++module STM32.STLinkUSB.TwoBoards+where++import System.USB+import Control.Monad.Trans.Reader+import Control.Monad.IO.Class++import STM32.STLinkUSB.USBUtils+import STM32.STLinkUSB.Env+import STM32.STLinkUSB.Commands+import STM32.STLinkUSB.Dongle+import STM32.STLinkUSB.CortexM++type STLTT m a = ReaderT (STLinkEnv,STLinkEnv) m a++runSTLinkAB :: STLTT IO a  -> IO a+runSTLinkAB+ = runSTLinkAB' (defaultDebugLogger, defaultDebugLogger)+   . runReaderT++runSTLinkAB_verbose :: STLTT IO a  -> IO a+runSTLinkAB_verbose+  = runSTLinkAB' (verboseDebugLogger, verboseDebugLogger)+    . runReaderT++runSTLinkAB' ::+     (Logger,Logger)+  -> ((STLinkEnv,STLinkEnv) -> IO a)+  -> IO a+runSTLinkAB' (loggerA,loggerB) action = do+  ctx <- newCtx+  setDebug ctx PrintWarnings+  list <- findUSBDevices ctx defaultSTLProductID+  let (deviceA,deviceB) = case list of+          []  -> error "no STLink dongle found"+          [_] -> error "just one STLink dongle found"+          [a,b] -> (a,b)+          (_:_:_:_) -> error "more two one STLink dongle found"+  (_,_,rxA,txA,traceA) <- findEndpoints ctx deviceA+  (_,_,rxB,txB,traceB) <- findEndpoints ctx deviceB+  let +     preEnvA handleA = STLinkEnv {+       usbCtx      = ctx+      ,rxEndpoint  = rxA+      ,txEndpoint  = txA+      ,traceEndpoint = traceA+      ,deviceHandle  = handleA+      ,dongleAPI     = APIV2+      ,debugLogger   = taggedLogger "A" loggerA+      }+     preEnvB handleB = STLinkEnv {+       usbCtx      = ctx+      ,rxEndpoint  = rxB+      ,txEndpoint  = txB+      ,traceEndpoint = traceB+      ,deviceHandle  = handleB+      ,dongleAPI     = APIV2+      ,debugLogger   = taggedLogger "B" loggerB+      }+  runSTLinkWithAB (deviceA,deviceB) (preEnvA,preEnvB) action++runSTLinkWithAB ::+      (Device, Device)+   -> ((DeviceHandle -> STLinkEnv), (DeviceHandle -> STLinkEnv))+   -> ((STLinkEnv, STLinkEnv) -> IO a)+   -> IO a+runSTLinkWithAB (deviceA, deviceB) (preEnvA, preEnvB) action+  =  withUSB deviceA $ \deviceHandleA ->+      withUSB deviceB $ \deviceHandleB ->+        (action (preEnvA deviceHandleA, preEnvB deviceHandleB))++taggedLogger :: String -> Logger -> Logger+taggedLogger tag logger loglevel msg+  = logger loglevel (tag++":"++msg)+++boardA :: STLT IO a  -> STLTT IO a+boardA action = do+  env <- asks fst+  liftIO $ (runReaderT action) env++boardB :: STLT IO a  -> STLTT IO a+boardB action = do+  env <- asks snd+  liftIO $ (runReaderT action) env++testTwoBoards :: IO ()+testTwoBoards = runSTLinkAB_verbose $ do+  boardA $ initDongle+  _<-boardA $ readCpuID+  boardB $ initDongle
+ STM32/STLinkUSB/USBUtils.hs view
@@ -0,0 +1,68 @@+----------------------------------------------------------------------------+-- |+-- Module      :  STM32.STLinkUSB.USBUtils+-- Copyright   :  (c) Marc Fontaine 2017+-- License     :  BSD3+-- +-- Maintainer  :  Marc.Fontaine@gmx.de+-- Stability   :  experimental+-- Portability :  GHC-only+--+-- This module contains low-level functions for initializing the USB connection.+-- In most setups 'STM32.STLinkUSB.Env.runSTLink' does all the work+-- and there is no need to include this module.++module STM32.STLinkUSB.USBUtils+where+import qualified Data.Vector as Vector+import System.USB+import Control.Monad++findDefaultEndpoints+  :: IO (Ctx, Device, EndpointAddress, EndpointAddress, EndpointAddress)+findDefaultEndpoints = do+  ctx <- newCtx+  setDebug ctx PrintWarnings+  list <- findUSBDevices ctx defaultSTLProductID+  let device = case list of+        [x] -> x+        [] -> error "no STLink dongle found"+        (_:_:_) -> error "more than one STLink dongle found"+  +  findEndpoints ctx device+  +findUSBDevices ::+  Ctx -> ProductId -> IO [Device]+findUSBDevices ctx stlProductID = do+  devices <- fmap Vector.toList $ getDevices ctx+  flip filterM devices $ \ device -> do+      descr <- getDeviceDesc device+      return (deviceProductId descr == stlProductID)++defaultSTLProductID :: ProductId+defaultSTLProductID = 0x3748+                   +findEndpoints ::+     Ctx -> Device+  -> IO (Ctx, Device, EndpointAddress, EndpointAddress, EndpointAddress)+findEndpoints ctx device = do+  config <- getConfigDesc device 0+  let+     endPoints = interfaceEndpoints+                   $ Vector.head $ Vector.head $ configInterfaces config+     rxEndpoint = endpointAddress $ endPoints Vector.! 0+     txEndpoint = endpointAddress $ endPoints Vector.! 1+     traceEndpoint = endpointAddress $ endPoints Vector.! 2+  return (ctx, device, rxEndpoint, txEndpoint, traceEndpoint)++withUSB :: Device -> (DeviceHandle -> IO a) -> IO a+withUSB device action+  = withDeviceHandle device $+     \deviceHandle  -> withDetachedKernelDriver deviceHandle 0+                         $ action deviceHandle++usbReadTimeout :: Int+usbReadTimeout = 1000++usbWriteTimeout :: Int+usbWriteTimeout = 100
+ STM32/STLinkUSB/USBXfer.hs view
@@ -0,0 +1,115 @@+----------------------------------------------------------------------------+-- |+-- Module      :  STM32.STLinkUSB.USBXfer+-- Copyright   :  (c) Marc Fontaine 2017+-- License     :  BSD3+-- +-- Maintainer  :  Marc.Fontaine@gmx.de+-- Stability   :  experimental+-- Portability :  GHC-only+-- This module contains low-level functions for USB data transfers.+-- Don't use theses functions directly, the prefered API is the MemRW module.++{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RankNTypes #-}+module STM32.STLinkUSB.USBXfer+where++import System.USB+import Control.Monad.Trans.Reader+import Control.Monad.IO.Class+import Control.Concurrent (threadDelay)+import Control.Exception (catch)++import qualified Data.ByteString as BS++import STM32.STLinkUSB.Commands+import STM32.STLinkUSB.Env+import STM32.STLinkUSB.USBUtils++data XferStatus+  = XferOK+  | XferRetry+  | XferDongleError+  | XferUSBError (Either USBException System.USB.Status)+  deriving (Show,Eq)++writeBulkSTL :: Cmd -> STL (Size, System.USB.Status)+writeBulkSTL cmd+  = ReaderT $ \STLinkEnv {..} -> liftIO +    $ writeBulk deviceHandle txEndpoint (cmdToByteString cmd) usbWriteTimeout++readBulkSTL :: STL (BS.ByteString, Either USBException System.USB.Status)+readBulkSTL = ReaderT $ \STLinkEnv {..} -> do+  let readAction = do+        (r,s) <- readBulk deviceHandle rxEndpoint 64 usbReadTimeout+        return (r,Right s)+  liftIO $ catch readAction handler+  where+    handler e = return  (BS.empty,Left e)++xferStatus :: Cmd -> STL (BS.ByteString, Either USBException System.USB.Status)+xferStatus cmd = do+  debugSTL Debug $ show ("xferStatus write :",cmd)+  writeResult <- writeBulkSTL cmd+  debugSTL Debug $ show ("xferStatus writeResult :",cmd,writeResult)+  (retMsg,retStatus) <- readBulkSTL+  debugSTL Debug $ show ("xferStatus readResult : ",retStatus,BS.unpack retMsg)+  return (retMsg,retStatus)++xferBulkWrite :: Cmd -> BS.ByteString -> STL ()+xferBulkWrite cmd block = do+  writeResult1 <- writeBulkSTL cmd+  debugSTL Debug $ show ("xferBulkWrite : ",cmd,writeResult1)+  writeResult2 <- ReaderT $ \STLinkEnv {..} -> do+      liftIO $ writeBulk deviceHandle txEndpoint block usbWriteTimeout+  debugSTL Debug $ show ("xferBulkWrite result : ",writeResult2)+  +xfer :: Cmd -> STL BS.ByteString+xfer cmd = do+  (ret,err) <- xferStatus cmd+  case err of+    Right Completed -> return ret+    Right TimedOut  -> do+      let msg = "xfer (" ++ show cmd ++ ") : timeout"+      debugSTL Error msg+      error msg+    Left usbExcept -> do+      let msg = "xfer : USB exception : " ++ show usbExcept+      debugSTL Error msg+      error msg++-- todo xferRetry is expected to fail+-- it should not throw an exception but return an error+xferRetry :: Cmd -> STL BS.ByteString+xferRetry cmd = loop 8 10000+  where+    exit :: Show x => x -> STL BS.ByteString+    exit x = do+       debugSTL Error (show x)+       error $ show x+       +    loop :: Int -> Int -> STL BS.ByteString+    loop 0 _ = exit ("xferRetry giving up after retry:", cmd)+    loop n d = do+       (msg,usbStatus) <- xferStatus cmd+       case usbStatus of+          Left err -> exit ("xferRetry usb error ",err) -- todo+          Right Completed ->  case toStatus $ BS.head msg of+              SWD_AP_WAIT -> retry+              SWD_DP_WAIT -> retry+              DEBUG_ERR_OK -> return msg+              dongleStatus -> exit ("xferRetry dongle error ",dongleStatus)+          Right other -> exit ("xferRetry usb error ",other)+       where+         retry = do+           debugSTL Warn ("xferRetry retry after delay ("++ show cmd ++")")+           liftIO $ threadDelay d+           loop (n-1) (d*2)+           +xferReadTrace :: STL (BS.ByteString, Either USBException System.USB.Status)+xferReadTrace = do+  debugSTL Debug $ show "xferReadTrace"+  (retMsg,retStatus) <- readBulkSTL+  debugSTL Debug $ show ("xferReadTrace return : ",retStatus,BS.unpack retMsg)+  return (retMsg,retStatus)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain