bglib 0.1.0.0 → 1.0.0.0

raw patch · 6 files changed

+117/−83 lines, 6 filesdep +asyncPVP ok

version bump matches the API change (PVP)

Dependencies added: async

API changes (from Hackage documentation)

Files

• LICENSE +17/−27
• README.md +2/−2
• bglib.cabal +2/−1
• examples/bgapitest.hs +49/−16
• src/BGLib/Commands.hs +46/−37
• src/BGLib/Types.hs +1/−0

@@ -1,30 +1,20 @@-Copyright Tamas Fabian (c) 2018--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.+Copyright 2018 Tamas Fabian -    * 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.+Permission is hereby granted, free of charge, to any person obtaining a+copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions: -    * Neither the name of Tamas Fabian nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.+The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software. -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.+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS+OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

@@ -2,8 +2,8 @@  An implementation of the BGAPI serial protocol. -This protocol is spoken by Silicon Laboratories (formely BlueGiga)-Bluetooth and Wifi products via UART or USB.+This protocol is spoken by Silicon Labs (formely BlueGiga) Bluetooth+and Wifi products via UART or USB.  The Bluetooth Smart Software API Reference Manual can be found at: 

@@ -1,5 +1,5 @@ name:                bglib-version:             0.1.0.0+version:             1.0.0.0 synopsis:            Implementation of the BGAPI serial protocol description:         This library implements Silicon Labs' (formerly BlueGiga)                      serial protocol to communicate with certain Bluetooth and@@ -35,6 +35,7 @@   main-is:             bgapitest.hs   ghc-options:         -Wall -threaded   build-depends:       base >= 4.7 && < 5+                     , async                      , bglib                      , bytestring                      , mtl

