module Network.Zephyr.CBits where
import Foreign
import Foreign.C.Types
import Foreign.C.String
import System.Posix.Types (Fd(Fd))
import qualified Data.ByteString.Char8 as B
import qualified Data.Time as Time
import qualified Data.Time.Clock.POSIX as POSIXTime
newtype Code_t = Code_t {unCode_t :: CInt}
deriving (Eq, Show)
zerr_none :: Code_t
zerr_none = Code_t 0
zauth_no :: Code_t
zauth_no = Code_t 0
zauth_yes :: Code_t
zauth_yes = Code_t 1
zauth_failed :: Code_t
zauth_failed = Code_t (1)
error_message :: Code_t -> String
error_message c = unsafePerformIO $ c_error_message c >>= peekCString
newtype ZNoticeKind = ZNoticeKind { unZNoticeKind :: CInt }
deriving (Show, Eq, Storable);
kind_unsafe :: ZNoticeKind
kind_unsafe = ZNoticeKind 0
kind_unacked :: ZNoticeKind
kind_unacked = ZNoticeKind 1
kind_acked :: ZNoticeKind
kind_acked = ZNoticeKind 2
kind_hmack :: ZNoticeKind
kind_hmack = ZNoticeKind 3
kind_hmctl :: ZNoticeKind
kind_hmctl = ZNoticeKind 4
kind_servack :: ZNoticeKind
kind_servack = ZNoticeKind 5
kind_servnak :: ZNoticeKind
kind_servnak = ZNoticeKind 6
kind_clientack :: ZNoticeKind
kind_clientack = ZNoticeKind 7
kind_stat :: ZNoticeKind
kind_stat = ZNoticeKind 8
data ZAuth = Authenticated
| Unauthenticated
| AuthenticationFailed
deriving (Show, Eq, Enum, Bounded)
data ZSubscription = ZSubscription { sub_class :: B.ByteString
, sub_instance :: B.ByteString
, sub_recipient :: B.ByteString
}
withZSubscription :: ZSubscription -> (Ptr ZSubscription -> IO a) -> IO a
withZSubscription sub code = do
B.useAsCString (sub_class sub) $ \c_class -> do
B.useAsCString (sub_instance sub) $ \c_inst -> do
B.useAsCString (sub_recipient sub) $ \c_recip -> do
allocaBytes ((12)) $ \c_sub -> do
(\hsc_ptr -> pokeByteOff hsc_ptr 0) c_sub c_recip
(\hsc_ptr -> pokeByteOff hsc_ptr 4) c_sub c_class
(\hsc_ptr -> pokeByteOff hsc_ptr 8) c_sub c_inst
code c_sub
subSize :: Int
subSize = (12)
withSubs :: [ZSubscription] -> ((Ptr ZSubscription, CInt) -> IO a) -> IO a
withSubs subs code = let n_subs = length subs in
withMany withZSubscription subs $ \c_subs -> do
allocaBytes (n_subs * subSize) $ \c_array -> do
copySubs c_array c_subs
code (c_array, fromIntegral n_subs)
where copySubs to (s:ss) = do copyBytes to s subSize
copySubs (to `plusPtr` subSize) ss
copySubs _ [] = return ()
data ZNotice = ZNotice { z_version :: B.ByteString
, z_class :: B.ByteString
, z_instance :: B.ByteString
, z_recipient :: B.ByteString
, z_opcode :: B.ByteString
, z_sender :: Maybe B.ByteString
, z_default_fmt :: B.ByteString
, z_kind :: ZNoticeKind
, z_auth :: ZAuth
, z_fields :: [B.ByteString]
, z_time :: Time.UTCTime
}
allocaZNotice :: (Ptr ZNotice -> IO a) -> IO a
allocaZNotice comp = allocaBytes ((188)) $ \c_note -> do
memset c_note 0 ((188))
comp c_note
withZNotice :: ZNotice -> (Ptr ZNotice -> IO a) -> IO a
withZNotice note comp = do
allocaZNotice $ \c_note -> do
B.useAsCString (z_class note) $ \c_class -> do
B.useAsCString (z_instance note) $ \c_instance -> do
B.useAsCString (z_recipient note) $ \c_recipient -> do
B.useAsCString (z_opcode note) $ \c_opcode -> do
B.useAsCString (z_default_fmt note) $ \c_fmt -> do
B.useAsCStringLen message $ \(c_message, c_msg_len) -> do
maybeWith B.useAsCString (z_sender note) $ \c_sender -> do
(\hsc_ptr -> pokeByteOff hsc_ptr 8) c_note (z_kind note)
(\hsc_ptr -> pokeByteOff hsc_ptr 60) c_note (0::CInt)
(\hsc_ptr -> pokeByteOff hsc_ptr 80) c_note c_class
(\hsc_ptr -> pokeByteOff hsc_ptr 84) c_note c_instance
(\hsc_ptr -> pokeByteOff hsc_ptr 88) c_note c_opcode
(\hsc_ptr -> pokeByteOff hsc_ptr 100) c_note c_fmt
(\hsc_ptr -> pokeByteOff hsc_ptr 172) c_note c_message
(\hsc_ptr -> pokeByteOff hsc_ptr 176) c_note c_msg_len
(\hsc_ptr -> pokeByteOff hsc_ptr 92) c_note c_sender
comp c_note
where message :: B.ByteString
message = B.append (B.intercalate (B.pack "\0") $ z_fields note) (B.pack "\0")
parseZNotice :: Ptr ZNotice -> IO ZNotice
parseZNotice c_note = do
version <- (\hsc_ptr -> peekByteOff hsc_ptr 4) c_note >>= B.packCString
cls <- (\hsc_ptr -> peekByteOff hsc_ptr 80) c_note >>= B.packCString
inst <- (\hsc_ptr -> peekByteOff hsc_ptr 84) c_note >>= B.packCString
recip <- (\hsc_ptr -> peekByteOff hsc_ptr 96) c_note >>= B.packCString
opcode <- (\hsc_ptr -> peekByteOff hsc_ptr 88) c_note >>= B.packCString
sender <- (\hsc_ptr -> peekByteOff hsc_ptr 92) c_note >>= B.packCString
fmt <- (\hsc_ptr -> peekByteOff hsc_ptr 100) c_note >>= B.packCString
kind <- (\hsc_ptr -> peekByteOff hsc_ptr 8) c_note
secs <- (\hsc_ptr -> peekByteOff hsc_ptr 52) c_note
time <- return $ POSIXTime.posixSecondsToUTCTime (realToFrac (secs :: CTime))
c_len <- (\hsc_ptr -> peekByteOff hsc_ptr 176) c_note
c_msg <- (\hsc_ptr -> peekByteOff hsc_ptr 172) c_note
message <- B.packCStringLen (c_msg, c_len)
fields <- return $ filterFields $ B.split '\0' message
c_auth <- z_check_authentication c_note $ (\hsc_ptr -> hsc_ptr `plusPtr` 12) c_note
auth <- case c_auth of
_ | c_auth == zauth_no -> return Unauthenticated
| c_auth == zauth_yes -> return Authenticated
| c_auth == zauth_failed -> return AuthenticationFailed
| otherwise -> fail $ error_message c_auth
return $ ZNotice { z_version = version
, z_class = cls
, z_instance = inst
, z_recipient = recip
, z_opcode = opcode
, z_sender = Just sender
, z_default_fmt = fmt
, z_kind = kind
, z_auth = auth
, z_fields = fields
, z_time = time
}
where filterFields = id
newtype SockAddr = SockAddr { unSockAddr :: SockAddr }
type Port = CUShort
foreign import ccall unsafe "error_message"
c_error_message :: Code_t -> IO CString
foreign import ccall unsafe "ZInitialize"
z_initialize :: IO Code_t
foreign import ccall unsafe "ZOpenPort"
z_open_port :: Ptr Port -> IO Code_t
foreign import ccall unsafe "ZClosePort"
z_close_port :: IO Code_t
foreign import ccall unsafe "ZGetSender"
z_get_sender :: IO CString
foreign import ccall unsafe "&__Zephyr_realm"
z_realm :: CString
type ZAuthProc = FunPtr (Ptr ZNotice -> CString -> CInt -> IO (Ptr CInt))
foreign import ccall unsafe "ZSendNotice"
z_send_notice :: Ptr ZNotice -> ZAuthProc -> IO Code_t
foreign import ccall unsafe "&ZMakeAuthentication"
z_make_authentication :: ZAuthProc
foreign import ccall unsafe "ZCancelSubscriptions"
z_cancel_subscriptions :: Port -> IO Code_t
foreign import ccall unsafe "ZSubscribeTo"
z_subscribe_to :: Ptr ZSubscription -> CInt -> Port -> IO Code_t
foreign import ccall unsafe "ZUnsubscribeTo"
z_unsubscribe_to :: Ptr ZSubscription -> CInt -> Port -> IO Code_t
foreign import ccall unsafe "ZReceiveNotice"
z_receive_notice :: Ptr ZNotice -> Ptr SockAddr -> IO Code_t
foreign import ccall unsafe "ZCheckAuthentication"
z_check_authentication :: Ptr ZNotice -> Ptr SockAddr -> IO Code_t
foreign import ccall unsafe "ZFreeNotice"
z_free_notice :: Ptr ZNotice -> IO ()
foreign import ccall unsafe "ZPending"
z_pending :: IO CInt
foreign import ccall unsafe "&__Zephyr_fd"
z_fd :: Ptr Fd
foreign import ccall unsafe "string.h"
memset :: Ptr a -> CInt -> CSize -> IO ()