module EIBd.Client.Connection (
Connection,
connectRemote,
connectLocal,
defaultPort,
Message (..),
APCI (..),
recvMessage,
sendMessage,
sendMessage',
GroupMessage (..),
recvGroupMessage,
sendGroupMessage,
) where
import Control.Monad
import Control.Applicative
import Control.Exception
import Data.Bits
import qualified Data.ByteString as B
import Foreign hiding (void)
import Foreign.C
import EIBd.Client.Address
foreign import ccall "EIBSocketRemote"
socketRemote :: CString -> CInt -> IO (Ptr ConnStruct)
foreign import ccall "EIBSocketLocal"
socketLocal :: CString -> IO (Ptr ConnStruct)
foreign import ccall "&EIBClose"
closeConnection :: FunPtr (Ptr ConnStruct -> IO ())
foreign import ccall "EIBOpen_GroupSocket"
openGroupSocket :: Ptr ConnStruct -> CInt -> IO CInt
foreign import ccall "EIBGetGroup_Src"
recvGroup :: Ptr ConnStruct -> CInt -> Ptr Word8 -> Ptr Word16 -> Ptr Word16 -> IO CInt
foreign import ccall "EIBSendGroup"
sendGroup :: Ptr ConnStruct -> CUShort -> CInt -> Ptr CChar -> IO CInt
data ConnStruct
newtype Connection
= Connection { connHandle :: ForeignPtr ConnStruct }
deriving Show
withHandle :: Connection -> (Ptr ConnStruct -> IO a) -> IO a
withHandle = withForeignPtr . connHandle
connectRemote :: B.ByteString -> Word16 -> IO Connection
connectRemote host' port' = B.useAsCString host' $ \host -> do
cs <- socketRemote host (fromIntegral port')
when (cs == nullPtr) (fail "Failed to connect")
openGroupSocket cs 0
fmap Connection (newForeignPtr closeConnection cs)
connectLocal :: B.ByteString -> IO Connection
connectLocal path' = B.useAsCString path' $ \path -> do
cs <- socketLocal path
when (cs == nullPtr) (fail "Failed to connect")
openGroupSocket cs 0
fmap Connection (newForeignPtr closeConnection cs)
defaultPort :: Word16
defaultPort = 6720
data APCI
= GroupAddrRead
| GroupAddrResponse
| GroupAddrWrite
| IndividualWrite
| IndividualRequest
| IndividualResponse
| AdcRead
| AdcResponse
| MemoryRead
| MemoryResponse
| MemoryWrite
| UserMessage
| MaskVersionRead
| MaskVersionResponse
| Restart
| Escape
deriving (Show, Eq, Ord)
data Message = Message { messageSource :: IndividualAddress
, messageDestination :: GroupAddress
, messageTPCI :: Word8
, messageAPCI :: APCI
, messagePayload :: B.ByteString }
deriving (Show, Eq)
toAPCI :: Word8 -> APCI
toAPCI 0 = GroupAddrRead
toAPCI 1 = GroupAddrResponse
toAPCI 2 = GroupAddrWrite
toAPCI 3 = IndividualWrite
toAPCI 4 = IndividualRequest
toAPCI 5 = IndividualResponse
toAPCI 6 = AdcRead
toAPCI 7 = AdcResponse
toAPCI 8 = MemoryRead
toAPCI 9 = MemoryResponse
toAPCI 10 = MemoryWrite
toAPCI 11 = UserMessage
toAPCI 12 = MaskVersionRead
toAPCI 13 = MaskVersionResponse
toAPCI 14 = Restart
toAPCI 15 = Escape
toAPCI _ = undefined
fromAPCI :: APCI -> Word8
fromAPCI GroupAddrRead = 0
fromAPCI GroupAddrResponse = 1
fromAPCI GroupAddrWrite = 2
fromAPCI IndividualWrite = 3
fromAPCI IndividualRequest = 4
fromAPCI IndividualResponse = 5
fromAPCI AdcRead = 6
fromAPCI AdcResponse = 7
fromAPCI MemoryRead = 8
fromAPCI MemoryResponse = 9
fromAPCI MemoryWrite = 10
fromAPCI UserMessage = 11
fromAPCI MaskVersionRead = 12
fromAPCI MaskVersionResponse = 13
fromAPCI Restart = 14
fromAPCI Escape = 15
recvMessage :: Connection -> IO Message
recvMessage conn = withHandle conn $ \ptr ->
bracket allocStuff freeStuff $ \(buf, srcPtr, dstPtr) -> do
len <- recvGroup ptr 32 buf srcPtr dstPtr
when (len < 2) (fail "Failed to read group message")
arr <- evaluate =<< peekArray (fromIntegral len) buf
src <- evaluate =<< peek srcPtr
dst <- evaluate =<< peek dstPtr
let t : a : xs = arr
let tpci = shift t (2)
let payload = B.pack (a .&. 63 : xs)
let apci = toAPCI ((shift t 2 .&. 12) .|. (shift a (6) .&. 3))
return (Message (IndividualAddress src)
(GroupAddress dst)
tpci
apci
payload)
where
allocStuff = (,,) <$> mallocArray 32
<*> malloc
<*> malloc
freeStuff (buf, srcPtr, dstPtr) = do
free buf
free srcPtr
free dstPtr
sendMessage :: Connection -> GroupAddress -> Word8 -> APCI -> B.ByteString -> IO Bool
sendMessage conn (GroupAddress dst) tpci apci' payload = fmap (>= 0) . withHandle conn $ \ptr ->
B.useAsCStringLen apdu $ \(buf, len) ->
sendGroup ptr (CUShort dst) (fromIntegral len) buf
where
apci = fromAPCI apci'
octet0 = shift tpci 2 .|. (shift apci (2) .&. 3)
octet1Mask = shift (apci .&. 3) 6
apdu = case B.unpack payload of
[] -> B.pack [octet0, octet1Mask]
x : xs -> B.pack (octet0 : (octet1Mask .|. x) : xs)
sendMessage' :: Connection -> Message -> IO Bool
sendMessage' conn (Message _ dst tpci apci payload) =
sendMessage conn dst tpci apci payload
data GroupMessage
= GroupRead
| GroupResponse B.ByteString
| GroupWrite B.ByteString
deriving (Show, Eq)
recvGroupMessage :: Connection -> IO (IndividualAddress, GroupAddress, GroupMessage)
recvGroupMessage conn = do
Message src dst _ cmd payload <- recvMessage conn
case cmd of
GroupAddrRead -> return (src, dst, GroupRead)
GroupAddrResponse -> return (src, dst, GroupResponse payload)
GroupAddrWrite -> return (src, dst, GroupWrite payload)
_ -> recvGroupMessage conn
sendGroupMessage :: Connection -> GroupAddress -> GroupMessage -> IO Bool
sendGroupMessage conn dst GroupRead =
sendMessage conn dst 0 GroupAddrRead B.empty
sendGroupMessage conn dst (GroupResponse payload) =
sendMessage conn dst 0 GroupAddrResponse payload
sendGroupMessage conn dst (GroupWrite payload) =
sendMessage conn dst 0 GroupAddrWrite payload