@@ -4,6 +4,7 @@ import           BGLib.Commands import           BGLib.Types import           Control.Concurrent+import           Control.Concurrent.Async import           Control.Concurrent.STM import           Control.Monad.IO.Class import           Control.Monad.Reader@@ -15,17 +16,26 @@ import           System.Exit import           System.Hardware.Serialport +-- This is our monad stack, most of the application runs inside this.+type AppM env a = ReaderT env IO a++-- We store the command line options here data AppOptions = AppOptions     { appOptSerialPort :: String     , appOptDebug      :: Bool     } +-- The data structure will be our "env", the environment stored in the+-- ReaderT env IO monad stack data App = App     { appOptions :: AppOptions     , appSerialPort :: SerialPort     , appBGChan  :: TChan BgPacket     } +-- Instances for our environment to properly serve the library+-- functions.+ instance HasSerialPort App where     getSerialPort = appSerialPort @@ -35,6 +45,7 @@ instance HasDebug App where     getDebug = appOptDebug . appOptions +-- Command line parser optParser :: Parser AppOptions optParser = AppOptions         <$> argument str @@ -45,9 +56,29 @@             <> short 'd'             <> help "Whether to be quiet" ) -execApp :: env -> ReaderT env m a -> m a+-- Takes an environment and runs a program with it inside the IO monad.+execApp :: env -> AppM env a -> IO a execApp = flip runReaderT +-- RUns a program in a new thread inside out AppM stack+forkApp :: AppM env () -> AppM env ThreadId+forkApp act = do+    env <- ask+    liftIO $ forkIO $ execApp env act++-- Can be used to wait for an event handler to return a value.+-- Waiting for a specific BLE device advertisement to appear for+-- example. Timeout is in microseconds.+withTimeOut :: Int -> AppM env a -> AppM env (Maybe a)+withTimeOut t a = do+    env <- ask+    res <- liftIO $ race (threadDelay t) (execApp env a)+    return $ case res of+        Left () -> Nothing+        Right x -> Just x++-- A few lifted functions+ putStrLn :: MonadIO m => String -> m () putStrLn = liftIO . P.putStrLn @@ -56,6 +87,7 @@  main :: IO () main = do+    -- Run the command line parser     appOpts <- execParser $         info             ( optParser <**> helper )@@ -64,6 +96,7 @@             <> header "bgapitest - a short text / example for haskell-bglib"             ) +    -- Build the application environment     app <- App         <$> return appOpts         <*> openSerial@@ -71,12 +104,16 @@             (SerialPortSettings CS115200 8 One NoParity NoFlowControl 1000)         <*> atomically newBroadcastTChan +    -- Run the application     execApp app $ do+         -- Register an event handler for protocol errors.-        _ <- evtSystemProtocolError $ \reason -> do-            die $ "*** PROTOCOL ERROR " ++ show reason+        -- Event handlers are blocking. We use forkApp to make it+        -- "run in the background".+        _ <- forkApp $ evtSystemProtocolError $ \reason -> do+            liftIO $ die $ "*** PROTOCOL ERROR " ++ show reason -            -- Starts a thread that keeps reading packets from the serial port,+        -- Starts a thread that keeps reading packets from the serial port,         -- pushing them to the broadcast TChan         startPacketReader @@ -122,25 +159,21 @@         decrypted <- systemAesDecrypt encrypted         putStrLn $ "Decrypted: " ++ BSS.unpack (fromUInt8Array decrypted)         putStrLn ""+        +        _ <- gapDiscover GapDiscoverGeneric          -- Register an event handler for scan responses. Can be done anywhere.         -- The handler forks a thread that runs forever, and can be terminated         -- later if necessary.-        tid <- evtGapScanResponse $ \rssi _ sender _ _ _ -> do-            print rssi-            print sender-            putStrLn ""-            return True -- We'd like to listen to further events.--        _ <- gapDiscover GapDiscoverGeneric--        liftIO $ threadDelay 5000000+        _ <- withTimeOut 5000000 $ evtGapScanResponse $ \rssi _ sender _ _ _ -> do+                print rssi+                print sender+                putStrLn ""+                return $ Nothing -- We'd like to listen to further events.          _ <- gapEndProcedure -        liftIO $ killThread tid--        -- Let's cause trouble.+        putStrLn "Let's cause trouble:"         s <- askSerialPort         _ <- liftIO $ send s $ BSS.pack "a"         liftIO $ threadDelay 5000000

