simple-bluetooth (empty) → 0.1.0.0

raw patch · 9 files changed

+681/−0 lines, 9 filesdep +Win32dep +basedep +bytestringsetup-changed

Dependencies added: Win32, base, bytestring, network

Files

LICENSE +30/−0
Network/Bluetooth.hs +13/−0
Network/Bluetooth/Adapter.hsc +149/−0
Network/Bluetooth/Device.hsc +187/−0
Network/Bluetooth/Types.hsc +67/−0
Network/Bluetooth/Win32.hsc +169/−0
Setup.hs +2/−0
examples/discover.hs +24/−0
simple-bluetooth.cabal +40/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2013, Stephen Blackheath
+
+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 Stephen Blackheath 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.

+ Network/Bluetooth.hs view

@@ -0,0 +1,13 @@+-- | Simple Bluetooth API for Windows and Linux (bluez).
+--
+-- You must use 'Network.withSocketsDo' at the start of your program
+-- for Windows compatibility.
+module Network.Bluetooth (
+        module Network.Bluetooth.Adapter,
+        module Network.Bluetooth.Device
+    ) where
+
+import Network.Bluetooth.Adapter
+import Network.Bluetooth.Device
+import qualified Network (withSocketsDo)
+

+ Network/Bluetooth/Adapter.hsc view

