bus-pirate 0.1 → 0.2
raw patch · 4 files changed
+223/−2 lines, 4 files
Files
- System/Hardware/BusPirate.hs +2/−1
- System/Hardware/BusPirate/Core.hs +96/−0
- System/Hardware/BusPirate/I2C.hs +122/−0
- bus-pirate.cabal +3/−1
System/Hardware/BusPirate.hs view
@@ -2,7 +2,8 @@ module System.Hardware.BusPirate ( -- * General- module System.Hardware.BusPirate.Core+ BusPirateM+ , runBusPirate -- * I2C mode , module System.Hardware.BusPirate.I2C ) where
+ System/Hardware/BusPirate/Core.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-}++module System.Hardware.BusPirate.Core where++import Control.Applicative+import Control.Monad (when, replicateM_)+import Control.Monad.Trans.Class+import Control.Monad.Trans.Either+import Control.Monad.Trans.Reader+import Control.Monad.IO.Class+import System.IO+import Data.Word+import Control.Concurrent (threadDelay)++import System.Hardware.Serialport as SP++import qualified Data.ByteString as BS+import Data.ByteString (ByteString)++newtype BusPirateM a = BPM (EitherT String (ReaderT Handle IO) a)+ deriving (Functor, Applicative, Monad, MonadIO)++withDevice :: (Handle -> BusPirateM a) -> BusPirateM a+withDevice action = BPM (lift ask) >>= action++settings = defaultSerialSettings { commSpeed = CS115200 }++drainInput :: Handle -> IO ()+drainInput h = do+ threadDelay 10+ a <- BS.hGetSome h 100+ when (not $ BS.null a) $ drainInput h++-- | Attempt to enter binary mode+initialize :: Handle -> EitherT String IO ()+initialize dev = do+ liftIO $ hFlush dev+ liftIO $ BS.hPut dev "\x00"+ a <- liftIO $ BS.hGetSome dev 5+ when (a /= "BBIO1")+ $ left "Invalid response during initialization"++-- | Run the given action until success up to n times+attempt :: Monad m => Int -> EitherT e m a -> EitherT e m a+attempt n action = go n+ where+ go 0 = action+ go n = do res <- lift $ runEitherT action+ case res of+ Right a -> return a+ Left _ -> go (n-1)++-- | Open a Bus Pirate device and run the given action+runBusPirate :: FilePath -> BusPirateM a -> IO (Either String a)+runBusPirate path (BPM action) = do+ dev <- liftIO $ SP.hOpenSerial path settings+ res <- runEitherT $ do+ attempt 20 (initialize dev)+ liftIO $ drainInput dev+ EitherT $ runReaderT (runEitherT action) dev+ replicateM_ 20 $ BS.hPut dev "\x00"+ BS.hPut dev "\x0f"+ hClose dev+ return res++put :: ByteString -> BusPirateM ()+put bs = withDevice $ \dev->BPM $ liftIO $ BS.hPut dev bs++putByte :: Word8 -> BusPirateM ()+putByte b = withDevice $ \dev->BPM $ liftIO $ BS.hPut dev (BS.singleton b)++putWord16 :: Word16 -> BusPirateM ()+putWord16 b = do+ putByte $ fromIntegral $ b `div` 0x100+ putByte $ fromIntegral $ b+ +get :: Int -> BusPirateM ByteString+get n = withDevice $ \dev->BPM $ liftIO $ BS.hGet dev n++getByte :: BusPirateM Word8+getByte = do+ r <- get 1+ if BS.null r+ then fail $ "Failed to read byte"+ else return $ BS.head r++commandExpect :: Word8 -> ByteString -> BusPirateM ()+commandExpect cmd reply = do+ put $ BS.pack [fromIntegral cmd]+ r <- get (BS.length reply)+ if r /= reply+ then fail $ "Expected reply '"++show reply++"', found '"++show r++"'"+ else return ()+ +command :: Word8 -> BusPirateM ()+command cmd = commandExpect cmd "\x01"
+ System/Hardware/BusPirate/I2C.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-}++module System.Hardware.BusPirate.I2C+ ( -- * Primitive operations+ I2cM+ , i2cMode+ , startBit+ , stopBit+ , readByte+ , ackBit+ , nackBit+ , AckNack(..)+ , bulkWrite+ , writeRead+ -- * Configuration+ , I2cConfig(..)+ , setConfig+ , I2cSpeed(..)+ , setSpeed+ ) where++import Control.Applicative+import Control.Monad (replicateM, when)+import Control.Monad.IO.Class+import Control.Monad.Trans.Either+import Data.Word+import Data.List (intercalate)++import qualified Data.ByteString as BS+import Data.ByteString (ByteString)++import System.Hardware.BusPirate.Core++newtype I2cM a = I2cM (BusPirateM a)+ deriving (Functor, Applicative, Monad, MonadIO)+ +-- | Enter I2C mode and run given action+i2cMode :: I2cM a -> BusPirateM a+i2cMode (I2cM m) = commandExpect 0x2 "I2C1" >> m++-- | Send a start bit+startBit :: I2cM ()+startBit = I2cM $ command 0x2++-- | Send a stop bit+stopBit :: I2cM ()+stopBit = I2cM $ command 0x3++-- | Read a byte+readByte :: I2cM Word8+readByte = I2cM $ putByte 0x4 >> getByte++data AckNack = Ack | Nack+ deriving (Show, Eq, Ord, Enum, Bounded)++-- | Send an ACK +ackBit :: I2cM ()+ackBit = I2cM $ command 0x6++-- | Send a NACK +nackBit :: I2cM ()+nackBit = I2cM $ command 0x7++-- | Write some bytes+bulkWrite :: ByteString -> I2cM ()+bulkWrite d + | BS.null d = return ()+ | BS.length d > 16 = I2cM $ BPM $ left "Too many bytes"+ | otherwise = I2cM $ do + command $ fromIntegral $ 0x10 + BS.length d - 1+ put d+ acks <- replicateM (BS.length d) $ toEnum . fromIntegral <$> getByte+ case map fst $ filter (\(n,a)->a /= Ack) $ zip [0..] acks of+ [] -> return ()+ nacks -> let nacks' = intercalate ", " $ map show nacks+ bytes = if length nacks > 1 then "bytes" else "byte"+ in fail $ "Nack after "++bytes++" "++nacks'++" during bulkWrite of "++show d++data I2cConfig = I2cConfig { i2cPower :: Bool+ , i2cPullups :: Bool+ , i2cAux :: Bool+ , i2cChipSelect :: Bool+ }+ deriving (Show)++-- | Set Bus Pirate I2C configuration bits+setConfig :: I2cConfig -> I2cM ()+setConfig config = I2cM $ + command $ 0x40+ + bit 3 (i2cPower config)+ + bit 2 (i2cPullups config)+ + bit 1 (i2cAux config)+ + bit 0 (i2cChipSelect config)+ where+ bit n True = 2^n+ bit _ _ = 0++data I2cSpeed = I2c_5kHz+ | I2c_50kHz+ | I2c_100kHz+ | I2c_400kHz+ deriving (Show, Eq, Ord, Enum, Bounded)+ +-- | Set I2C bus speed+setSpeed :: I2cSpeed -> I2cM ()+setSpeed speed = I2cM $ command $ fromIntegral $ 0x60 + fromEnum speed++-- | Send Start bit, write some bytes, then read some bytes (ACKing+-- each until the last), then send a stop bit+writeRead :: ByteString -> Int -> I2cM ByteString+writeRead send recv + | BS.length send > 0xffff = error "Too large send request"+ | recv > 0xffff = error "Too large recieve request"+ | otherwise = I2cM $ do+ putByte 0x8+ putWord16 $ fromIntegral $ BS.length send+ putWord16 $ fromIntegral $ recv+ put send+ status <- getByte+ case status of+ 0x00 -> fail "writeRead: Failed"+ 0x01 -> get recv
bus-pirate.cabal view
@@ -1,5 +1,5 @@ name: bus-pirate-version: 0.1+version: 0.2 synopsis: Haskell interface to the Bus Pirate binary interface homepage: http://www.github.com/bgamari/bus-pirate license: BSD3@@ -19,6 +19,8 @@ library exposed-modules: System.Hardware.BusPirate+ System.Hardware.BusPirate.I2C+ other-modules: System.Hardware.BusPirate.Core build-depends: base >=4.6 && <4.7, serialport >=0.4 && <0.5, bytestring >=0.10 && <0.11,