@@ -225,15 +225,24 @@     xCmd' mt tt cc cid inp     decode . BSL.fromStrict . fromBgPayload . bgpPayload <$> ( liftIO $ waitForPacket chan mt tt cc cid ) -registerEventHandler :: Binary a => (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env) => BgMessageType -> BgTecnologyType -> BgCommandClass -> UInt8 -> (a -> IO Bool) -> m ThreadId+-- Register an event handler.+-- Event handler block by waiting on the TChan provided by the+-- environment. One can use forkIO to make event handler run in+-- independent threads, or use race with threadDelay to wait for an+-- event with a timeout.+registerEventHandler+    :: (Binary a, MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env)+    => BgMessageType -> BgTecnologyType -> BgCommandClass -> UInt8 -> (a -> m (Maybe b)) -> m b registerEventHandler mt tt cc cid handler = do     chan <- askDupBGChan-    liftIO $ forkIO $ go chan+    go chan     where         go chan = do-            BgPacket{..} <- waitForPacket chan mt tt cc cid-            continue <- handler $ decode $ BSL.fromStrict $ fromBgPayload $ bgpPayload-            if continue then go chan else return ()+            BgPacket{..} <- liftIO $ waitForPacket chan mt tt cc cid+            mbResult <- handler $ decode $ BSL.fromStrict $ fromBgPayload $ bgpPayload+            case mbResult of+                Nothing -> go chan+                Just r  -> return r  curry3 :: ((a, b, c) -> d) -> a -> b -> c -> d curry3 func a b c = func (a, b, c)@@ -333,37 +342,37 @@  evtAttclientAttributeValue     :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env)-    => (UInt8 -> UInt16 -> UInt8 -> UInt8Array -> IO Bool) -> m ThreadId+    => (UInt8 -> UInt16 -> UInt8 -> UInt8Array -> m (Maybe a)) -> m a evtAttclientAttributeValue     = registerEventHandler BgMsgEvent BgBlue BgClsAttributeClient 0x05 . uncurry4  evtAttclientFindInformationFound     :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env)-    => (UInt8 -> UInt16 -> UInt8Array -> IO Bool) -> m ThreadId+    => (UInt8 -> UInt16 -> UInt8Array -> m (Maybe a)) -> m a evtAttclientFindInformationFound     = registerEventHandler BgMsgEvent BgBlue BgClsAttributeClient 0x04 . uncurry3  evtAttclientGroupFound     :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env)-    => (UInt8 -> UInt16 -> UInt16 -> UInt8Array -> IO Bool) -> m ThreadId+    => (UInt8 -> UInt16 -> UInt16 -> UInt8Array -> m (Maybe a)) -> m a evtAttclientGroupFound     = registerEventHandler BgMsgEvent BgBlue BgClsAttributeClient 0x02 . uncurry4  evtAttclientIndicated     :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env)-    => (UInt8 -> UInt16 -> IO Bool) -> m ThreadId+    => (UInt8 -> UInt16 -> m (Maybe a)) -> m a evtAttclientIndicated     = registerEventHandler BgMsgEvent BgBlue BgClsAttributeClient 0x00 . uncurry  evtAttclientProcedureCompleted     :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env)-    => (UInt8 -> BGResult -> UInt16 -> IO Bool) -> m ThreadId+    => (UInt8 -> BGResult -> UInt16 -> m (Maybe a)) -> m a evtAttclientProcedureCompleted     = registerEventHandler BgMsgEvent BgBlue BgClsAttributeClient 0x01 . uncurry3  evtAttclientReadMultipleResponse     :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env)-    => (UInt8 -> UInt8Array -> IO Bool) -> m ThreadId+    => (UInt8 -> UInt8Array -> m (Maybe a)) -> m a evtAttclientReadMultipleResponse     = registerEventHandler BgMsgEvent BgBlue BgClsAttributeClient 0x06 . uncurry @@ -403,19 +412,19 @@  evtAttributesStatus     :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env)-    => (UInt16 -> UInt8 -> IO Bool) -> m ThreadId+    => (UInt16 -> UInt8 -> m (Maybe a)) -> m a evtAttributesStatus     = registerEventHandler BgMsgEvent BgBlue BgClsAttributeDatabase 0x02 . uncurry  evtAttributesUserReadRequest     :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env)-    => (UInt8 -> UInt16 -> UInt16 -> UInt8 -> IO Bool) -> m ThreadId+    => (UInt8 -> UInt16 -> UInt16 -> UInt8 -> m (Maybe a)) -> m a evtAttributesUserReadRequest     = registerEventHandler BgMsgEvent BgBlue BgClsAttributeDatabase 0x01 . uncurry4  evtAttributesValue     :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env)-    => (UInt8 -> UInt8 -> UInt16 -> UInt16 -> UInt8Array -> IO Bool) -> m ThreadId+    => (UInt8 -> UInt8 -> UInt16 -> UInt16 -> UInt8Array -> m (Maybe a)) -> m a evtAttributesValue     = registerEventHandler BgMsgEvent BgBlue BgClsAttributeDatabase 0x00 . uncurry5 @@ -465,24 +474,24 @@  evtConnectionDisconnected     :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env)-    => (UInt8 -> BGResult -> IO Bool) -> m ThreadId+    => (UInt8 -> BGResult -> m (Maybe a)) -> m a evtConnectionDisconnected     = registerEventHandler BgMsgEvent BgBlue BgClsConnection 0x04 . uncurry  evtConnectionFeatureInd     :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env)-    => (UInt8 -> UInt8Array -> IO Bool) -> m ThreadId+    => (UInt8 -> UInt8Array -> m (Maybe a)) -> m a evtConnectionFeatureInd = registerEventHandler BgMsgEvent BgBlue BgClsConnection 0x02 . uncurry  evtConnectionStatus     :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env)-    => (UInt8 -> UInt8 -> BdAddr -> UInt8 -> UInt16 -> UInt16 -> UInt16 -> UInt8 -> IO Bool)-    -> m ThreadId+    => (UInt8 -> UInt8 -> BdAddr -> UInt8 -> UInt16 -> UInt16 -> UInt16 -> UInt8 -> m (Maybe a))+    -> m a evtConnectionStatus = registerEventHandler BgMsgEvent BgBlue BgClsConnection 0x00 . uncurry8  evtConnectionVersionInd     :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env)-    => (UInt8 -> UInt8 -> UInt16 -> UInt16 -> IO Bool) -> m ThreadId+    => (UInt8 -> UInt8 -> UInt16 -> UInt16 -> m (Maybe a)) -> m a evtConnectionVersionInd = registerEventHandler BgMsgEvent BgBlue BgClsConnection 0x01 . uncurry4  -----------------------------------------------------------------------@@ -557,7 +566,7 @@ -- Register an event handler for GAP scan responses evtGapScanResponse     :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env)-    => (Int8 -> UInt8 -> BdAddr -> UInt8 -> UInt8 -> UInt8Array -> IO Bool) -> m ThreadId+    => (Int8 -> UInt8 -> BdAddr -> GapAddressType -> UInt8 -> UInt8Array -> m (Maybe a)) -> m a evtGapScanResponse     = registerEventHandler BgMsgEvent BgBlue BgClsGenericAccessProfile 0x00 . uncurry6 @@ -682,25 +691,25 @@  evtHardwareAdcResult     :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env)-    => (UInt8 -> UInt16 -> IO Bool) -> m ThreadId+    => (UInt8 -> UInt16 -> m (Maybe a)) -> m a evtHardwareAdcResult     = registerEventHandler BgMsgEvent BgBlue BgClsHardware 0x02 . uncurry  evtHardwareAnalogComparatorStatus     :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env)-    => (UInt32 -> UInt8 -> IO Bool) -> m ThreadId+    => (UInt32 -> UInt8 -> m (Maybe a)) -> m a evtHardwareAnalogComparatorStatus     = registerEventHandler BgMsgEvent BgBlue BgClsHardware 0x03 . uncurry  evtHardwareIoPortStatus     :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env)-    => (UInt32 -> UInt8 -> UInt8 -> UInt8 -> IO Bool) -> m ThreadId+    => (UInt32 -> UInt8 -> UInt8 -> UInt8 -> m (Maybe a)) -> m a evtHardwareIoPortStatus     = registerEventHandler BgMsgEvent BgBlue BgClsHardware 0x00 . uncurry4  evtHardwareSoftTimer     :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env)-    => (UInt8 -> IO Bool) -> m ThreadId+    => (UInt8 -> m (Maybe a)) -> m a evtHardwareSoftTimer     = registerEventHandler BgMsgEvent BgBlue BgClsHardware 0x01 @@ -755,7 +764,7 @@  evtFlashPsKey     :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env)-    => (UInt16 -> UInt8Array -> IO Bool) -> m ThreadId+    => (UInt16 -> UInt8Array -> m (Maybe a)) -> m a evtFlashPsKey     = registerEventHandler BgMsgEvent BgBlue BgClsPersistentStore 0x00 . uncurry @@ -810,25 +819,25 @@  evtSmBondingFail     :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env)-    => (UInt8 -> BGResult -> IO Bool) -> m ThreadId+    => (UInt8 -> BGResult -> m (Maybe a)) -> m a evtSmBondingFail     = registerEventHandler BgMsgEvent BgBlue BgClsSecurityManager 0x01 . uncurry  evtSmBondStatus     :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env)-    => (UInt8 -> UInt8 -> Bool -> UInt8 -> IO Bool) -> m ThreadId+    => (UInt8 -> UInt8 -> Bool -> UInt8 -> m (Maybe a)) -> m a evtSmBondStatus     = registerEventHandler BgMsgEvent BgBlue BgClsSecurityManager 0x04 . uncurry4  evtSmPasskeyDisplay     :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env)-    => (UInt8 -> UInt32 -> IO Bool) -> m ThreadId+    => (UInt8 -> UInt32 -> m (Maybe a)) -> m a evtSmPasskeyDisplay     = registerEventHandler BgMsgEvent BgBlue BgClsSecurityManager 0x02 . uncurry  evtSmPasskeyRequest     :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env)-    => (UInt8 -> IO Bool) -> m ThreadId+    => (UInt8 -> m (Maybe a)) -> m a evtSmPasskeyRequest     = registerEventHandler BgMsgEvent BgBlue BgClsSecurityManager 0x03 @@ -928,43 +937,43 @@  evtSystemBoot     :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env)-    => (UInt16 -> UInt16 -> UInt16 -> UInt16 -> UInt16 -> UInt8 -> UInt8 -> IO Bool) -> m ThreadId+    => (UInt16 -> UInt16 -> UInt16 -> UInt16 -> UInt16 -> UInt8 -> UInt8 -> m (Maybe a)) -> m a evtSystemBoot     = registerEventHandler BgMsgEvent BgBlue BgClsSystem 0x00 . uncurry7  evtSystemEndpointWatermarkRx     :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env)-    => (UInt8 -> UInt8 -> IO Bool) -> m ThreadId+    => (UInt8 -> UInt8 -> m (Maybe a)) -> m a evtSystemEndpointWatermarkRx     = registerEventHandler BgMsgEvent BgBlue BgClsSystem 0x02 . uncurry  evtSystemEndpointWatermarkTx     :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env)-    => (UInt8 -> UInt8 -> IO Bool) -> m ThreadId+    => (UInt8 -> UInt8 -> m (Maybe a)) -> m a evtSystemEndpointWatermarkTx     = registerEventHandler BgMsgEvent BgBlue BgClsSystem 0x03 . uncurry  evtSystemNoLicenseKey     :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env)-    => (() -> IO Bool) -> m ThreadId+    => (() -> m (Maybe a)) -> m a evtSystemNoLicenseKey     = registerEventHandler BgMsgEvent BgBlue BgClsSystem 0x05  evtSystemProtocolError     :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env)-    => (BGResult -> IO Bool) -> m ThreadId+    => (BGResult -> m (Maybe a)) -> m a evtSystemProtocolError     = registerEventHandler BgMsgEvent BgBlue BgClsSystem 0x06  evtSystemScriptFailure     :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env)-    => (UInt16 -> BGResult -> IO Bool) -> m ThreadId+    => (UInt16 -> BGResult -> m (Maybe a)) -> m a evtSystemScriptFailure     = registerEventHandler BgMsgEvent BgBlue BgClsSystem 0x04 . uncurry  evtSystemUsbEnumerated     :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env)-    => (Bool -> IO Bool) -> m ThreadId+    => (Bool -> m (Maybe a)) -> m a evtSystemUsbEnumerated     = registerEventHandler BgMsgEvent BgBlue BgClsSystem 0x07 @@ -1023,5 +1032,5 @@  evtDfuBoot     :: (MonadIO m, MonadReader env m, HasSerialPort env, HasBGChan env, HasDebug env)-    => (UInt32 -> IO Bool) -> m ThreadId+    => (UInt32 -> m (Maybe a)) -> m a evtDfuBoot = registerEventHandler BgMsgEvent BgBlue BgClsDfu 0x00

@@ -61,6 +61,7 @@     , BGResult(..)     ) where +import           Control.Concurrent import           Control.Concurrent.STM.TChan import           Control.Monad.Reader import           Control.Concurrent.STM