@@ -0,0 +1,149 @@+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}
+module Network.Bluetooth.Adapter (
+        allAdapters,
+        defaultAdapter,
+        discover,
+        module Network.Bluetooth.Types
+    ) where
+
+#if defined(mingw32_HOST_OS)
+#include <windows.h>
+#else
+#include <bluetooth/bluetooth.h>
+#include <bluetooth/hci.h>
+#endif
+#include <stddef.h>
+
+import Network.Bluetooth.Device
+import Network.Bluetooth.Types
+#if defined(mingw32_HOST_OS)
+import Network.Bluetooth.Win32
+#endif
+import qualified Data.ByteString.Internal as BI
+
+import Control.Applicative
+import Control.Exception
+import Control.Monad
+import Data.Bits
+import Data.IORef
+import Data.Word
+import Foreign
+import Foreign.C
+#if defined(mingw32_HOST_OS)
+import System.Win32.Types
+#endif
+
+#if !defined(mingw32_HOST_OS)
+foreign import ccall safe "hci_for_each_dev" hci_for_each_dev
+    :: CInt -> FunPtr (CInt -> CInt -> CLong -> IO CInt) -> CLong -> IO ()
+
+foreign import ccall safe "wrapper" mkVisitDev
+    ::            (CInt -> CInt -> CLong -> IO CInt) ->
+       IO (FunPtr (CInt -> CInt -> CLong -> IO CInt))
+
+foreign import ccall safe "hci_open_dev" hci_open_dev
+    :: CInt -> IO CInt
+#endif
+
+#if !defined(mingw32_HOST_OS)
+openDev :: CInt -> IO Adapter
+openDev dev_id = do
+    ret <- hci_open_dev dev_id
+    if ret < 0 then do
+        errno@(Errno errno_) <- getErrno
+        if errno == eINTR
+            then openDev dev_id
+            else do
+                err <- peekCString (strerror errno_)
+                throwIO $ BluetoothException "openDev" err
+      else
+        pure $ Adapter dev_id ret
+#endif
+
+allAdapters :: IO [Adapter]
+#if defined(mingw32_HOST_OS)
+allAdapters = return [Adapter]
+#else
+allAdapters = do
+    devsRef <- newIORef []
+    cb <- mkVisitDev $ \_ dev_id _ -> do
+        modifyIORef devsRef (dev_id:)
+        pure 0
+    hci_for_each_dev (#const HCI_UP) cb 0
+      `finally`
+        freeHaskellFunPtr cb
+    dev_ids <- reverse <$> readIORef devsRef
+    mapM openDev dev_ids
+#endif
+
+#if !defined(mingw32_HOST_OS)
+foreign import ccall unsafe "hci_get_route" hci_get_route
+    :: Ptr BluetoothAddr -> IO CInt
+#endif
+
+defaultAdapter :: IO (Maybe Adapter)
+#if defined(mingw32_HOST_OS)
+defaultAdapter = return $ Just Adapter
+#else
+defaultAdapter = do
+    ret <- hci_get_route nullPtr
+    if ret < 0 then do
+        errno@(Errno errno_) <- getErrno
+        if errno == eINTR
+            then defaultAdapter
+          else if errno == eNODEV
+            then pure Nothing
+            else do
+                err <- peekCString (strerror errno_)
+                throwIO $ BluetoothException "defaultAdapter" err
+      else
+        Just <$> openDev ret
+#endif
+
+#if !defined(mingw32_HOST_OS)
+foreign import ccall safe "hci_inquiry" hci_inquiry
+    :: CInt -> CInt -> CInt -> Ptr Word8 -> Ptr (Ptr InquiryInfo) -> CLong -> IO CInt
+
+data InquiryInfo = InquiryInfo {
+        iiAddr :: BluetoothAddr
+    }
+    deriving Show
+
+instance Storable InquiryInfo where
+    sizeOf _ = (#const sizeof(inquiry_info))
+    alignment _ = alignment (undefined :: Word64)
+    peek p = InquiryInfo <$> peek (p `plusPtr` (#const offsetof(inquiry_info, bdaddr)))
+    poke _ _ = fail "InquiryInfo.poke not defined"
+#endif
+
+discover :: Adapter -> IO [Device]
+#if defined(mingw32_HOST_OS)
+discover a = map (Device a . fst) <$> discover' a flags
+  where
+    flags = (#const LUP_CONTAINERS) .|.
+            (#const LUP_RETURN_ADDR) .|.
+            (#const LUP_FLUSHCACHE)
+#else
+discover a@(Adapter dev_id _) = go 0  -- (#const IREQ_CACHE_FLUSH)
+  where
+    go flags = do
+        mDevices <- allocaArray 255 $ \ppDevs -> do
+            poke ppDevs nullPtr
+            n <- hci_inquiry dev_id 8 255 nullPtr ppDevs flags
+            if n < 0 then do
+                errno@(Errno errno_) <- getErrno
+                if errno == eINTR
+                    then pure Nothing
+                    else do
+                        err <- peekCString (strerror errno_)
+                        throwIO $ BluetoothException "discover" err
+              else do
+                pDevs <- peek ppDevs
+                iis <- peekArray (fromIntegral n) pDevs
+                free pDevs
+                pure $ Just $ map (Device a . iiAddr) iis
+        case mDevices of
+            Just devices -> pure devices
+            Nothing      -> go 0  -- eINTR ? Retry.
+#endif
+

+ Network/Bluetooth/Device.hsc view

@@ -0,0 +1,187 @@+{-# LANGUAGE ForeignFunctionInterface #-}
+module Network.Bluetooth.Device (
+        Device(..),
+        deviceName,
+        RFCOMMSocket,
+        openRFCOMM,
+        recvRFCOMM,
+        sendRFCOMM,
+        sendAllRFCOMM,
+        closeRFCOMM,
+        module Network.Bluetooth.Types
+    ) where
+
+#if defined(mingw32_HOST_OS)
+#include <windows.h>
+#else
+#include <bluetooth/bluetooth.h>
+#include <bluetooth/hci.h>
+#include <bluetooth/rfcomm.h>
+#endif
+#include <stddef.h>
+
+import Network.Bluetooth.Types
+#if defined(mingw32_HOST_OS)
+import Network.Bluetooth.Win32
+#endif
+import Network.Socket
+import qualified Network.Socket.ByteString as NB
+
+import Control.Applicative
+import Control.Exception
+import Control.Monad
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Internal as B
+import qualified Data.ByteString.Unsafe as B
+import Data.IORef
+import Data.List (lookup)
+import Data.Word
+import Foreign
+import Foreign.C
+import GHC.Conc (threadWaitWrite)
+#if defined(mingw32_HOST_OS)
+import System.Win32.Types
+#endif
+
+
+data Device = Device Adapter BluetoothAddr deriving (Eq, Ord, Show)
+
+foreign import ccall safe "hci_read_remote_name" hci_read_remote_name
+    :: CInt -> Ptr BluetoothAddr -> CInt -> Ptr CChar -> CInt -> IO CInt
+
+deviceName :: Device -> IO ByteString
+#if defined(mingw32_HOST_OS)
+deviceName dev@(Device a addr) = do
+    devs <- discover' a flags
+    case join $ lookup addr devs of
+        Just name -> return name
+        Nothing -> throwIO $ BluetoothException "deviceName" "device has no name"
+  where
+    flags = (#const LUP_CONTAINERS) .|.
+            (#const LUP_RETURN_ADDR) .|.
+            (#const LUP_RETURN_NAME)
+#else
+deviceName dev@(Device (Adapter _ dd) (BluetoothAddr bs)) = do
+    retRef <- newIORef 0
+    bs0 <- B.create maxLen $ \buf -> do
+        ret <- B.unsafeUseAsCString bs $ \cs ->
+            hci_read_remote_name dd (castPtr cs) (fromIntegral maxLen) (castPtr buf) 0
+        writeIORef retRef ret
+    ret <- readIORef retRef
+    if ret < 0 then do
+        errno@(Errno errno_) <- getErrno
+        if errno == eINTR
+            then deviceName dev
+            else do
+                err <- peekCString (strerror errno_)
+                throwIO $ BluetoothException "deviceName" err
+      else
+        return $ B.takeWhile (/= 0) bs0
+  where
+    maxLen = 255
+#endif
+
+data RFCOMMSocket = RFCOMMSocket Socket
+
+#if !defined(mingw32_HOST_OS)
+data SockAddrBTH = SockAddrBTH Word16 ByteString Word8
+
+sockAddrBTH :: BluetoothAddr -> Word8 -> SockAddrBTH
+sockAddrBTH (BluetoothAddr bs) port = SockAddrBTH (#const AF_BLUETOOTH) bs port
+
+instance Storable SockAddrBTH where
+    sizeOf _ = (#const sizeof(struct sockaddr_rc))
+    alignment _ = alignment (undefined :: Word64)
+    peek _ = fail "SockAddrBTH.peek not defined"
+    poke p (SockAddrBTH family bdaddr channel) = do
+        let p_family = p `plusPtr` (#const offsetof(struct sockaddr_rc, rc_family)) :: Ptr ()
+            p_bdaddr = p `plusPtr` (#const offsetof(struct sockaddr_rc, rc_bdaddr))
+            p_channel = p `plusPtr` (#const offsetof(struct sockaddr_rc, rc_channel))
+        case (#const sizeof(sa_family_t)) of
+            1 -> poke (castPtr p_family) (fromIntegral family :: Word8)
+            2 -> poke (castPtr p_family) (fromIntegral family :: Word16)
+            4 -> poke (castPtr p_family) (fromIntegral family :: Word32)
+            sz -> fail $ "SockAddrBTH.poke can't handle size "++show sz
+        B.unsafeUseAsCString bdaddr $ \c_bdaddr ->
+            B.memcpy p_bdaddr (castPtr c_bdaddr) (B.length bdaddr)
+        poke p_channel channel
+#endif
+
+#if defined(mingw32_HOST_OS)
+foreign import stdcall unsafe "connect"
+#else
+foreign import ccall unsafe "connect"
+#endif
+  c_connect :: CInt -> Ptr SockAddrBTH -> CInt -> IO CInt
+
+#if defined(mingw32_HOST_OS)
+foreign import stdcall unsafe "socket"
+  c_socket :: CInt -> CInt -> CInt -> IO CInt
+#endif
+
+openRFCOMM :: Device -> Word8 -> IO RFCOMMSocket
+openRFCOMM dev@(Device _ addr) channel = do
+#if defined(mingw32_HOST_OS)
+    s <- do
+        fd <- c_socket (fromIntegral aF_BTH) (#const SOCK_STREAM) bTHPROTO_RFCOMM
+        mkSocket fd AF_BLUETOOTH Stream bTHPROTO_RFCOMM NotConnected
+#else
+    s <- socket AF_BLUETOOTH Stream (#const BTPROTO_RFCOMM)
+    setSocketOption s ReusePort 1
+#endif
+    connect s `onException` sClose s
+  where
+    connect s = do
+        let fd = fdSocket s
+        ret <- alloca $ \p_sarc -> do
+            poke p_sarc (sockAddrBTH addr channel)
+            c_connect fd p_sarc (fromIntegral $ sizeOf (undefined :: SockAddrBTH))
+        if ret < 0 then do
+            errno@(Errno errno_) <- getErrno
+            case errno of
+                _ | errno == eINTR -> connect s
+                _ | errno == eOK -> return $ RFCOMMSocket s
+                _ | errno == eINPROGRESS -> do
+                    threadWaitWrite (fromIntegral fd)
+                    errno@(Errno errno_) <- Errno . fromIntegral <$> getSocketOption s SoError
+                    if errno == eOK
+                        then return $ RFCOMMSocket s
+                        else do
+#if defined(mingw32_HOST_OS)
+                            err <- getLastError
+                            throwIO =<< BluetoothException "openRFCOMM" <$> (peekTString =<< getErrorMessage err)
+#else
+                            err <- peekCString (strerror errno_)
+                            throwIO $ BluetoothException "openRFCOMM" err
+#endif
+                _ -> do
+#if defined(mingw32_HOST_OS)
+                    err <- getLastError
+                    throwIO =<< BluetoothException "openRFCOMM" <$> (peekTString =<< getErrorMessage err)
+#else
+                    err <- peekCString (strerror errno_)
+                    throwIO $ BluetoothException "openRFCOMM" err
+#endif
+          else
+            return $ RFCOMMSocket s
+
+recvRFCOMM :: RFCOMMSocket -> Int -> IO ByteString
+recvRFCOMM (RFCOMMSocket s) n = NB.recv s n
+  `catch` \exc ->
+     throwIO (BluetoothException "recvRFCOMM" (show (exc :: IOException)))
+
+sendRFCOMM :: RFCOMMSocket -> ByteString -> IO Int
+sendRFCOMM (RFCOMMSocket s) txt = NB.send s txt
+  `catch` \exc ->
+     throwIO (BluetoothException "sendRFCOMM" (show (exc :: IOException)))
+
+sendAllRFCOMM :: RFCOMMSocket -> ByteString -> IO ()
+sendAllRFCOMM (RFCOMMSocket s) txt = NB.sendAll s txt
+  `catch` \exc ->
+     throwIO (BluetoothException "sendAllRFCOMM" (show (exc :: IOException)))
+
+closeRFCOMM :: RFCOMMSocket -> IO ()
+closeRFCOMM (RFCOMMSocket s) = sClose s
+  `catch` \exc ->
+     throwIO (BluetoothException "close" (show (exc :: IOException)))

+ Network/Bluetooth/Types.hsc view

@@ -0,0 +1,67 @@+{-# LANGUAGE DeriveDataTypeable #-}
+module Network.Bluetooth.Types where
+
+#if defined(mingw32_HOST_OS)
+#include <windows.h>
+#else
+#include <bluetooth/bluetooth.h>
+#include <bluetooth/hci.h>
+#endif
+#include <stddef.h>
+
+import Control.Applicative
+import Control.Exception
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Internal as BI
+import Data.Char
+import Data.List
+import Data.Typeable
+import Foreign
+import Foreign.C
+import Numeric
+
+
+#if !defined(mingw32_HOST_OS)
+foreign import ccall unsafe "strerror" strerror
+    :: CInt -> CString
+#endif
+
+#if defined(mingw32_HOST_OS)
+data Adapter = Adapter deriving (Eq, Ord, Show)
+#else
+data Adapter = Adapter CInt CInt deriving (Eq, Ord, Show)
+#endif
+
+data BluetoothException = BluetoothException String String deriving (Show, Typeable)
+instance Exception BluetoothException
+
+newtype BluetoothAddr = BluetoothAddr ByteString deriving (Eq, Ord)
+
+instance Show BluetoothAddr where
+    show (BluetoothAddr bs) = intercalate ":" $ map (\x -> dig2 $ showHex x "") $ reverse $ B.unpack bs
+      where
+        dig2 = map toUpper . reverse . take 2 . reverse . ('0':) 
+
+instance Read BluetoothAddr where
+    readsPrec _ t = go t (6 :: Int) []
+      where
+        go t n acc = case readHex t of
+            (x, t'):_ -> case (n, t') of
+                (1, _)       -> [(BluetoothAddr (B.pack (x:acc)), t')]
+                (_, ':':t'') -> go t'' (n-1) (x:acc)
+                _ -> []
+            _ -> []
+
+instance Storable BluetoothAddr where
+#if defined(mingw32_HOST_OS)
+    sizeOf _ = 8
+#else
+    sizeOf _ = (#const sizeof(bdaddr_t))
+#endif
+    alignment _ = alignment (undefined :: Word64)
+    peek p = BluetoothAddr . B.pack <$> peekArray 6 (castPtr p)
+    poke p (BluetoothAddr bs) = do
+        BI.memset (castPtr p) 0 (fromIntegral $ sizeOf (undefined :: BluetoothAddr)) 
+        pokeArray (castPtr p) (B.unpack bs)
+

+ Network/Bluetooth/Win32.hsc view

@@ -0,0 +1,169 @@+module Network.Bluetooth.Win32 where
+
+#include <windows.h>
+
+import Network.Bluetooth.Types
+
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as C
+import qualified Data.ByteString.Internal as BI
+import Control.Applicative
+import Control.Exception
+import Foreign
+import Foreign.C
+import System.Win32.Types
+
+
+data SockAddrBTH = SockAddrBTH {
+    bthFamily :: USHORT,
+    bthAddr   :: BluetoothAddr,
+    bthPort   :: LONG
+  }
+  deriving Show
+
+sockAddrBTH :: BluetoothAddr -> Word8 -> SockAddrBTH
+sockAddrBTH addr port = SockAddrBTH aF_BTH addr (fromIntegral port)
+
+instance Storable SockAddrBTH where
+    sizeOf _ = 30
+    alignment _ = alignment (undefined :: Word64)
+    poke p bth = do
+        BI.memset (castPtr p) 0 (fromIntegral $ sizeOf bth)
+        poke (p `plusPtr` 0) (bthFamily bth)
+        poke (p `plusPtr` 2) (bthAddr bth)
+        poke (p `plusPtr` 26) (bthPort bth)
+    peek p = SockAddrBTH <$> peek (p `plusPtr` 0)
+                         <*> peek (p `plusPtr` 2)
+                         <*> peek (p `plusPtr` 26)
+
+data SOCKET_ADDRESS sa = SOCKET_ADDRESS {
+    saSockaddr :: Ptr sa,
+    saSockaddrLength :: INT
+  }
+  deriving Show
+
+instance Storable (SOCKET_ADDRESS sa) where
+    sizeOf _ = (#const sizeof(SOCKET_ADDRESS))
+    alignment _ = alignment (undefined :: Word64)
+    poke _ _ = fail "SOCKET_ADDRESS.poke not defined"
+    peek p = SOCKET_ADDRESS <$> peek (p `plusPtr` (#const offsetof(SOCKET_ADDRESS,lpSockaddr)))
+                            <*> peek (p `plusPtr` (#const offsetof(SOCKET_ADDRESS,iSockaddrLength)))
+
+data CSADDR_INFO sa = CSADDR_INFO {
+    csaLocalAddr  :: SOCKET_ADDRESS sa,
+    csaRemoteAddr :: SOCKET_ADDRESS sa
+  }
+  deriving Show
+
+instance Storable sa => Storable (CSADDR_INFO sa) where
+    sizeOf _ = (#const sizeof(CSADDR_INFO))
+    alignment _ = alignment (undefined :: Word64)
+    poke _ _ = fail "CSADDR_INFO.poke not defined"
+    peek p = CSADDR_INFO <$> peek (p `plusPtr` (#const offsetof(CSADDR_INFO,LocalAddr)))
+                         <*> peek (p `plusPtr` (#const offsetof(CSADDR_INFO,RemoteAddr)))
+
+data WSAQUERYSET sa = WSAQUERYSET {
+    qsSize                :: DWORD,
+    qsServiceInstanceName :: CString,
+    qsNameSpace           :: DWORD,
+    qsNumberOfCsAddrs     :: DWORD,
+    qsCsAddrs             :: Ptr (CSADDR_INFO sa),
+    qsBlob                :: Ptr Word8
+  }
+  deriving Show
+
+instance Storable (WSAQUERYSET sa) where
+    sizeOf _ = (#const sizeof(WSAQUERYSET))
+    alignment _ = alignment (undefined :: Word64)
+    poke p qs = do
+        BI.memset (castPtr p) 0 (fromIntegral $ sizeOf qs)
+        poke (p `plusPtr` (#const offsetof(WSAQUERYSET,dwSize))) (qsSize qs)
+        poke (p `plusPtr` (#const offsetof(WSAQUERYSET,lpszServiceInstanceName))) (qsServiceInstanceName qs)
+        poke (p `plusPtr` (#const offsetof(WSAQUERYSET,dwNameSpace))) (qsNameSpace qs)
+        poke (p `plusPtr` (#const offsetof(WSAQUERYSET,dwNumberOfCsAddrs))) (qsNumberOfCsAddrs qs)
+        poke (p `plusPtr` (#const offsetof(WSAQUERYSET,lpcsaBuffer))) (qsCsAddrs qs)
+        poke (p `plusPtr` (#const offsetof(WSAQUERYSET,lpBlob))) (qsBlob qs)
+    peek p =
+        WSAQUERYSET <$> peek (p `plusPtr` (#const offsetof(WSAQUERYSET,dwSize)))
+                    <*> peek (p `plusPtr` (#const offsetof(WSAQUERYSET,lpszServiceInstanceName)))
+                    <*> peek (p `plusPtr` (#const offsetof(WSAQUERYSET,dwNameSpace))) 
+                    <*> peek (p `plusPtr` (#const offsetof(WSAQUERYSET,dwNumberOfCsAddrs)))
+                    <*> peek (p `plusPtr` (#const offsetof(WSAQUERYSET,lpcsaBuffer)))
+                    <*> peek (p `plusPtr` (#const offsetof(WSAQUERYSET,lpBlob)))
+
+foreign import stdcall safe "WSALookupServiceBeginA" wsaLookupServiceBegin
+    :: Ptr (WSAQUERYSET SockAddrBTH) -> DWORD -> Ptr HANDLE -> IO CInt
+foreign import stdcall safe "WSALookupServiceNextA" wsaLookupServiceNext
+    :: HANDLE -> DWORD -> Ptr DWORD -> Ptr (WSAQUERYSET SockAddrBTH) -> IO CInt
+foreign import stdcall safe "WSALookupServiceEnd" wsaLookupServiceEnd
+    :: HANDLE -> IO CInt
+
+-- | The Bluetooth namespace
+nS_BTH :: DWORD
+nS_BTH = 16
+
+aF_BTH :: USHORT
+aF_BTH = 32
+
+wsaServiceNotFound :: ErrCode
+wsaServiceNotFound = 10108
+
+wsaENoMore :: ErrCode
+wsaENoMore = 10110
+
+bTHPROTO_RFCOMM :: CInt
+bTHPROTO_RFCOMM = 0x0003
+
+discover' :: Adapter -> DWORD -> IO [(BluetoothAddr, Maybe ByteString)]
+discover' a flags = alloca $ \pqs -> alloca $ \ph -> do
+    poke pqs $ WSAQUERYSET {
+        qsSize            = fromIntegral $ sizeOf (undefined :: WSAQUERYSET SockAddrBTH),
+        qsServiceInstanceName = nullPtr,
+        qsNameSpace       = nS_BTH,
+        qsNumberOfCsAddrs = 0,
+        qsCsAddrs         = nullPtr,
+        qsBlob            = nullPtr
+      }
+    ret <- wsaLookupServiceBegin pqs flags ph
+    none <- if ret < 0 then do
+        err <- getLastError
+        if err == wsaServiceNotFound  -- This error means that there are no devices
+            then pure True
+            else throwIO =<< BluetoothException "discover" <$> (peekTString =<< getErrorMessage err)
+      else
+        pure False
+    if none then
+        return []
+      else do
+        h <- peek ph
+        do
+            let bufSize = 5000
+            alloca $ \pResults -> allocaBytes bufSize $ \buf -> alloca $ \pdwSize -> do
+                poke pResults $ WSAQUERYSET {
+                    qsSize            = fromIntegral $ sizeOf (undefined :: WSAQUERYSET SockAddrBTH),
+                    qsServiceInstanceName = nullPtr,
+                    qsNameSpace       = nS_BTH,
+                    qsNumberOfCsAddrs = 0,
+                    qsCsAddrs         = nullPtr,
+                    qsBlob            = nullPtr
+                  }
+                let loop acc = do
+                        poke pdwSize (fromIntegral bufSize)
+                        ret <- wsaLookupServiceNext h flags pdwSize pResults
+                        if ret < 0 then do
+                            err <- getLastError
+                            if err == wsaENoMore
+                                then pure $ reverse acc
+                                else throwIO =<< BluetoothException "discover" <$> (peekTString =<< getErrorMessage err)
+                          else do
+                            results <- peek pResults
+                            csAddrs <- peekArray (fromIntegral $ qsNumberOfCsAddrs results) (qsCsAddrs results)
+                            addrs <- mapM (peek . saSockaddr . csaRemoteAddr) csAddrs
+                            serviceName <- if qsServiceInstanceName results == nullPtr
+                                then pure Nothing
+                                else Just . C.pack <$> peekCString (qsServiceInstanceName results)
+                            loop $ reverse (map (\addr -> (bthAddr addr, serviceName)) addrs) ++ acc
+                loop []
+          `finally`
+            wsaLookupServiceEnd h
+

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain

+ examples/discover.hs view

@@ -0,0 +1,24 @@+{-# LANGUAGE ScopedTypeVariables #-}
+import Network.Bluetooth
+import Network.Socket (withSocketsDo)
+import Control.Applicative
+import Control.Exception
+import Control.Monad (mapM_)
+import System.IO
+
+main = withSocketsDo $ do
+    mAdapter <- defaultAdapter
+    case mAdapter of
+        Just adapter -> do
+            devs <- discover adapter
+            mapM_ printDev devs
+        Nothing -> hPutStrLn stderr "no local bluetooth adapter found"
+  where
+    printDev dev@(Device _ addr) = do
+        putStr $ show addr ++ " "
+        hFlush stdout
+        name <- (Just <$> deviceName dev)
+            `catch` \(exc :: BluetoothException) -> return Nothing
+        print name
+        hFlush stdout
+

+ simple-bluetooth.cabal view

@@ -0,0 +1,40 @@+-- Initial bluetooth.cabal generated by cabal init.  For further 
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name:                simple-bluetooth
+version:             0.1.0.0
+synopsis:            Simple Bluetooth API for Windows and Linux (bluez)
+description:         You must use 'Network.withSocketsDo' at the start of your program
+                     for Windows compatibility.
+license:             BSD3
+license-file:        LICENSE
+author:              Stephen Blackheath
+maintainer:          docks.cattlemen.stephen@blacksapphire.com
+-- copyright:           
+category:            Network
+build-type:          Simple
+extra-source-files:  examples/discover.hs
+cabal-version:       >=1.10
+
+library
+  exposed-modules:   
+      Network.Bluetooth  
+      Network.Bluetooth.Adapter
+      Network.Bluetooth.Device
+  other-modules:       
+      Network.Bluetooth.Types
+  if os(windows)
+    other-modules:
+      Network.Bluetooth.Win32
+  build-depends:       base >=4.5 && <5,
+                       network,
+                       bytestring
+  if os(windows)
+    build-depends: Win32
+  default-language:    Haskell2010
+  if os(windows)
+    extra-libraries:   ws2_32
+    include-dirs: Network/Bluetooth/
+  else
+    extra-libraries:   bluetooth
+