diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,31 +0,0 @@ -hosc - haskell open sound control ---------------------------------- - -[hosc][hosc] provides `Sound.OSC`, a [haskell][hs] -module implementing a subset of the [Open Sound Control][osc] byte protocol. -hosc is required by the [hsc3][hsc3] haskell [supercollider][sc3] bindings. - -There are a number of related projects: - -- [hosc-json](?t=hosc-json): JSON text encoding of OSC -- [hosc-utils](?t=hosc-utils): command line utilities - -© [rohan drape][rd], [stefan kersten][sk] and others, 2007-2014, -[gpl][gpl]. with contributions by: - -- [alex mclean][am] -- [henning thielemann][ht] - -see the [darcs][darcs] [history](?t=hosc&q=history) for details - -[hosc]: http://rd.slavepianos.org/?t=hosc -[hs]: http://haskell.org/ -[osc]: http://opensoundcontrol.org/ -[hsc3]: http://rd.slavepianos.org/?t=hsc3 -[sc3]: http://audiosynth.com/ -[rd]: http://rd.slavepianos.org/ -[sk]: http://space.k-hornz.de/ -[am]: http://yaxu.org/ -[ht]: http://www.henning-thielemann.de/Research.html -[darcs]: http://darcs.net/ -[gpl]: http://gnu.org/copyleft/ diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,39 @@ +hosc - haskell open sound control +--------------------------------- + +[hosc][hosc] provides `Sound.Osc`, a [haskell][hs] +module implementing a subset of the [Open Sound Control][osc] byte protocol. +hosc is required by the [hsc3][hsc3] Haskell [SuperCollider][sc3] bindings. + +See also: + +- [hosc-json](http://rohandrape.net/?t=hosc-json): Json text encoding of Osc +- [hosc-util](http://rohandrape.net/?t=hosc-util): non-core Osc functions + +© [Rohan Drape][rd], [Stefan Kersten][sk] and others, 2007-2024, +[Gpl-3][gpl-3]. with contributions by: + +- [Alex McLean][am] +- [Henning Thielemann][ht] + +Please see the [history](http://rohandrape.net/?t=hosc&q=history) for details + +[hosc]: http://rohandrape.net/?t=hosc +[hs]: http://haskell.org/ +[osc]: https://opensoundcontrol.stanford.edu/ +[hsc3]: http://rohandrape.net/?t=hsc3 +[sc3]: http://audiosynth.com/ +[rd]: http://rohandrape.net/ +[sk]: http://space.k-hornz.de/ +[am]: http://yaxu.org/ +[ht]: http://www.henning-thielemann.de/Research.html +[gpl]: http://gnu.org/copyleft/ +[gpl-3]: http://gnu.org/licenses/gpl-3.0.html + +* * * + +``` +$ make doctest +Examples: 110 Tried: 110 Errors: 0 Failures: 0 +$ +``` diff --git a/Sound/OSC.hs b/Sound/OSC.hs deleted file mode 100644 --- a/Sound/OSC.hs +++ /dev/null @@ -1,8 +0,0 @@ --- | Composite of "Sound.OSC.Core" and "Sound.OSC.Transport.Monad". -module Sound.OSC (module M) where - -import Control.Monad.IO.Class as M (MonadIO,liftIO) -import Sound.OSC.Core as M -import Sound.OSC.Transport.FD.UDP as M -import Sound.OSC.Transport.FD.TCP as M -import Sound.OSC.Transport.Monad as M diff --git a/Sound/OSC/Class.hs b/Sound/OSC/Class.hs deleted file mode 100644 --- a/Sound/OSC/Class.hs +++ /dev/null @@ -1,31 +0,0 @@ --- | Typeclass for encoding and decoding OSC packets. -module Sound.OSC.Class where - -import Sound.OSC.Type -import Sound.OSC.Coding - --- | A type-class for values that can be translated to and from OSC --- 'Packet's. -class OSC o where - toPacket :: o -> Packet -- ^ Translation to 'Packet'. - fromPacket :: Packet -> Maybe o -- ^ Translation from 'Packet'. - -instance OSC Message where - toPacket = Packet_Message - fromPacket = packet_to_message - -instance OSC Bundle where - toPacket = Packet_Bundle - fromPacket = Just . packet_to_bundle - -instance OSC Packet where - toPacket = id - fromPacket = Just - --- | 'encodePacket' '.' 'toPacket'. -encodeOSC :: (Coding c,OSC o) => o -> c -encodeOSC = encodePacket . toPacket - --- | 'fromPacket' '.' 'decodePacket'. -decodeOSC :: (Coding c,OSC o) => c -> Maybe o -decodeOSC = fromPacket . decodePacket diff --git a/Sound/OSC/Coding.hs b/Sound/OSC/Coding.hs deleted file mode 100644 --- a/Sound/OSC/Coding.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE FlexibleInstances,TypeSynonymInstances #-} --- | A type-class to provide coding operations to different data types --- using the same function names. -module Sound.OSC.Coding where - -import qualified Data.ByteString as S {- bytestring -} -import qualified Data.ByteString.Lazy as B {- bytestring -} -import qualified Data.ByteString.Lazy.Char8 as C {- bytestring -} - -import Sound.OSC.Type -import qualified Sound.OSC.Coding.Decode.Binary as Binary -import qualified Sound.OSC.Coding.Encode.Builder as Builder - --- | Converting from and to binary packet representations. -class Coding a where - encodePacket :: Packet -> a -- ^ Decode an OSC packet. - decodePacket :: a -> Packet -- ^ Encode an OSC packet. - -instance Coding S.ByteString where - encodePacket = Builder.encodePacket_strict - decodePacket = Binary.decodePacket_strict - -instance Coding B.ByteString where - encodePacket = Builder.encodePacket - decodePacket = Binary.decodePacket - -instance Coding String where - encodePacket = C.unpack . encodePacket - decodePacket = decodePacket . C.pack - --- | An 'encodePacket' and 'decodePacket' pair over 'B.ByteString'. -type Coder = (Packet -> B.ByteString,B.ByteString -> Packet) - --- | 'encodePacket' '.' 'Packet_Message'. -encodeMessage :: Coding c => Message -> c -encodeMessage = encodePacket . Packet_Message - --- | 'encodePacket' '.' 'Packet_Bundle'. -encodeBundle :: Coding c => Bundle -> c -encodeBundle = encodePacket . Packet_Bundle - --- | 'packet_to_message' '.' 'decodePacket'. -decodeMessage :: Coding c => c -> Maybe Message -decodeMessage = packet_to_message . decodePacket - --- | 'packet_to_bundle' '.' 'decodePacket'. -decodeBundle :: Coding c => c -> Bundle -decodeBundle = packet_to_bundle . decodePacket diff --git a/Sound/OSC/Coding/Byte.hs b/Sound/OSC/Coding/Byte.hs deleted file mode 100644 --- a/Sound/OSC/Coding/Byte.hs +++ /dev/null @@ -1,112 +0,0 @@ --- | Byte-level coding utility functions. -module Sound.OSC.Coding.Byte where - -import Data.Binary {- base -} -import Data.Bits {- base -} -import qualified Data.ByteString as S {- bytestring -} -import qualified Data.ByteString.Char8 as S.C {- bytestring -} -import qualified Data.ByteString.Lazy as L {- bytestring -} -import qualified Data.ByteString.Lazy.Char8 as L.C {- bytestring -} -import Data.Int {- base -} - -import Sound.OSC.Coding.Cast -import Sound.OSC.Type - --- | Encode a signed 8-bit integer. -encode_i8 :: Int -> L.ByteString -encode_i8 n = encode (fromIntegral n :: Int8) - --- | Encode an un-signed 8-bit integer. -encode_u8 :: Int -> L.ByteString -encode_u8 n = encode (fromIntegral n :: Word8) - --- | Encode a signed 16-bit integer. -encode_i16 :: Int -> L.ByteString -encode_i16 n = encode (fromIntegral n :: Int16) - --- | Encode a signed 32-bit integer. -encode_i32 :: Int -> L.ByteString -encode_i32 n = encode (fromIntegral n :: Int32) - --- | Encode an unsigned 16-bit integer. -encode_u32 :: Int -> L.ByteString -encode_u32 n = encode (fromIntegral n :: Word32) - --- | Encode a signed 64-bit integer. -encode_i64 :: Int64 -> L.ByteString -encode_i64 = encode - --- | Encode an unsigned 64-bit integer. -encode_u64 :: Word64 -> L.ByteString -encode_u64 = encode - --- | Encode a 32-bit IEEE floating point number. -encode_f32 :: Float -> L.ByteString -encode_f32 = encode . f32_w32 - --- | Encode a 64-bit IEEE floating point number. -encode_f64 :: Double -> L.ByteString -encode_f64 = encode . f64_w64 - --- | Encode an ASCII string. -encode_str :: ASCII -> L.ByteString -{-# INLINE encode_str #-} -encode_str = L.pack . S.unpack - --- | Decode an un-signed 8-bit integer. -decode_u8 :: L.ByteString -> Int -decode_u8 = fromIntegral . L.head - --- | Decode a signed 8-bit integer. -decode_i8 :: L.ByteString -> Int -decode_i8 b = fromIntegral (decode b :: Int8) - --- | Decode a signed 16-bit integer. -decode_i16 :: L.ByteString -> Int -decode_i16 b = fromIntegral (decode b :: Int16) - --- | Decode a signed 32-bit integer. -decode_i32 :: L.ByteString -> Int -decode_i32 b = fromIntegral (decode b :: Int32) - --- | Decode an unsigned 32-bit integer. -decode_u32 :: L.ByteString -> Int -decode_u32 b = fromIntegral (decode b :: Word32) - --- | Decode a signed 64-bit integer. -decode_i64 :: L.ByteString -> Int64 -decode_i64 = decode - --- | Decode an unsigned 64-bit integer. -decode_u64 :: L.ByteString -> Word64 -decode_u64 = decode - --- | Decode a 32-bit IEEE floating point number. -decode_f32 :: L.ByteString -> Float -decode_f32 b = w32_f32 (decode b :: Word32) - --- | Decode a 64-bit IEEE floating point number. -decode_f64 :: L.ByteString -> Double -decode_f64 b = w64_f64 (decode b :: Word64) - --- | Decode an ASCII string. -decode_str :: L.ByteString -> ASCII -{-# INLINE decode_str #-} -decode_str = S.C.pack . L.C.unpack - --- | Bundle header as a (strict) 'S.C.ByteString'. -bundleHeader_strict :: S.C.ByteString -bundleHeader_strict = S.C.pack "#bundle\0" - --- | Bundle header as a lazy ByteString. -bundleHeader :: L.ByteString -{-# INLINE bundleHeader #-} -bundleHeader = L.C.fromChunks [bundleHeader_strict] - --- | The number of bytes required to align an OSC value to the next --- 4-byte boundary. --- --- > map align [0::Int .. 7] == [0,3,2,1,0,3,2,1] -align :: (Num i,Bits i) => i -> i -{-# INLINE align #-} -align n = ((n + 3) .&. complement 3) - n diff --git a/Sound/OSC/Coding/Cast.hs b/Sound/OSC/Coding/Cast.hs deleted file mode 100644 --- a/Sound/OSC/Coding/Cast.hs +++ /dev/null @@ -1,43 +0,0 @@ --- | Bit-level type casts and byte layout string typecasts. -module Sound.OSC.Coding.Cast (f32_w32,w32_f32 - ,f64_w64,w64_f64 - ,str_cstr,cstr_str - ,str_pstr,pstr_str) where - -import qualified Data.Binary.IEEE754 as I {- data-binary-ieee754 -} -import Data.Char {- base -} -import Data.Word {- base -} - --- | The IEEE byte representation of a float. -f32_w32 :: Float -> Word32 -f32_w32 = I.floatToWord - --- | Inverse of 'f32_w32'. -w32_f32 :: Word32 -> Float -w32_f32 = I.wordToFloat - --- | The IEEE byte representation of a double. -f64_w64 :: Double -> Word64 -f64_w64 = I.doubleToWord - --- | Inverse of 'f64_i64'. -w64_f64 :: Word64 -> Double -w64_f64 = I.wordToDouble - --- | Transform a haskell string into a C string (a null suffixed byte --- string). -str_cstr :: String -> [Word8] -str_cstr s = map (fromIntegral . ord) s ++ [0] - --- | Inverse of 'str_cstr'. -cstr_str :: [Word8] -> String -cstr_str = map (chr . fromIntegral) . takeWhile (/= 0) - --- | Transform a haskell string to a pascal string (a length prefixed --- byte string). -str_pstr :: String -> [Word8] -str_pstr s = fromIntegral (length s) : map (fromIntegral . ord) s - --- | Inverse of 'str_pstr'. -pstr_str :: [Word8] -> String -pstr_str = map (chr . fromIntegral) . drop 1 diff --git a/Sound/OSC/Coding/Decode/Base.hs b/Sound/OSC/Coding/Decode/Base.hs deleted file mode 100644 --- a/Sound/OSC/Coding/Decode/Base.hs +++ /dev/null @@ -1,104 +0,0 @@ --- | Base-level decode function for OSC packets (slow). For ordinary --- use see 'Sound.OSC.Coding.Decode.Binary'. -module Sound.OSC.Coding.Decode.Base (decodeMessage - ,decodeBundle - ,decodePacket) where - -import Data.Binary {- base -} -import qualified Data.ByteString.Char8 as C {- bytestring -} -import qualified Data.ByteString.Lazy as B {- bytestring -} -import Data.List {- base -} -import Data.Maybe {- base -} - -import Sound.OSC.Coding.Byte -import Sound.OSC.Time -import Sound.OSC.Type - --- The plain byte count of an OSC value. -size :: Datum_Type -> B.ByteString -> Int -size ty b = - case ty of - 'i' -> 4 - 'f' -> 4 - 'd' -> 8 - 't' -> 8 -- timetag - 'm' -> 4 -- MIDI message - 's' -> fromIntegral (fromMaybe - (error ("size: no terminating zero: " ++ show b)) - (B.elemIndex 0 b)) - 'b' -> decode_i32 (B.take 4 b) - _ -> error "size: illegal type" - --- The storage byte count of an OSC value. -storage :: Datum_Type -> B.ByteString -> Int -storage ty b = - case ty of - 's' -> let n = size 's' b + 1 in n + align n - 'b' -> let n = size 'b' b in n + align n + 4 - _ -> size ty B.empty - --- Decode an OSC datum -decode_datum :: Datum_Type -> B.ByteString -> Datum -decode_datum ty b = - case ty of - 'i' -> Int32 (decode b) - 'h' -> Int64 (decode b) - 'f' -> Float (decode_f32 b) - 'd' -> Double (decode_f64 b) - 's' -> ASCII_String (decode_str (b_take (size 's' b) b)) - 'b' -> Blob (b_take (size 'b' b) (B.drop 4 b)) - 't' -> TimeStamp (ntpi_to_ntpr (decode_u64 b)) - 'm' -> let [b0,b1,b2,b3] = B.unpack (B.take 4 b) - in midi (b0,b1,b2,b3) - _ -> error ("decode_datum: illegal type (" ++ [ty] ++ ")") - --- Decode a sequence of OSC datum given a type descriptor string. -decode_datum_seq :: ASCII -> B.ByteString -> [Datum] -decode_datum_seq cs b = - let swap (x,y) = (y,x) - cs' = C.unpack cs - f b' c = swap (B.splitAt (fromIntegral (storage c b')) b') - in zipWith decode_datum cs' (snd (mapAccumL f b cs')) - --- | Decode an OSC 'Message'. -decodeMessage :: B.ByteString -> Message -decodeMessage b = - let n = storage 's' b - (ASCII_String cmd) = decode_datum 's' b - m = storage 's' (b_drop n b) - (ASCII_String dsc) = decode_datum 's' (b_drop n b) - arg = decode_datum_seq (descriptor_tags dsc) (b_drop (n + m) b) - in Message (C.unpack cmd) arg - --- Decode a sequence of OSC messages, each one headed by its length -decode_message_seq :: B.ByteString -> [Message] -decode_message_seq b = - let s = decode_i32 b - m = decodeMessage (b_drop 4 b) - nxt = decode_message_seq (b_drop (4+s) b) - in if B.length b == 0 then [] else m:nxt - --- | Decode an OSC 'Bundle'. -decodeBundle :: B.ByteString -> Bundle -decodeBundle b = - let h = storage 's' b -- header (should be '#bundle') - t = storage 't' (b_drop h b) -- time tag - (TimeStamp timeStamp) = decode_datum 't' (b_drop h b) - ms = decode_message_seq (b_drop (h+t) b) - in Bundle timeStamp ms - --- | Decode an OSC 'Packet'. --- --- > let b = B.pack [47,103,95,102,114,101,101,0,44,105,0,0,0,0,0,0] --- > in decodePacket b == Message "/g_free" [Int 0] -decodePacket :: B.ByteString -> Packet -decodePacket b = - if bundleHeader `B.isPrefixOf` b - then Packet_Bundle (decodeBundle b) - else Packet_Message (decodeMessage b) - -b_take :: Int -> B.ByteString -> B.ByteString -b_take = B.take . fromIntegral - -b_drop :: Int -> B.ByteString -> B.ByteString -b_drop = B.drop . fromIntegral diff --git a/Sound/OSC/Coding/Decode/Binary.hs b/Sound/OSC/Coding/Decode/Binary.hs deleted file mode 100644 --- a/Sound/OSC/Coding/Decode/Binary.hs +++ /dev/null @@ -1,116 +0,0 @@ --- | Optimised decode function for OSC packets. -module Sound.OSC.Coding.Decode.Binary - (getPacket - ,decodePacket - ,decodePacket_strict) where - -import Control.Applicative {- base -} -import Control.Monad (when) {- base -} -import qualified Data.Binary.Get as G {- binary -} -import qualified Data.Binary.IEEE754 as I {- data-binary-ieee754 -} -import qualified Data.ByteString.Char8 as S.C {- bytestring -} -import qualified Data.ByteString.Lazy as B {- bytestring -} -import qualified Data.ByteString.Lazy.Char8 as C {- bytestring -} -import Data.Int {- base -} -import Data.Word {- base -} - -import Sound.OSC.Coding.Byte -import Sound.OSC.Time -import Sound.OSC.Type - --- | Get a 32 bit integer in big-endian byte order. -getInt32be :: G.Get Int32 -getInt32be = fromIntegral <$> G.getWord32be - --- | Get a 64 bit integer in big-endian byte order. -getInt64be :: G.Get Int64 -getInt64be = fromIntegral <$> G.getWord64be - --- | Get an aligned OSC string. -get_string :: G.Get String -get_string = do - s <- G.getLazyByteStringNul - G.skip (fromIntegral (align (B.length s + 1))) - return $ C.unpack s - --- | Get an aligned OSC string. -get_ascii :: G.Get ASCII -get_ascii = do - s <- G.getLazyByteStringNul - G.skip (fromIntegral (align (B.length s + 1))) - return (S.C.pack (C.unpack s)) - --- | Get binary data prefixed by byte count. -get_bytes :: Word32 -> G.Get B.ByteString -get_bytes n = do - b <- G.getLazyByteString (fromIntegral n) - if n /= fromIntegral (B.length b) - then fail "get_bytes: end of stream" - else G.skip (fromIntegral (align n)) - return b - --- | Get an OSC datum. -get_datum :: Datum_Type -> G.Get Datum -get_datum ty = - case ty of - 'i' -> Int32 <$> fromIntegral <$> getInt32be - 'h' -> Int64 <$> fromIntegral <$> getInt64be - 'f' -> Float <$> realToFrac <$> I.getFloat32be - 'd' -> Double <$> I.getFloat64be - 's' -> ASCII_String <$> get_ascii - 'b' -> Blob <$> (get_bytes =<< G.getWord32be) - 't' -> TimeStamp <$> ntpi_to_ntpr <$> G.getWord64be - 'm' -> do b0 <- G.getWord8 - b1 <- G.getWord8 - b2 <- G.getWord8 - b3 <- G.getWord8 - return $ Midi (MIDI b0 b1 b2 b3) - _ -> fail ("get_datum: illegal type " ++ show ty) - --- | Get an OSC 'Message'. -get_message :: G.Get Message -get_message = do - cmd <- get_string - dsc <- get_ascii - case S.C.unpack dsc of - ',':tags -> do - arg <- mapM get_datum tags - return $ Message cmd arg - _ -> fail "get_message: invalid type descriptor string" - --- | Get a sequence of OSC 'Message's, each one headed by its length. -get_message_seq :: G.Get [Message] -get_message_seq = do - b <- G.isEmpty - if b - then return [] - else do - p <- flip G.isolate get_message . fromIntegral =<< G.getWord32be - ps <- get_message_seq - return (p:ps) - --- | Get a bundle. Fail if bundle header is not found in packet. -get_bundle :: G.Get Bundle -get_bundle = do - h <- G.getByteString (S.C.length bundleHeader_strict) - when (h /= bundleHeader_strict) (fail "get_bundle: not a bundle") - t <- ntpi_to_ntpr <$> G.getWord64be - ps <- get_message_seq - return $ Bundle t ps - --- | Get an OSC 'Packet'. -getPacket :: G.Get Packet -getPacket = (Packet_Bundle <$> get_bundle) <|> (Packet_Message <$> get_message) - --- | Decode an OSC packet from a lazy ByteString. --- --- > let b = B.pack [47,103,95,102,114,101,101,0,44,105,0,0,0,0,0,0] --- > in decodeOSC b == Message "/g_free" [Int 0] -decodePacket :: B.ByteString -> Packet -{-# INLINE decodePacket #-} -decodePacket = G.runGet getPacket - --- | Decode an OSC packet from a strict ByteString. -decodePacket_strict :: S.C.ByteString -> Packet -{-# INLINE decodePacket_strict #-} -decodePacket_strict = G.runGet getPacket . B.fromChunks . (:[]) diff --git a/Sound/OSC/Coding/Encode/Base.hs b/Sound/OSC/Coding/Encode/Base.hs deleted file mode 100644 --- a/Sound/OSC/Coding/Encode/Base.hs +++ /dev/null @@ -1,56 +0,0 @@ --- | Base-level encode function for OSC packets (slow). For ordinary --- use see 'Sound.OSC.Coding.Encode.Builder'. -module Sound.OSC.Coding.Encode.Base (encodeMessage - ,encodeBundle - ,encodePacket) where - -import Data.Binary {- base -} -import qualified Data.ByteString.Char8 as C {- bytestring -} -import qualified Data.ByteString.Lazy as B {- bytestring -} - -import Sound.OSC.Coding.Byte -import Sound.OSC.Type -import Sound.OSC.Time - --- Align a byte string if required. -extend :: Word8 -> B.ByteString -> B.ByteString -extend p s = B.append s (B.replicate (align (B.length s)) p) - --- Encode an OSC datum. -encode_datum :: Datum -> B.ByteString -encode_datum dt = - case dt of - Int32 i -> encode i - Int64 i -> encode i - Float f -> encode_f32 f - Double d -> encode_f64 d - TimeStamp t -> encode_u64 $ ntpr_to_ntpi t - ASCII_String s -> extend 0 (B.snoc (encode_str s) 0) - Midi (MIDI b0 b1 b2 b3) -> B.pack [b0,b1,b2,b3] - Blob b -> let n = encode_i32 (fromIntegral (B.length b)) - in B.append n (extend 0 b) - --- | Encode an OSC 'Message'. -encodeMessage :: Message -> B.ByteString -encodeMessage (Message c l) = - B.concat [encode_datum (ASCII_String (C.pack c)) - ,encode_datum (ASCII_String (descriptor l)) - ,B.concat (map encode_datum l) ] - --- Encode an OSC 'Message' as an OSC blob. -encode_message_blob :: Message -> Datum -encode_message_blob = Blob . encodeMessage - --- | Encode an OSC 'Bundle'. -encodeBundle :: Bundle -> B.ByteString -encodeBundle (Bundle t m) = - B.concat [bundleHeader - ,encode_u64 (ntpr_to_ntpi t) - ,B.concat (map (encode_datum . encode_message_blob) m)] - --- | Encode an OSC 'Packet'. -encodePacket :: Packet -> B.ByteString -encodePacket o = - case o of - Packet_Message m -> encodeMessage m - Packet_Bundle b -> encodeBundle b diff --git a/Sound/OSC/Coding/Encode/Builder.hs b/Sound/OSC/Coding/Encode/Builder.hs deleted file mode 100644 --- a/Sound/OSC/Coding/Encode/Builder.hs +++ /dev/null @@ -1,95 +0,0 @@ --- | Optimised encode function for OSC packets. -module Sound.OSC.Coding.Encode.Builder - (build_packet - ,encodeMessage - ,encodeBundle - ,encodePacket - ,encodePacket_strict) where - -import qualified Data.Binary.IEEE754 as I {- data-binary-ieee754 -} -import qualified Data.ByteString as S {- bytestring -} -import qualified Data.ByteString.Lazy as L {- bytestring -} -import qualified Blaze.ByteString.Builder as B {- bytestring -} -import qualified Blaze.ByteString.Builder.Char8 as B {- bytestring -} -import Data.Monoid (mappend, mconcat) {- base -} -import Data.Word (Word8) {- base -} - -import Sound.OSC.Coding.Byte (align, bundleHeader) -import Sound.OSC.Time -import Sound.OSC.Type - --- Generate a list of zero bytes for padding. -padding :: Integral i => i -> [Word8] -padding n = replicate (fromIntegral n) 0 - --- Encode a string with zero padding. -build_ascii :: ASCII -> B.Builder -build_ascii s = B.fromByteString s `mappend` B.fromWord8s (0:padding (align (S.length s + 1))) - --- Encode a string with zero padding. -build_string :: String -> B.Builder -build_string s = B.fromString s `mappend` B.fromWord8s (0:padding (align (length s + 1))) - --- Encode a byte string with prepended length and zero padding. -build_bytes :: L.ByteString -> B.Builder -build_bytes s = B.fromInt32be (fromIntegral (L.length s)) - `mappend` B.fromLazyByteString s - `mappend` B.fromWord8s (padding (align (L.length s))) - --- Encode an OSC datum. -build_datum :: Datum -> B.Builder -build_datum d = - case d of - Int32 i -> B.fromInt32be (fromIntegral i) - Int64 i -> B.fromInt64be (fromIntegral i) - Float n -> B.fromWord32be (I.floatToWord (realToFrac n)) - Double n -> B.fromWord64be (I.doubleToWord n) - TimeStamp t -> B.fromWord64be (fromIntegral (ntpr_to_ntpi t)) - ASCII_String s -> build_ascii s - Midi (MIDI b0 b1 b2 b3) -> B.fromWord8s [b0,b1,b2,b3] - Blob b -> build_bytes b - --- Encode an OSC 'Message'. -build_message :: Message -> B.Builder -build_message (Message c l) = - mconcat [build_string c - ,build_ascii (descriptor l) - ,mconcat $ map build_datum l] - --- Encode an OSC 'Bundle'. -build_bundle_ntpi :: NTPi -> [Message] -> B.Builder -build_bundle_ntpi t l = - mconcat [B.fromLazyByteString bundleHeader - ,B.fromWord64be t - ,mconcat $ map (build_bytes . B.toLazyByteString . build_message) l] - --- | Builder monoid for an OSC 'Packet'. -build_packet :: Packet -> B.Builder -build_packet o = - case o of - Packet_Message m -> build_message m - Packet_Bundle (Bundle t m) -> build_bundle_ntpi (ntpr_to_ntpi t) m - -{-# INLINE encodeMessage #-} -{-# INLINE encodeBundle #-} -{-# INLINE encodePacket #-} -{-# INLINE encodePacket_strict #-} - --- | Encode an OSC 'Message'. -encodeMessage :: Message -> L.ByteString -encodeMessage = B.toLazyByteString . build_packet . Packet_Message - --- | Encode an OSC 'Bundle'. -encodeBundle :: Bundle -> L.ByteString -encodeBundle = B.toLazyByteString . build_packet . Packet_Bundle - --- | Encode an OSC 'Packet' to a lazy 'L.ByteString'. --- --- > let b = L.pack [47,103,95,102,114,101,101,0,44,105,0,0,0,0,0,0] --- > in encodeOSC (Message "/g_free" [Int 0]) == b -encodePacket :: Packet -> L.ByteString -encodePacket = B.toLazyByteString . build_packet - --- | Encode an Packet packet to a strict ByteString. -encodePacket_strict :: Packet -> S.ByteString -encodePacket_strict = B.toByteString . build_packet diff --git a/Sound/OSC/Core.hs b/Sound/OSC/Core.hs deleted file mode 100644 --- a/Sound/OSC/Core.hs +++ /dev/null @@ -1,22 +0,0 @@ --- | Composite of non-transport related modules. --- --- Provides the 'Datum', 'Message', 'Bundle' and 'Packet' types and --- the 'Datem', 'OSC' and 'Coding' type-classes. --- --- The basic constructors are 'message' and 'bundle', the basic coding --- functions are 'encodePacket' and 'decodePacket'. --- --- > import Sound.OSC.Core --- > --- > let {o = bundle immediately [message "/g_free" [Int32 0]] --- > ;e = encodeBundle o :: String} --- > in decodeBundle e == o -module Sound.OSC.Core (module M) where - -import Sound.OSC.Class as M -import Sound.OSC.Coding as M -import Sound.OSC.Datum as M -import Sound.OSC.Normalise as M -import Sound.OSC.Time as M -import Sound.OSC.Type as M -import Sound.OSC.Wait as M diff --git a/Sound/OSC/Datum.hs b/Sound/OSC/Datum.hs deleted file mode 100644 --- a/Sound/OSC/Datum.hs +++ /dev/null @@ -1,64 +0,0 @@ --- | 'Datum' related functions. -module Sound.OSC.Datum where - -import qualified Data.ByteString.Lazy as B {- bytestring -} -import qualified Data.ByteString.Char8 as C {- bytestring -} -import Data.Int {- base -} -import Data.Word {- base -} - -import Sound.OSC.Type - --- | Type specialised 'd_get'. --- --- > map datum_int32 [Int32 1,Float 1] == [Just 1,Nothing] -datum_int32 :: Datum -> Maybe Int32 -datum_int32 = d_get - --- | Type specialised 'd_get'. -datum_int64 :: Datum -> Maybe Int64 -datum_int64 = d_get - --- | Type specialised 'd_get'. -datum_float :: Datum -> Maybe Float -datum_float = d_get - --- | Type specialised 'd_get'. -datum_double :: Datum -> Maybe Double -datum_double = d_get - --- | Type specialised 'd_get'. --- --- > datum_ascii (d_put (C.pack "string")) == Just (C.pack "string") -datum_ascii :: Datum -> Maybe ASCII -datum_ascii = d_get - --- | 'C.unpack' of 'd_get'. --- --- > datum_string (d_put (C.pack "string")) == Just "string" --- > map datum_string [string "string",Int32 5] == [Just "string",Nothing] -datum_string :: Datum -> Maybe String -datum_string = fmap C.unpack . datum_ascii - --- | Type specialised 'd_get'. -datum_blob :: Datum -> Maybe B.ByteString -datum_blob = d_get - --- | 'Maybe' variant of 'd_timestamp'. -datum_timestamp :: Datum -> Maybe Time -datum_timestamp d = case d of {TimeStamp x -> Just x;_ -> Nothing} - --- | Type specialised 'd_get'. -datum_midi :: Datum -> Maybe MIDI -datum_midi = d_get - --- | 'Datum' as sequence of 'Word8' if 'ASCII_String', 'Blob' or 'Midi'. --- --- > let d = [string "5",Blob (B.pack [53]),midi (0x00,0x90,0x40,0x60)] --- > in Data.Maybe.mapMaybe datum_sequence d == [[53],[53],[0,144,64,96]] -datum_sequence :: Datum -> Maybe [Word8] -datum_sequence d = - case d of - ASCII_String s -> Just (map (fromIntegral . fromEnum) (C.unpack s)) - Blob s -> Just (B.unpack s) - Midi (MIDI p q r s) -> Just [p,q,r,s] - _ -> Nothing diff --git a/Sound/OSC/FD.hs b/Sound/OSC/FD.hs deleted file mode 100644 --- a/Sound/OSC/FD.hs +++ /dev/null @@ -1,7 +0,0 @@ --- | Composite of "Sound.OSC.Core" and "Sound.OSC.Transport.FD". -module Sound.OSC.FD (module M) where - -import Sound.OSC.Core as M -import Sound.OSC.Transport.FD as M -import Sound.OSC.Transport.FD.UDP as M -import Sound.OSC.Transport.FD.TCP as M diff --git a/Sound/OSC/Normalise.hs b/Sound/OSC/Normalise.hs deleted file mode 100644 --- a/Sound/OSC/Normalise.hs +++ /dev/null @@ -1,64 +0,0 @@ --- | Datum normalisation. -module Sound.OSC.Normalise where - -import Sound.OSC.Type as O - --- | Lift 'O.Int32' to 'O.Int64' and 'O.Float' to 'O.Double'. --- --- > map normalise_datum [Int32 1,Float 1] == [Int64 1,Double 1] -normalise_datum :: Datum -> Datum -normalise_datum d = - case d of - Int32 n -> Int64 (fromIntegral n) - Float n -> Double (realToFrac n) - _ -> d - --- | A normalised 'O.Message' has only 'O.Int64' and 'O.Double' --- numerical values. --- --- > let m = message "/m" [Int32 0,Float 0] --- > in normalise_message m == message "/m" [Int64 0,Double 0] -normalise_message :: Message -> Message -normalise_message = message_coerce normalise_datum - --- | A normalised 'O.Bundle' has only 'O.Int64' and 'O.Double' --- numerical values. -normalise_bundle :: Bundle -> Bundle -normalise_bundle = bundle_coerce normalise_datum - --- * Coercion - --- | Map a normalising function over datum at an OSC 'Message'. -message_coerce :: (Datum -> Datum) -> Message -> Message -message_coerce f (Message s xs) = Message s (map f xs) - --- | Map a normalising function over datum at an OSC 'Bundle'. -bundle_coerce :: (Datum -> Datum) -> Bundle -> Bundle -bundle_coerce f (Bundle t xs) = Bundle t (map (message_coerce f) xs) - --- * Promotion - --- | Coerce 'Int32', 'Int64' and 'Float' to 'Double'. --- --- > map datum_promote [Int32 5,Float 5] == [Double 5,Double 5] -datum_promote :: Datum -> Datum -datum_promote d = - case d of - Int32 n -> Double (fromIntegral n) - Int64 n -> Double (fromIntegral n) - Float n -> Double (realToFrac n) - _ -> d - --- | 'O.Datum' as 'O.Int64' if 'O.Int32', 'O.Int64', 'O.Float' or --- 'O.Double'. --- --- > let d = [Int32 5,Int64 5,Float 5.5,Double 5.5,string "5"] --- > in map datum_floor d == [Int64 5,Int64 5,Int64 5,Int64 5,string "5"] -datum_floor :: Datum -> Datum -datum_floor d = - case d of - Int32 x -> Int64 (fromIntegral x) - Float x -> Int64 (fromInteger (floor x)) - Double x -> Int64 (fromInteger (floor x)) - _ -> d - diff --git a/Sound/OSC/Time.hs b/Sound/OSC/Time.hs deleted file mode 100644 --- a/Sound/OSC/Time.hs +++ /dev/null @@ -1,111 +0,0 @@ --- | OSC related timing functions. OSC timestamps are @NTP@ values, --- . -module Sound.OSC.Time where - -import Control.Concurrent {- base -} -import Control.Monad {- base -} -import Control.Monad.IO.Class {- transformers -} -import Data.Word {- base -} -import qualified Data.Time as T {- time -} -import qualified Data.Time.Clock.POSIX as T {- time -} - -import Sound.OSC.Type - --- * Temporal types - --- | Type for integer (binary) representation of @NTP@ time. -type NTPi = Word64 - --- | @Unix/Posix@ epoch time in real-valued (fractional) form. -type UT = Double - --- * Time conversion - --- | Convert a real-valued NTP timestamp to an 'NTPi' timestamp. -ntpr_to_ntpi :: RealFrac n => n -> NTPi -ntpr_to_ntpi t = round (t * 2^(32::Int)) - --- | Convert an 'NTPi' timestamp to a real-valued NTP timestamp. -ntpi_to_ntpr :: Fractional n => NTPi -> n -ntpi_to_ntpr t = fromIntegral t / 2^(32::Int) - --- | Difference (in seconds) between /NTP/ and /UT/ epochs. --- --- > ntp_ut_epoch_diff / (24 * 60 * 60) == 25567 -ntp_ut_epoch_diff :: Num n => n -ntp_ut_epoch_diff = (70 * 365 + 17) * 24 * 60 * 60 - --- | Convert a 'UT' timestamp to an 'NTPi' timestamp. -ut_to_ntpi :: UT -> NTPi -ut_to_ntpi t = ntpr_to_ntpi (t + ntp_ut_epoch_diff) - --- | Convert @Unix/Posix@ to @NTP@. -ut_to_ntpr :: Num n => n -> n -ut_to_ntpr = (+) ntp_ut_epoch_diff - --- | Convert @NTP@ to @Unix/Posix@. -ntpr_to_ut :: Num n => n -> n -ntpr_to_ut = (+) (negate ntp_ut_epoch_diff) - --- | Convert 'NTPi' to @Unix/Posix@. -ntpi_to_ut :: NTPi -> UT -ntpi_to_ut = ntpr_to_ut . ntpi_to_ntpr - --- * 'Data.Time' inter-operation. - --- | The time at 1970-01-01:00:00:00. -ut_epoch :: T.UTCTime -ut_epoch = - let d = T.fromGregorian 1970 1 1 - s = T.secondsToDiffTime 0 - in T.UTCTime d s - --- | Convert 'T.UTCTime' to @Unix/Posix@. -utc_to_ut :: Fractional n => T.UTCTime -> n -utc_to_ut t = realToFrac (T.diffUTCTime t ut_epoch) - --- * Clock operations - --- | Read current real-valued @NTP@ timestamp. --- --- > do {ct <- fmap utc_to_ut T.getCurrentTime --- > ;pt <- fmap realToFrac T.getPOSIXTime --- > ;print (pt - ct,pt - ct < 1e-5)} -time :: MonadIO m => m Time -time = liftIO (fmap (ut_to_ntpr . realToFrac) T.getPOSIXTime) - --- * Thread operations. - --- | The 'pauseThread' limit (in seconds). Values larger than this --- require a different thread delay mechanism, see 'sleepThread'. The --- value is the number of microseconds in @maxBound::Int@. -pauseThreadLimit :: Fractional n => n -pauseThreadLimit = fromIntegral (maxBound::Int) / 1e6 - --- | Pause current thread for the indicated duration (in seconds), see --- 'pauseThreadLimit'. -pauseThread :: (MonadIO m,Ord n,RealFrac n) => n -> m () -pauseThread n = when (n > 0) (liftIO (threadDelay (floor (n * 1e6)))) - --- | Type restricted 'pauseThread'. -wait :: MonadIO m => Double -> m () -wait = pauseThread - --- | Pause current thread until the given 'Time', see --- 'pauseThreadLimit'. -pauseThreadUntil :: MonadIO m => Time -> m () -pauseThreadUntil t = pauseThread . (t -) =<< time - --- | Sleep current thread for the indicated duration (in seconds). --- Divides long sleeps into parts smaller than 'pauseThreadLimit'. -sleepThread :: (RealFrac n, MonadIO m) => n -> m () -sleepThread n = - if n >= pauseThreadLimit - then let n' = pauseThreadLimit - 1 - in pauseThread n >> sleepThread (n - n') - else pauseThread n - --- | Sleep current thread until the given 'Time'. Divides long sleeps --- into parts smaller than 'pauseThreadLimit'. -sleepThreadUntil :: MonadIO m => Time -> m () -sleepThreadUntil t = sleepThread . (t -) =<< time diff --git a/Sound/OSC/Transport/FD.hs b/Sound/OSC/Transport/FD.hs deleted file mode 100644 --- a/Sound/OSC/Transport/FD.hs +++ /dev/null @@ -1,98 +0,0 @@ --- | An abstract transport layer with implementations for @UDP@ and --- @TCP@ transport. -module Sound.OSC.Transport.FD where - -import Control.Exception {- base -} -import Data.List {- base -} -import Data.Maybe {- base -} - -import Sound.OSC.Class -import Sound.OSC.Type -import Sound.OSC.Wait - --- | Abstract over the underlying transport protocol. -class Transport t where - -- | Encode and send an OSC packet. - sendOSC :: OSC o => t -> o -> IO () - -- | Receive and decode an OSC packet. - recvPacket :: t -> IO Packet - -- | Close an existing connection. - close :: t -> IO () - --- | Bracket OSC communication. -withTransport :: Transport t => IO t -> (t -> IO a) -> IO a -withTransport u = bracket u close - --- * Send - --- | Type restricted synonym for 'sendOSC'. -sendMessage :: Transport t => t -> Message -> IO () -sendMessage = sendOSC - --- | Type restricted synonym for 'sendOSC'. -sendBundle :: Transport t => t -> Bundle -> IO () -sendBundle = sendOSC - --- * Receive - --- | Variant of 'recvPacket' that runs 'fromPacket'. -recvOSC :: (Transport t,OSC o) => t -> IO (Maybe o) -recvOSC = fmap fromPacket . recvPacket - --- | Variant of 'recvPacket' that runs 'packet_to_bundle'. -recvBundle :: (Transport t) => t -> IO Bundle -recvBundle = fmap packet_to_bundle . recvPacket - --- | Variant of 'recvPacket' that runs 'packet_to_message'. -recvMessage :: (Transport t) => t -> IO (Maybe Message) -recvMessage = fmap packet_to_message . recvPacket - --- | Variant of 'recvPacket' that runs 'packetMessages'. -recvMessages :: (Transport t) => t -> IO [Message] -recvMessages = fmap packetMessages . recvPacket - --- * Timeout - --- | Variant of 'recvPacket' that implements an /n/ second 'timeout'. -recvPacketTimeout :: (Transport t) => Double -> t -> IO (Maybe Packet) -recvPacketTimeout n fd = timeout_r n (recvPacket fd) - --- * Wait - --- | Wait for a 'Packet' where the supplied predicate is 'True', --- discarding intervening packets. -waitUntil :: (Transport t) => t -> (Packet -> Bool) -> IO Packet -waitUntil t f = untilPredicate f (recvPacket t) - --- | Wait for a 'Packet' where the supplied function does not give --- 'Nothing', discarding intervening packets. -waitFor :: (Transport t) => t -> (Packet -> Maybe a) -> IO a -waitFor t f = untilMaybe f (recvPacket t) - --- | 'waitUntil' 'packet_is_immediate'. -waitImmediate :: Transport t => t -> IO Packet -waitImmediate t = waitUntil t packet_is_immediate - --- | 'waitFor' 'packet_to_message', ie. an incoming 'Message' or --- immediate mode 'Bundle' with one element. -waitMessage :: Transport t => t -> IO Message -waitMessage t = waitFor t packet_to_message - --- | A 'waitFor' for variant using 'packet_has_address' to match on --- the 'Address_Pattern' of incoming 'Packets'. -waitAddress :: Transport t => t -> Address_Pattern -> IO Packet -waitAddress t s = - let f o = if packet_has_address s o then Just o else Nothing - in waitFor t f - --- | Variant on 'waitAddress' that returns matching 'Message'. -waitReply :: Transport t => t -> Address_Pattern -> IO Message -waitReply t s = - let f = fromMaybe (error "waitReply: message not located?") . - find (message_has_address s) . - packetMessages - in fmap f (waitAddress t s) - --- | Variant of 'waitReply' that runs 'messageDatum'. -waitDatum :: Transport t => t -> Address_Pattern -> IO [Datum] -waitDatum t = fmap messageDatum . waitReply t diff --git a/Sound/OSC/Transport/FD/TCP.hs b/Sound/OSC/Transport/FD/TCP.hs deleted file mode 100644 --- a/Sound/OSC/Transport/FD/TCP.hs +++ /dev/null @@ -1,43 +0,0 @@ --- | OSC over TCP implementation. -module Sound.OSC.Transport.FD.TCP where - -import qualified Data.ByteString.Lazy as B {- bytestring -} -import Control.Monad {- base -} -import Network {- network -} -import System.IO {- base -} - -import Sound.OSC.Class -import Sound.OSC.Coding -import Sound.OSC.Coding.Byte -import Sound.OSC.Transport.FD - --- | The TCP transport handle data type. -data TCP = TCP {tcpHandle :: Handle} - -instance Transport TCP where - sendOSC (TCP fd) msg = - do let b = encodeOSC msg - n = fromIntegral (B.length b) - B.hPut fd (B.append (encode_u32 n) b) - hFlush fd - recvPacket (TCP fd) = - do b0 <- B.hGet fd 4 - b1 <- B.hGet fd (fromIntegral (decode_u32 b0)) - return (decodePacket b1) - close (TCP fd) = hClose fd - --- | Make a 'TCP' connection. -openTCP :: String -> Int -> IO TCP -openTCP host = - liftM TCP . - connectTo host . - PortNumber . - fromIntegral - --- | A trivial 'TCP' /OSC/ server. -tcpServer' :: Int -> (TCP -> IO ()) -> IO () -tcpServer' p f = do - s <- listenOn (PortNumber (fromIntegral p)) - (sequence_ . repeat) (do (fd, _, _) <- accept s - f (TCP fd) - return ()) diff --git a/Sound/OSC/Transport/FD/UDP.hs b/Sound/OSC/Transport/FD/UDP.hs deleted file mode 100644 --- a/Sound/OSC/Transport/FD/UDP.hs +++ /dev/null @@ -1,67 +0,0 @@ --- | OSC over UDP implementation. -module Sound.OSC.Transport.FD.UDP where - -import Control.Monad {- base -} -import qualified Network.Socket as N {- network -} -import qualified Network.Socket.ByteString as C {- network -} - -import Sound.OSC.Class -import Sound.OSC.Coding -import Sound.OSC.Type -import Sound.OSC.Transport.FD - --- | The UDP transport handle data type. -data UDP = UDP {udpSocket :: N.Socket} - --- | Return the port number associated with the UDP socket. -udpPort :: Integral n => UDP -> IO n -udpPort (UDP fd) = fmap fromIntegral (N.socketPort fd) - -instance Transport UDP where - -- C.L.send is not implemented for W32 - sendOSC (UDP fd) msg = void (C.send fd (encodeOSC msg)) - recvPacket (UDP fd) = liftM decodePacket (C.recv fd 8192) - close (UDP fd) = N.sClose fd - --- | Create and initialise UDP socket. -udp_socket :: (N.Socket -> N.SockAddr -> IO ()) -> String -> Int -> IO UDP -udp_socket f host port = do - fd <- N.socket N.AF_INET N.Datagram 0 - a <- N.inet_addr host - let sa = N.SockAddrInet (fromIntegral port) a - f fd sa - return (UDP fd) - --- | Make a 'UDP' connection. --- --- > let t = openUDP "127.0.0.1" 57110 --- > in withTransport t (\fd -> recvT 0.5 fd >>= print) -openUDP :: String -> Int -> IO UDP -openUDP = udp_socket N.connect --- N.setSocketOption fd N.RecvTimeOut 1000 - --- | Trivial 'UDP' server socket. --- --- > import Control.Concurrent --- --- > let {f fd = forever (recvMessage fd >>= print) --- > ;t = udpServer "127.0.0.1" 57300} --- > in void (forkIO (withTransport t f)) --- --- > let t = openUDP "127.0.0.1" 57300 --- > in withTransport t (\fd -> sendMessage fd (message "/n" [])) -udpServer :: String -> Int -> IO UDP -udpServer = udp_socket N.bindSocket - --- | Send variant to send to specified address. -sendTo :: OSC o => UDP -> o -> N.SockAddr -> IO () -sendTo (UDP fd) o a = do - -- C.L.sendTo does not exist - void (C.sendTo fd (encodeOSC o) a) - --- | Recv variant to collect message source address. -recvFrom :: UDP -> IO (Packet, N.SockAddr) -recvFrom (UDP fd) = do - -- C.L.recvFrom does not exist - (s,a) <- C.recvFrom fd 8192 - return (decodePacket s,a) diff --git a/Sound/OSC/Transport/Monad.hs b/Sound/OSC/Transport/Monad.hs deleted file mode 100644 --- a/Sound/OSC/Transport/Monad.hs +++ /dev/null @@ -1,114 +0,0 @@ --- | Monad class implementing an Open Sound Control transport. -module Sound.OSC.Transport.Monad where - -import Control.Monad (liftM) {- base -} -import Control.Monad.Trans.Reader {- transformers -} -import Control.Monad.IO.Class as M {- transformers -} -import Data.List {- base -} -import Data.Maybe {- base -} - -import Sound.OSC.Class -import qualified Sound.OSC.Transport.FD as T -import Sound.OSC.Type -import Sound.OSC.Wait - --- | Sender monad. -class Monad m => SendOSC m where - -- | Encode and send an OSC packet. - sendOSC :: OSC o => o -> m () - --- | Receiver monad. -class Monad m => RecvOSC m where - -- | Receive and decode an OSC packet. - recvPacket :: m Packet - --- | 'DuplexOSC' is the union of 'SendOSC' and 'RecvOSC'. -class (SendOSC m,RecvOSC m) => DuplexOSC m where - --- | 'Transport' is 'DuplexOSC' with a 'MonadIO' constraint. -class (DuplexOSC m,MonadIO m) => Transport m where - -instance (T.Transport t,MonadIO io) => SendOSC (ReaderT t io) where - sendOSC o = ReaderT (M.liftIO . flip T.sendOSC o) - -instance (T.Transport t,MonadIO io) => RecvOSC (ReaderT t io) where - recvPacket = ReaderT (M.liftIO . T.recvPacket) - -instance (T.Transport t,MonadIO io) => DuplexOSC (ReaderT t io) where - -instance (T.Transport t,MonadIO io) => Transport (ReaderT t io) where - --- | Transport connection. -type Connection t a = ReaderT t IO a - --- | Bracket Open Sound Control communication. -withTransport :: T.Transport t => IO t -> Connection t a -> IO a -withTransport u = T.withTransport u . runReaderT - --- * Send - --- | Type restricted synonym for 'sendOSC'. -sendMessage :: SendOSC m => Message -> m () -sendMessage = sendOSC - --- | Type restricted synonym for 'sendOSC'. -sendBundle :: SendOSC m => Bundle -> m () -sendBundle = sendOSC - --- * Receive - --- | Variant of 'recvPacket' that runs 'fromPacket'. -recvOSC :: (RecvOSC m,OSC o) => m (Maybe o) -recvOSC = liftM fromPacket recvPacket - --- | Variant of 'recvPacket' that runs 'packet_to_bundle'. -recvBundle :: (RecvOSC m) => m Bundle -recvBundle = liftM packet_to_bundle recvPacket - --- | Variant of 'recvPacket' that runs 'packet_to_message'. -recvMessage :: (RecvOSC m) => m (Maybe Message) -recvMessage = liftM packet_to_message recvPacket - --- | Variant of 'recvPacket' that runs 'packetMessages'. -recvMessages :: (RecvOSC m) => m [Message] -recvMessages = liftM packetMessages recvPacket - --- * Wait - --- | Wait for a 'Packet' where the supplied predicate is 'True', --- discarding intervening packets. -waitUntil :: (RecvOSC m) => (Packet -> Bool) -> m Packet -waitUntil f = untilPredicate f recvPacket - --- | Wait for a 'Packet' where the supplied function does not give --- 'Nothing', discarding intervening packets. -waitFor :: (RecvOSC m) => (Packet -> Maybe a) -> m a -waitFor f = untilMaybe f recvPacket - --- | 'waitUntil' 'packet_is_immediate'. -waitImmediate :: RecvOSC m => m Packet -waitImmediate = waitUntil packet_is_immediate - --- | 'waitFor' 'packet_to_message', ie. an incoming 'Message' or --- immediate mode 'Bundle' with one element. -waitMessage :: RecvOSC m => m Message -waitMessage = waitFor packet_to_message - --- | A 'waitFor' for variant using 'packet_has_address' to match on --- the 'Address_Pattern' of incoming 'Packets'. -waitAddress :: RecvOSC m => Address_Pattern -> m Packet -waitAddress s = - let f o = if packet_has_address s o then Just o else Nothing - in waitFor f - --- | Variant on 'waitAddress' that returns matching 'Message'. -waitReply :: RecvOSC m => Address_Pattern -> m Message -waitReply s = - let f = fromMaybe (error "waitReply: message not located?") . - find (message_has_address s) . - packetMessages - in liftM f (waitAddress s) - --- | Variant of 'waitReply' that runs 'messageDatum'. -waitDatum :: RecvOSC m => Address_Pattern -> m [Datum] -waitDatum = liftM messageDatum . waitReply diff --git a/Sound/OSC/Type.hs b/Sound/OSC/Type.hs deleted file mode 100644 --- a/Sound/OSC/Type.hs +++ /dev/null @@ -1,399 +0,0 @@ --- | Alegbraic data types for OSC datum and packets. -module Sound.OSC.Type where - -import qualified Data.ByteString.Lazy as B {- bytestring -} -import qualified Data.ByteString.Char8 as C {- bytestring -} -import Data.Int {- base -} -import Data.List {- base -} -import Data.Word {- base -} -import Numeric {- base -} - --- * Time - --- | @NTP@ time in real-valued (fractional) form. -type Time = Double - --- | Constant indicating a bundle to be executed immediately. -immediately :: Time -immediately = 1 / 2^(32::Int) - --- * Datum - --- | Type enumerating Datum categories. -type Datum_Type = Char - --- | Type for ASCII strings (strict 'Char'8 'C.ByteString'). -type ASCII = C.ByteString - --- | Type-specialised 'C.pack'. -ascii :: String -> ASCII -ascii = C.pack - --- | Type-specialised 'C.unpack'. -ascii_to_string :: ASCII -> String -ascii_to_string = C.unpack - --- | Four-byte midi message. -data MIDI = MIDI Word8 Word8 Word8 Word8 - deriving (Eq,Show,Read) - --- | The basic elements of OSC messages. -data Datum = Int32 {d_int32 :: Int32} - | Int64 {d_int64 :: Int64} - | Float {d_float :: Float} - | Double {d_double :: Double} - | ASCII_String {d_ascii_string :: ASCII} - | Blob {d_blob :: B.ByteString} - | TimeStamp {d_timestamp :: Time} - | Midi {d_midi :: MIDI} - deriving (Eq,Read,Show) - --- | Single character identifier of an OSC datum. -datum_tag :: Datum -> Datum_Type -datum_tag dt = - case dt of - Int32 _ -> 'i' - Int64 _ -> 'h' - Float _ -> 'f' - Double _ -> 'd' - ASCII_String _ -> 's' - Blob _ -> 'b' - TimeStamp _ -> 't' - Midi _ -> 'm' - --- | 'Datum' as 'Integral' if 'Sound.OSC.Type.Int32' or --- 'Sound.OSC.Type.Int64'. --- --- > let d = [Int32 5,Int64 5,Float 5.5,Double 5.5] --- > in map datum_integral d == [Just (5::Int),Just 5,Nothing,Nothing] -datum_integral :: Integral i => Datum -> Maybe i -datum_integral d = - case d of - Int32 x -> Just (fromIntegral x) - Int64 x -> Just (fromIntegral x) - _ -> Nothing - --- | 'Datum' as 'Floating' if 'Sound.OSC.Type.Int32', --- 'Sound.OSC.Type.Int64', 'Sound.OSC.Type.Float', --- 'Sound.OSC.Type.Double' or 'TimeStamp'. --- --- > let d = [Int32 5,Int64 5,Float 5,Double 5,TimeStamp 5] --- > in Data.Maybe.mapMaybe datum_floating d == replicate 5 (5::Double) -datum_floating :: Floating n => Datum -> Maybe n -datum_floating d = - case d of - Int32 n -> Just (fromIntegral n) - Int64 n -> Just (fromIntegral n) - Float n -> Just (realToFrac n) - Double n -> Just (realToFrac n) - TimeStamp n -> Just (realToFrac n) - _ -> Nothing - --- | Class for translating to and from 'Datum'. There are instances --- for the direct 'Datum' field types. --- --- > d_put (1::Int32) == Int32 1 --- > d_put (1::Int64) == Int64 1 --- > d_put (1::Float) == Float 1 --- > d_put (1::Double) == Double 1 --- > d_put (C.pack "str") == ASCII_String (C.pack "str") --- > d_put (B.pack [37,37]) == Blob (B.pack [37,37]) --- > d_put (MIDI 0 0 0 0) == Midi (MIDI 0 0 0 0) --- --- There are also instances for standard Haskell types. --- --- > d_put (1::Int) == Int64 1 --- > d_put (1::Integer) == Int64 1 -class Datem a where - d_put :: a -> Datum - d_get :: Datum -> Maybe a - -instance Datem Int32 where - d_put = Int32 - d_get d = case d of {Int32 x -> Just x;_ -> Nothing} - -instance Datem Int64 where - d_put = Int64 - d_get d = case d of {Int64 x -> Just x;_ -> Nothing} - -instance Datem Int where - d_put = Int64 . fromIntegral - d_get = datum_integral - -instance Datem Integer where - d_put = Int64 . fromIntegral - d_get = datum_integral - -instance Datem Float where - d_put = Float - d_get d = case d of {Float x -> Just x;_ -> Nothing} - -instance Datem Double where - d_put = Double - d_get d = case d of {Double x -> Just x;_ -> Nothing} - -instance Datem C.ByteString where - d_put = ASCII_String - d_get d = case d of {ASCII_String x -> Just x;_ -> Nothing} - -instance Datem B.ByteString where - d_put = Blob - d_get d = case d of {Blob x -> Just x;_ -> Nothing} - -instance Datem MIDI where - d_put = Midi - d_get d = case d of {Midi x -> Just x;_ -> Nothing} - --- | Type generalised 'Sound.OSC.Type.Int32'. --- --- > int32 (1::Int32) == int32 (1::Integer) --- > d_int32 (int32 (maxBound::Int32)) == maxBound --- > int32 (((2::Int) ^ (64::Int))::Int) == Int32 0 -int32 :: Integral n => n -> Datum -int32 = Int32 . fromIntegral - --- | Type generalised 'Sound.OSC.Type.Int64'. --- --- > int64 (1::Int32) == int64 (1::Integer) --- > d_int64 (int64 (maxBound::Int64)) == maxBound -int64 :: Integral n => n -> Datum -int64 = Int64 . fromIntegral - --- | Type generalised 'Sound.OSC.Type.Float'. --- --- > float (1::Int) == float (1::Double) --- > floatRange (undefined::Float) == (-125,128) --- > isInfinite (d_float (float (encodeFloat 1 256 :: Double))) == True -float :: Real n => n -> Datum -float = Float . realToFrac - --- | Type generalised 'Sound.OSC.Type.Double'. --- --- > double (1::Int) == double (1::Double) --- > double (encodeFloat 1 256 :: Double) == Double 1.157920892373162e77 -double :: Real n => n -> Datum -double = Double . realToFrac - --- | 'ASCII_String' of 'C.pack'. --- --- > string "string" == ASCII_String (C.pack "string") -string :: String -> Datum -string = ASCII_String . C.pack - --- | Four-tuple variant of 'Midi' '.' 'MIDI'. --- --- > midi (0,0,0,0) == Midi (MIDI 0 0 0 0) -midi :: (Word8,Word8,Word8,Word8) -> Datum -midi (p,q,r,s) = Midi (MIDI p q r s) - --- * Message - --- | OSC address pattern. This is strictly an ASCII value, but it is --- very common to pattern match on addresses and matching on --- 'C.ByteString' requires @OverloadedStrings@. -type Address_Pattern = String - --- | An OSC message. -data Message = Message {messageAddress :: Address_Pattern - ,messageDatum :: [Datum]} - deriving (Eq,Read,Show) - --- | 'Message' constructor. It is an 'error' if the 'Address_Pattern' --- doesn't conform to the OSC specification. -message :: Address_Pattern -> [Datum] -> Message -message a xs = - case a of - '/':_ -> Message a xs - _ -> error "message: ill-formed address pattern" - --- | Message argument types are given by a descriptor. --- --- > C.unpack (descriptor [Int32 1,Float 1,string "1"]) == ",ifs" -descriptor :: [Datum] -> ASCII -descriptor l = C.pack (',' : map datum_tag l) - --- | Descriptor tags are @comma@ prefixed. -descriptor_tags :: ASCII -> ASCII -descriptor_tags = C.drop 1 - --- * Bundle - --- | An OSC bundle. -data Bundle = Bundle {bundleTime :: Time - ,bundleMessages :: [Message]} - deriving (Eq,Read,Show) - --- | OSC 'Bundle's can be ordered (time ascending). -instance Ord Bundle where - compare (Bundle a _) (Bundle b _) = compare a b - --- | 'Bundle' constructor. It is an 'error' if the 'Message' list is --- empty. -bundle :: Time -> [Message] -> Bundle -bundle t xs = - case xs of - [] -> error "bundle: empty?" - _ -> Bundle t xs - --- * Packet - --- | An OSC 'Packet' is either a 'Message' or a 'Bundle'. -data Packet = Packet_Message {packetMessage :: Message} - | Packet_Bundle {packetBundle :: Bundle} - deriving (Eq,Read,Show) - --- | 'Packet_Bundle' '.' 'bundle'. -p_bundle :: Time -> [Message] -> Packet -p_bundle t = Packet_Bundle . bundle t - --- | 'Packet_Message' '.' 'message'. -p_message :: Address_Pattern -> [Datum] -> Packet -p_message a = Packet_Message . message a - --- | The 'Time' of 'Packet', if the 'Packet' is a 'Message' this is --- 'immediately'. -packetTime :: Packet -> Time -packetTime = at_packet (const immediately) bundleTime - --- | Retrieve the set of 'Message's from a 'Packet'. -packetMessages :: Packet -> [Message] -packetMessages = at_packet return bundleMessages - --- | If 'Packet' is a 'Message' add 'immediately' timestamp, else 'id'. -packet_to_bundle :: Packet -> Bundle -packet_to_bundle = at_packet (\m -> Bundle immediately [m]) id - --- | If 'Packet' is a 'Message' or a 'Bundle' with an /immediate/ time --- tag and with one element, return the 'Message', else 'Nothing'. -packet_to_message :: Packet -> Maybe Message -packet_to_message p = - case p of - Packet_Bundle b -> - case b of - Bundle t [m] -> if t == immediately then Just m else Nothing - _ -> Nothing - Packet_Message m -> Just m - --- | Is 'Packet' immediate, ie. a 'Bundle' with timestamp --- 'immediately', or a plain Message. -packet_is_immediate :: Packet -> Bool -packet_is_immediate = (== immediately) . packetTime - --- | Variant of 'either' for 'Packet'. -at_packet :: (Message -> a) -> (Bundle -> a) -> Packet -> a -at_packet f g p = - case p of - Packet_Message m -> f m - Packet_Bundle b -> g b - --- * Address Query - --- | Does 'Message' have the specified 'Address_Pattern'. -message_has_address :: Address_Pattern -> Message -> Bool -message_has_address x = (== x) . messageAddress - --- | Do any of the 'Message's at 'Bundle' have the specified --- 'Address_Pattern'. -bundle_has_address :: Address_Pattern -> Bundle -> Bool -bundle_has_address x = any (message_has_address x) . bundleMessages - --- | Does 'Packet' have the specified 'Address_Pattern', ie. --- 'message_has_address' or 'bundle_has_address'. -packet_has_address :: Address_Pattern -> Packet -> Bool -packet_has_address x = - at_packet (message_has_address x) - (bundle_has_address x) - --- * Pretty printing - --- | Perhaps a precision value for floating point numbers. -type FP_Precision = Maybe Int - --- | Variant of 'showFFloat' that deletes trailing zeros. --- --- > map (floatPP (Just 4)) [1,pi] == ["1.0","3.1416"] -floatPP :: RealFloat n => Maybe Int -> n -> String -floatPP p n = - let s = showFFloat p n "" - s' = dropWhile (== '0') (reverse s) - in case s' of - '.':_ -> reverse ('0' : s') - _ -> reverse s' - --- | Pretty printer for 'Time'. --- --- > timePP (Just 4) (1/3) == "0.3333" -timePP :: FP_Precision -> Time -> String -timePP = floatPP - --- | Pretty printer for vectors. --- --- > vecPP [1::Int,2,3] == "<1,2,3>" -vecPP :: Show a => [a] -> String -vecPP v = '<' : intercalate "," (map show v) ++ ">" - --- | Pretty printer for 'Datum'. --- --- > let d = [Int32 1,Float 1.2,string "str",midi (0,0x90,0x40,0x60)] --- > in map datumPP d == ["1","1.2","\"str\"","<0,144,64,96>"] -datumPP :: FP_Precision -> Datum -> String -datumPP p d = - case d of - Int32 n -> show n - Int64 n -> show n - Float n -> floatPP p n - Double n -> floatPP p n - ASCII_String s -> show (C.unpack s) - Blob s -> show s - TimeStamp t -> timePP p t - Midi (MIDI b1 b2 b3 b4) -> vecPP [b1,b2,b3,b4] - --- | Pretty printer for 'Message'. -messagePP :: FP_Precision -> Message -> String -messagePP p (Message a d) = - let d' = map (datumPP p) d - in unwords ("#message" : a : d') - --- | Pretty printer for 'Bundle'. -bundlePP :: FP_Precision -> Bundle -> String -bundlePP p (Bundle t m) = - let m' = intersperse ";" (map (messagePP p) m) - in unwords ("#bundle" : timePP p t : m') - --- | Pretty printer for 'Packet'. -packetPP :: FP_Precision -> Packet -> String -packetPP p pkt = - case pkt of - Packet_Message m -> messagePP p m - Packet_Bundle b -> bundlePP p b - --- * Parser - --- | Variant of 'read'. -readMaybe :: (Read a) => String -> Maybe a -readMaybe s = - case reads s of - [(x, "")] -> Just x - _ -> Nothing - --- | Given 'Datum_Type' attempt to parse 'Datum' at 'String'. --- --- > parse_datum 'i' "42" == Just (Int32 42) --- > parse_datum 'h' "42" == Just (Int64 42) --- > parse_datum 'f' "3.14159" == Just (Float 3.14159) --- > parse_datum 'd' "3.14159" == Just (Double 3.14159) --- > parse_datum 's' "\"pi\"" == Just (string "pi") --- > parse_datum 'b' "[112,105]" == Just (Blob (B.pack [112,105])) --- > parse_datum 'm' "(0,144,60,90)" == Just (midi (0,144,60,90)) -parse_datum :: Datum_Type -> String -> Maybe Datum -parse_datum ty = - case ty of - 'i' -> fmap Int32 . readMaybe - 'h' -> fmap Int64 . readMaybe - 'f' -> fmap Float . readMaybe - 'd' -> fmap Double . readMaybe - 's' -> fmap (ASCII_String . C.pack) . readMaybe - 'b' -> fmap (Blob . B.pack) . readMaybe - 't' -> error "parse_datum: timestamp" - 'm' -> fmap midi . readMaybe - _ -> error "parse_datum: type" diff --git a/Sound/OSC/Wait.hs b/Sound/OSC/Wait.hs deleted file mode 100644 --- a/Sound/OSC/Wait.hs +++ /dev/null @@ -1,28 +0,0 @@ --- | Waiting (for replies). -module Sound.OSC.Wait where - -import System.Timeout {- base -} - --- * Timeout - --- | Real valued variant of 'timeout'. -timeout_r :: Double -> IO a -> IO (Maybe a) -timeout_r t = timeout (floor (t * 1000000)) - --- * Wait - --- | Repeat action until predicate /f/ is 'True' when applied to --- result. -untilPredicate :: Monad m => (a -> Bool) -> m a -> m a -untilPredicate f act = - let g p = if f p then rec else return p - rec = act >>= g - in rec - --- | Repeat action until /f/ does not give 'Nothing' when applied to --- result. -untilMaybe :: Monad m => (a -> Maybe b) -> m a -> m b -untilMaybe f act = - let g p = case f p of {Nothing -> rec;Just r -> return r} - rec = act >>= g - in rec diff --git a/Sound/Osc.hs b/Sound/Osc.hs new file mode 100644 --- /dev/null +++ b/Sound/Osc.hs @@ -0,0 +1,7 @@ +-- | Composite of "Sound.Osc.Core" and "Sound.Osc.Transport.Monad". +module Sound.Osc (module M) where + +import Control.Monad.IO.Class as M (MonadIO, liftIO) +import Sound.Osc.Core as M +import Sound.Osc.Transport.Fd.Socket as M +import Sound.Osc.Transport.Monad as M diff --git a/Sound/Osc/Coding/Byte.hs b/Sound/Osc/Coding/Byte.hs new file mode 100644 --- /dev/null +++ b/Sound/Osc/Coding/Byte.hs @@ -0,0 +1,410 @@ +{- | Byte-level coding utility functions. +Plain forms are big-endian, little-endian forms have @_le@ suffix. +-} +module Sound.Osc.Coding.Byte where + +import Data.Bits {- base -} +import Data.Int {- base -} +import Data.Word {- base -} +import System.IO {- base -} + +import qualified GHC.ByteOrder {- base -} + +import qualified Data.Binary as Binary {- binary -} +import qualified Data.Binary.Get as Binary.Get {- binary -} +import qualified Data.Binary.Put as Binary.Put {- binary -} + +import qualified Data.ByteString as ByteString {- bytestring -} +import qualified Data.ByteString.Char8 as ByteString.Char8 {- bytestring -} +import qualified Data.ByteString.Internal as ByteString.Internal {- bytestring -} +import qualified Data.ByteString.Lazy as ByteString.Lazy {- bytestring -} +import qualified Data.ByteString.Lazy.Char8 as ByteString.Lazy.Char8 {- bytestring -} +import qualified Data.ByteString.Unsafe as ByteString.Unsafe {- bytestring -} + +import qualified Sound.Osc.Coding.Convert as Convert {- hosc -} + +-- * Encode + +-- | Type specialised 'Binary.encode' (big-endian). +encode_int8 :: Int8 -> ByteString.Lazy.ByteString +encode_int8 = Binary.encode + +{- | Type specialised 'Binary.encode' (big-endian). + +>>> encode_int16 0x0102 == ByteString.Lazy.pack [0x01,0x02] +True +-} +encode_int16 :: Int16 -> ByteString.Lazy.ByteString +encode_int16 = Binary.encode + +{- | Little-endian. + +>>> encode_int16_le 0x0102 == ByteString.Lazy.pack [0x02,0x01] +True +-} +encode_int16_le :: Int16 -> ByteString.Lazy.ByteString +encode_int16_le = Binary.Put.runPut . Binary.Put.putInt16le + +-- | Encode a signed 64-bit integer (big-endian). +encode_int64 :: Int64 -> ByteString.Lazy.ByteString +encode_int64 = Binary.encode + +-- | Type specialised 'Binary.encode' (big-endian). +encode_word8 :: Word8 -> ByteString.Lazy.ByteString +encode_word8 = Binary.encode + +{- | Type specialised 'Binary.encode' (big-endian). + +>>> encode_word16 0x0102 == ByteString.Lazy.pack [0x01,0x02] +True +-} +encode_word16 :: Word16 -> ByteString.Lazy.ByteString +encode_word16 = Binary.encode + +{- | Little-endian. + +>>> encode_word16_le 0x0102 == ByteString.Lazy.pack [0x02,0x01] +True +-} +encode_word16_le :: Word16 -> ByteString.Lazy.ByteString +encode_word16_le = Binary.Put.runPut . Binary.Put.putWord16le + +-- | Type specialised 'Binary.encode'. +encode_word32 :: Word32 -> ByteString.Lazy.ByteString +encode_word32 = Binary.encode + +-- | Little-endian variant of 'encode_word32'. +encode_word32_le :: Word32 -> ByteString.Lazy.ByteString +encode_word32_le = Binary.Put.runPut . Binary.Put.putWord32le + +-- | Encode an unsigned 64-bit integer. +encode_word64 :: Word64 -> ByteString.Lazy.ByteString +encode_word64 = Binary.encode + +-- * Encode/Int + +-- | Encode a signed 8-bit integer. +encode_i8 :: Int -> ByteString.Lazy.ByteString +encode_i8 = encode_int8 . Convert.int_to_int8 + +-- | Encode an un-signed 8-bit integer. +encode_u8 :: Int -> ByteString.Lazy.ByteString +encode_u8 = encode_word8 . Convert.int_to_word8 + +{- | Encode an un-signed 16-bit integer. + +>>> encode_u16 0x0102 == ByteString.Lazy.pack [1,2] +True +-} +encode_u16 :: Int -> ByteString.Lazy.ByteString +encode_u16 = encode_word16 . Convert.int_to_word16 + +{- | Little-endian. + +>>> encode_u16_le 0x0102 == ByteString.Lazy.pack [2,1] +True +-} +encode_u16_le :: Int -> ByteString.Lazy.ByteString +encode_u16_le = encode_word16_le . Convert.int_to_word16 + +-- | Encode a signed 16-bit integer. +encode_i16 :: Int -> ByteString.Lazy.ByteString +encode_i16 = Binary.encode . Convert.int_to_int16 + +-- | Encode a signed 32-bit integer. +encode_i32 :: Int -> ByteString.Lazy.ByteString +encode_i32 = Binary.encode . Convert.int_to_int32 + +{- | Encode an unsigned 32-bit integer. + +>>> ByteString.Lazy.unpack (encode_u32 0x01020304) +[1,2,3,4] +-} +encode_u32 :: Int -> ByteString.Lazy.ByteString +encode_u32 = encode_word32 . Convert.int_to_word32 + +{- | Little-endian. + +>>> ByteString.Lazy.unpack (encode_u32_le 0x01020304) +[4,3,2,1] +-} +encode_u32_le :: Int -> ByteString.Lazy.ByteString +encode_u32_le = encode_word32_le . Convert.int_to_word32 + +-- * Encode/Float + +{- | Encode a 32-bit IEEE floating point number. + +>>> ByteString.Lazy.unpack (encode_f32 3.141) +[64,73,6,37] +-} +encode_f32 :: Float -> ByteString.Lazy.ByteString +encode_f32 = Binary.Put.runPut . Binary.Put.putFloatbe + +{- | Little-endian variant of 'encode_f32'. + +>>> ByteString.Lazy.unpack (encode_f32_le 3.141) +[37,6,73,64] +-} +encode_f32_le :: Float -> ByteString.Lazy.ByteString +encode_f32_le = Binary.Put.runPut . Binary.Put.putFloatle + +{- | Encode a 64-bit IEEE floating point number. + +>>> ByteString.Lazy.unpack (encode_f64 3.141) +[64,9,32,196,155,165,227,84] +-} +encode_f64 :: Double -> ByteString.Lazy.ByteString +encode_f64 = Binary.Put.runPut . Binary.Put.putDoublebe + +{- | Little-endian variant of 'encode_f64'. + +>>> ByteString.Lazy.unpack (encode_f64_le 3.141) +[84,227,165,155,196,32,9,64] +-} +encode_f64_le :: Double -> ByteString.Lazy.ByteString +encode_f64_le = Binary.Put.runPut . Binary.Put.putDoublele + +-- * Encode/Ascii + +-- | Encode an Ascii string (Ascii at Datum is an alias for a Char8 Bytetring). +encode_ascii :: ByteString.Char8.ByteString -> ByteString.Lazy.ByteString +encode_ascii = ByteString.Lazy.pack . ByteString.unpack + +-- * Decode + +-- | Type specialised 'Binary.decode'. +decode_word16 :: ByteString.Lazy.ByteString -> Word16 +decode_word16 = Binary.decode + +-- | Little-endian variant of 'decode_word16'. +decode_word16_le :: ByteString.Lazy.ByteString -> Word16 +decode_word16_le = Binary.Get.runGet Binary.Get.getWord16le + +-- | Type specialised 'Binary.decode'. +decode_int16 :: ByteString.Lazy.ByteString -> Int16 +decode_int16 = Binary.decode + +-- | Type specialised 'Binary.decode'. +decode_word32 :: ByteString.Lazy.ByteString -> Word32 +decode_word32 = Binary.decode + +-- | Little-endian variant of 'decode_word32'. +decode_word32_le :: ByteString.Lazy.ByteString -> Word32 +decode_word32_le = Binary.Get.runGet Binary.Get.getWord32le + +-- | Type specialised 'Binary.decode'. +decode_int64 :: ByteString.Lazy.ByteString -> Int64 +decode_int64 = Binary.decode + +-- | Type specialised 'Binary.decode'. +decode_word64 :: ByteString.Lazy.ByteString -> Word64 +decode_word64 = Binary.decode + +-- * Decode/Int + +-- | Decode an un-signed 8-bit integer. +decode_u8 :: ByteString.Lazy.ByteString -> Int +decode_u8 = Convert.word8_to_int . ByteString.Lazy.head + +-- | Decode a signed 8-bit integer. +decode_i8 :: ByteString.Lazy.ByteString -> Int +decode_i8 = Convert.int8_to_int . Binary.decode + +-- | Decode an unsigned 8-bit integer. +decode_u16 :: ByteString.Lazy.ByteString -> Int +decode_u16 = Convert.word16_to_int . decode_word16 + +-- | Little-endian variant of 'decode_u16'. +decode_u16_le :: ByteString.Lazy.ByteString -> Int +decode_u16_le = Convert.word16_to_int . decode_word16_le + +-- | Decode a signed 16-bit integer. +decode_i16 :: ByteString.Lazy.ByteString -> Int +decode_i16 = Convert.int16_to_int . decode_int16 + +-- | Little-endian variant of 'decode_i16'. +decode_i16_le :: ByteString.Lazy.ByteString -> Int +decode_i16_le = decode_i16 . ByteString.Lazy.reverse + +{- | Decode a signed 32-bit integer. + +>>> decode_i32 (ByteString.Lazy.pack [0x00,0x00,0x03,0xe7]) == 0x03e7 +True +-} +decode_i32 :: ByteString.Lazy.ByteString -> Int +decode_i32 = Convert.int32_to_int . Binary.decode + +{- | Little-endian variant of 'decode_i32'. + +>>> decode_i32_le (ByteString.Lazy.pack [0xe7,0x03,0x00,0x00]) == 0x03e7 +True +-} +decode_i32_le :: ByteString.Lazy.ByteString -> Int +decode_i32_le = decode_i32 . ByteString.Lazy.reverse + +{- | Decode an unsigned 32-bit integer. + +>>> decode_u32 (ByteString.Lazy.pack [1,2,3,4]) == 0x01020304 +True +-} +decode_u32 :: ByteString.Lazy.ByteString -> Int +decode_u32 = Convert.word32_to_int . decode_word32 + +{- | Little-endian variant of decode_u32. + +>>> decode_u32_le (ByteString.Lazy.pack [1,2,3,4]) == 0x04030201 +True +-} +decode_u32_le :: ByteString.Lazy.ByteString -> Int +decode_u32_le = Convert.word32_to_int . decode_word32_le + +-- * Decode/Float + +{- | Decode a 32-bit IEEE floating point number. + +>>> decode_f32 (ByteString.Lazy.pack [64,73,6,37]) +3.141 +-} +decode_f32 :: ByteString.Lazy.ByteString -> Float +decode_f32 = Binary.Get.runGet Binary.Get.getFloatbe + +-- | Little-endian variant of 'decode_f32'. +decode_f32_le :: ByteString.Lazy.ByteString -> Float +decode_f32_le = Binary.Get.runGet Binary.Get.getFloatle + +-- | Decode a 64-bit IEEE floating point number. +decode_f64 :: ByteString.Lazy.ByteString -> Double +decode_f64 = Binary.Get.runGet Binary.Get.getDoublebe + +-- * Decode/Ascii + +-- | Decode an Ascii string, inverse of 'encode_ascii'. +decode_ascii :: ByteString.Lazy.ByteString -> ByteString.Char8.ByteString +{-# INLINE decode_ascii #-} +decode_ascii = ByteString.Char8.pack . ByteString.Lazy.Char8.unpack + +-- * IO + +-- | Read /n/ bytes from /h/ and run /f/. +read_decode :: (ByteString.Lazy.ByteString -> t) -> Int -> Handle -> IO t +read_decode f n = fmap f . flip ByteString.Lazy.hGet n + +-- | Type-specialised reader for 'Binary.decode'. +read_word32 :: Handle -> IO Word32 +read_word32 = read_decode Binary.decode 4 + +-- | 'read_decode' of 'decode_word32_le'. +read_word32_le :: Handle -> IO Word32 +read_word32_le = read_decode decode_word32_le 4 + +-- | 'ByteString.Lazy.hPut' of 'encode_word32'. +write_word32 :: Handle -> Word32 -> IO () +write_word32 h = ByteString.Lazy.hPut h . encode_word32 + +-- | 'ByteString.Lazy.hPut' of 'encode_word32_le'. +write_word32_le :: Handle -> Word32 -> IO () +write_word32_le h = ByteString.Lazy.hPut h . encode_word32_le + +-- * Io/Int + +-- | 'decode_i8' of 'ByteString.Lazy.hGet'. +read_i8 :: Handle -> IO Int +read_i8 = read_decode decode_i8 1 + +-- | 'decode_i16' of 'ByteString.Lazy.hGet'. +read_i16 :: Handle -> IO Int +read_i16 = read_decode decode_i16 2 + +-- | 'decode_i32' of 'ByteString.Lazy.hGet'. +read_i32 :: Handle -> IO Int +read_i32 = read_decode decode_i32 4 + +-- | 'decode_i32_le' of 'ByteString.Lazy.hGet'. +read_i32_le :: Handle -> IO Int +read_i32_le = read_decode decode_i32_le 4 + +-- | 'decode_u32' of 'ByteString.Lazy.hGet'. +read_u32 :: Handle -> IO Int +read_u32 = read_decode decode_u32 4 + +-- | 'decode_u32_le' of 'ByteString.Lazy.hGet'. +read_u32_le :: Handle -> IO Int +read_u32_le = read_decode decode_u32_le 4 + +-- | 'ByteString.Lazy.hPut' of 'encode_u32'. +write_u32 :: Handle -> Int -> IO () +write_u32 h = ByteString.Lazy.hPut h . encode_u32 + +-- | 'ByteString.Lazy.hPut' of 'encode_u32_le'. +write_u32_le :: Handle -> Int -> IO () +write_u32_le h = ByteString.Lazy.hPut h . encode_u32_le + +-- * Io/Float + +-- | 'decode_f32' of 'ByteString.Lazy.hGet'. +read_f32 :: Handle -> IO Float +read_f32 = read_decode decode_f32 4 + +-- | 'decode_f32_le' of 'ByteString.Lazy.hGet'. +read_f32_le :: Handle -> IO Float +read_f32_le = read_decode decode_f32_le 4 + +-- * Io/Ascii + +-- | Read u8 length prefixed Ascii string (pascal string). +read_pstr :: Handle -> IO ByteString.Char8.ByteString +read_pstr h = do + n <- fmap decode_u8 (ByteString.Lazy.hGet h 1) + fmap decode_ascii (ByteString.Lazy.hGet h n) + +-- * Util + +{- | Bundle header as a (strict) 'ByteString.Char8.ByteString'. + +>>> ByteString.Char8.length bundleHeader_strict +8 +-} +bundleHeader_strict :: ByteString.Char8.ByteString +bundleHeader_strict = ByteString.Char8.pack "#bundle\0" + +{- | Bundle header as a lazy ByteString. + +>>> ByteString.Lazy.length bundleHeader +8 +-} +bundleHeader :: ByteString.Lazy.ByteString +{-# INLINE bundleHeader #-} +bundleHeader = ByteString.Lazy.Char8.fromChunks [bundleHeader_strict] + +{- | The number of bytes required to align an Osc value to the next 4-byte boundary. + +>>> map align [0::Int .. 7] +[0,3,2,1,0,3,2,1] + +>>> map align [512::Int .. 519] +[0,3,2,1,0,3,2,1] +-} +align :: (Num i, Bits i) => i -> i +{-# INLINE align #-} +align n = ((n + 3) .&. complement 3) - n + +-- * ByteString + +-- | Is machine little endian? +isLittleEndian :: Bool +isLittleEndian = GHC.ByteOrder.targetByteOrder == GHC.ByteOrder.LittleEndian + +-- | Byte-swap byte string in four-byte segments. +byteStringSwap32BitWords :: ByteString.ByteString -> ByteString.ByteString +byteStringSwap32BitWords xs = + ByteString.Internal.unsafePackLenBytes + (ByteString.length xs `quot` 4 * 4) + [ ByteString.Unsafe.unsafeIndex xs $ i * 4 + j + | i <- [0 .. ByteString.length xs `quot` 4 - 1] + , j <- [3, 2, 1, 0] + ] + +-- | If target is little-endian, swap bytes to be in network order, else identity. +byteString32BitNetworkOrder :: ByteString.ByteString -> ByteString.ByteString +byteString32BitNetworkOrder x = if isLittleEndian then byteStringSwap32BitWords x else x diff --git a/Sound/Osc/Coding/Cast.hs b/Sound/Osc/Coding/Cast.hs new file mode 100644 --- /dev/null +++ b/Sound/Osc/Coding/Cast.hs @@ -0,0 +1,72 @@ +-- | Bit-level type casts and byte layout string typecasts. +module Sound.Osc.Coding.Cast where + +import Data.Char {- base -} +import Data.Word {- base -} + +import Sound.Osc.Coding.Byte {- hosc3 -} +import Sound.Osc.Coding.Convert {- hosc -} + +{- | The IEEE byte representation of a float. + +>>> f32_w32 pi +1078530011 + +>>> f32_w32 (-7913907.5) +3404825447 + +>>> 23 ^ 7 +3404825447 +-} +f32_w32 :: Float -> Word32 +f32_w32 = decode_word32 . encode_f32 + +{- | Inverse of 'f32_w32'. + +>>> w32_f32 1078530011 +3.1415927 + +>>> w32_f32 (23 ^ 7) +-7913907.5 +-} +w32_f32 :: Word32 -> Float +w32_f32 = decode_f32 . encode_word32 + +{- | The IEEE byte representation of a double. + + +>>> f64_w64 pi +4614256656552045848 + +>>> f64_w64 1.6822072834e-314 +3404825447 +-} +f64_w64 :: Double -> Word64 +f64_w64 = decode_word64 . encode_f64 + +{- | Inverse of 'f64_w64'. + +>>> w64_f64 4614256656552045848 +3.141592653589793 + +>>> w64_f64 (23 ^ 7) +1.6822072834e-314 +-} +w64_f64 :: Word64 -> Double +w64_f64 = decode_f64 . encode_word64 + +-- | Transform a haskell string into a C string (a null suffixed byte string). +str_cstr :: String -> [Word8] +str_cstr s = map (int_to_word8 . ord) s ++ [0] + +-- | Inverse of 'str_cstr'. +cstr_str :: [Word8] -> String +cstr_str = map (chr . word8_to_int) . takeWhile (/= 0) + +-- | Transform a haskell string to a pascal string (a length prefixed byte string). +str_pstr :: String -> [Word8] +str_pstr s = int_to_word8 (length s) : map (int_to_word8 . ord) s + +-- | Inverse of 'str_pstr'. +pstr_str :: [Word8] -> String +pstr_str = map (chr . word8_to_int) . drop 1 diff --git a/Sound/Osc/Coding/Convert.hs b/Sound/Osc/Coding/Convert.hs new file mode 100644 --- /dev/null +++ b/Sound/Osc/Coding/Convert.hs @@ -0,0 +1,129 @@ +-- | Type conversion. +module Sound.Osc.Coding.Convert where + +import Data.Int {- base -} +import Data.Word {- base -} + +-- * Int -> N + +-- | Type specialised 'fromIntegral' +int_to_word8 :: Int -> Word8 +int_to_word8 = fromIntegral + +-- | Type specialised 'fromIntegral' +int_to_word32 :: Int -> Word32 +int_to_word32 = fromIntegral + +-- | Type specialised 'fromIntegral'. +int_to_word16 :: Int -> Word16 +int_to_word16 = fromIntegral + +-- | Type specialised 'fromIntegral' +int_to_int8 :: Int -> Int8 +int_to_int8 = fromIntegral + +-- | Type specialised 'fromIntegral' +int_to_int16 :: Int -> Int16 +int_to_int16 = fromIntegral + +-- | Type specialised 'fromIntegral' +int_to_int32 :: Int -> Int32 +int_to_int32 = fromIntegral + +-- | Type specialised 'fromIntegral' +int_to_int64 :: Int -> Int64 +int_to_int64 = fromIntegral + +-- * N -> Int + +-- | Type specialised 'fromIntegral' +int8_to_int :: Int8 -> Int +int8_to_int = fromIntegral + +-- | Type specialised 'fromIntegral' +int16_to_int :: Int16 -> Int +int16_to_int = fromIntegral + +-- | Type specialised 'fromIntegral' +int32_to_int :: Int32 -> Int +int32_to_int = fromIntegral + +-- | Type specialised 'fromIntegral' +int64_to_int :: Int64 -> Int +int64_to_int = fromIntegral + +-- | Type specialised 'fromIntegral' +word8_to_int :: Word8 -> Int +word8_to_int = fromIntegral + +-- | Type specialised 'fromIntegral' +word16_to_int :: Word16 -> Int +word16_to_int = fromIntegral + +-- | Type specialised 'fromIntegral' +word32_to_int :: Word32 -> Int +word32_to_int = fromIntegral + +-- * N -> N + +-- | Type specialised 'fromIntegral' +word16_to_word32 :: Word16 -> Word32 +word16_to_word32 = fromIntegral + +-- | Type specialised 'fromIntegral' +word32_to_word16 :: Word32 -> Word16 +word32_to_word16 = fromIntegral + +-- | Type specialised 'fromIntegral' +word32_to_int32 :: Word32 -> Int32 +word32_to_int32 = fromIntegral + +-- | Type specialised 'fromIntegral' +word32_to_int64 :: Word32 -> Int64 +word32_to_int64 = fromIntegral + +-- | Type specialised 'fromIntegral' +word64_to_int64 :: Word64 -> Int64 +word64_to_int64 = fromIntegral + +-- | Type specialised 'fromIntegral' +int64_to_int32 :: Int64 -> Int32 +int64_to_int32 = fromIntegral + +-- | Type specialised 'fromIntegral' +int64_to_word32 :: Int64 -> Word32 +int64_to_word32 = fromIntegral + +-- * N -> Real + +-- | Type specialised 'fromIntegral' +word64_to_double :: Word64 -> Double +word64_to_double = fromIntegral + +-- * Enum + +-- | Type-specialised 'toEnum' of 'fromIntegral' +word8_to_enum :: Enum e => Word8 -> e +word8_to_enum = toEnum . fromIntegral + +-- | Type-specialised 'toEnum' of 'fromIntegral' +word16_to_enum :: Enum e => Word16 -> e +word16_to_enum = toEnum . fromIntegral + +-- | Type-specialised 'fromIntegral' of 'fromEnum'. +enum_to_word8 :: Enum e => e -> Word8 +enum_to_word8 = fromIntegral . fromEnum + +-- | Type-specialised 'fromIntegral' of 'fromEnum'. +enum_to_word16 :: Enum e => e -> Word16 +enum_to_word16 = fromIntegral . fromEnum + +-- * Enum/Char + +-- | Type-specialised 'word8_to_enum'. +word8_to_char :: Word8 -> Char +word8_to_char = word8_to_enum + +-- | Type-specialised 'enum_to_word8'. +char_to_word8 :: Char -> Word8 +char_to_word8 = enum_to_word8 diff --git a/Sound/Osc/Coding/Decode/Base.hs b/Sound/Osc/Coding/Decode/Base.hs new file mode 100644 --- /dev/null +++ b/Sound/Osc/Coding/Decode/Base.hs @@ -0,0 +1,122 @@ +{- | Base-level decode function for Osc packets. + For ordinary use see 'Sound.Osc.Coding.Decode.Binary'. +-} +module Sound.Osc.Coding.Decode.Base ( + decodeMessage, + decodeBundle, + decodePacket, +) where + +import Data.Binary {- base -} +import qualified Data.ByteString.Char8 as C {- bytestring -} +import qualified Data.ByteString.Lazy as B {- bytestring -} +import Data.List {- base -} +import Data.Maybe {- base -} + +import Sound.Osc.Coding.Byte {- hosc -} +import Sound.Osc.Coding.Convert {- hosc -} +import Sound.Osc.Datum {- hosc -} +import Sound.Osc.Packet {- hosc -} +import Sound.Osc.Time {- hosc -} + +-- | The plain byte count of an Osc value. +size :: DatumType -> B.ByteString -> Int +size ty b = + case ty of + 'i' -> 4 -- Int32 + 'f' -> 4 -- Float + 'd' -> 8 -- Double + 't' -> 8 -- Time (NTP) + 'm' -> 4 -- MIDI + 's' -> + int64_to_int + ( fromMaybe + (error ("size: no terminating zero: " ++ show b)) + (B.elemIndex 0 b) + ) + 'b' -> decode_i32 (B.take 4 b) + _ -> error "size: illegal type" + +-- | The storage byte count (aligned) of an Osc value. +storage :: DatumType -> B.ByteString -> Int +storage ty b = + case ty of + 's' -> let n = size 's' b + 1 in n + align n + 'b' -> let n = size 'b' b in n + align n + 4 + _ -> size ty B.empty + +-- | Decode an Osc datum +decode_datum :: DatumType -> B.ByteString -> Datum +decode_datum ty b = + case ty of + 'i' -> Int32 (decode b) + 'h' -> Int64 (decode b) + 'f' -> Float (decode_f32 b) + 'd' -> Double (decode_f64 b) + 's' -> AsciiString (decode_ascii (b_take (size 's' b) b)) + 'b' -> Blob (b_take (size 'b' b) (B.drop 4 b)) + 't' -> TimeStamp (ntpi_to_ntpr (decode_word64 b)) + 'm' -> + case B.unpack (B.take 4 b) of + [b0, b1, b2, b3] -> midi (b0, b1, b2, b3) + _ -> error "decode_datum: illegal midi data" + _ -> error ("decode_datum: illegal type (" ++ [ty] ++ ")") + +-- | Decode a sequence of Osc datum given a type descriptor string. +decode_datum_seq :: Ascii -> B.ByteString -> [Datum] +decode_datum_seq cs b = + let swap (x, y) = (y, x) + cs' = C.unpack cs + f b' c = swap (B.splitAt (int_to_int64 (storage c b')) b') + in zipWith decode_datum cs' (snd (mapAccumL f b cs')) + +-- | Decode an Osc 'Message'. +decodeMessage :: B.ByteString -> Message +decodeMessage b = + let n = storage 's' b + cmd = decode_datum 's' b + m = storage 's' (b_drop n b) + in case (cmd, decode_datum 's' (b_drop n b)) of + (AsciiString cmd', AsciiString dsc) -> + let arg = decode_datum_seq (descriptor_tags dsc) (b_drop (n + m) b) + in Message (C.unpack cmd') arg + _ -> error "decodeMessage" + +-- | Decode a sequence of length prefixed (Int32) Osc messages. +decode_message_seq :: B.ByteString -> [Message] +decode_message_seq b = + let s = decode_i32 b + m = decodeMessage (b_drop 4 b) + nxt = decode_message_seq (b_drop (4 + s) b) + in if B.length b == 0 then [] else m : nxt + +-- | Decode an Osc 'Bundle'. +decodeBundle :: B.ByteString -> BundleOf Message +decodeBundle b = + let h = storage 's' b -- header (should be '#bundle') + t = storage 't' (b_drop h b) -- time + in case decode_datum 't' (b_drop h b) of + TimeStamp timeStamp -> Bundle timeStamp (decode_message_seq (b_drop (h + t) b)) + _ -> error "decodeBundle" + +{- | Decode an Osc 'Packet'. + +>>> let b = B.pack [47,103,95,102,114,101,101,0,44,105,0,0,0,0,0,0] +>>> decodePacket b == Packet_Message (Message "/g_free" [Int32 0]) +True +-} +decodePacket :: B.ByteString -> PacketOf Message +decodePacket b = + if bundleHeader `B.isPrefixOf` b + then Packet_Bundle (decodeBundle b) + else Packet_Message (decodeMessage b) + +-- * Util + +-- | 'B.take' with 'Int' count. +b_take :: Int -> B.ByteString -> B.ByteString +b_take = B.take . int_to_int64 + +-- | 'B.drop' with 'Int' count. +b_drop :: Int -> B.ByteString -> B.ByteString +b_drop = B.drop . int_to_int64 diff --git a/Sound/Osc/Coding/Decode/Binary.hs b/Sound/Osc/Coding/Decode/Binary.hs new file mode 100644 --- /dev/null +++ b/Sound/Osc/Coding/Decode/Binary.hs @@ -0,0 +1,152 @@ +-- | Optimised decode function for Osc packets. +module Sound.Osc.Coding.Decode.Binary ( + get_packet, + decodeMessage, + decodeBundle, + decodePacket, + decodePacket_strict, + decodeMessageOr, + decodeBundleOr, + decodePacketOr, +) where + +import Control.Applicative {- base -} +import Control.Monad {- base -} +import Data.Word {- base -} + +import qualified Data.Binary.Get as Binary {- binary -} + +import qualified Data.ByteString.Char8 as ByteString.Char8 {- bytestring -} +import qualified Data.ByteString.Lazy as ByteString.Lazy {- bytestring -} +import qualified Data.ByteString.Lazy.Char8 as ByteString.Lazy.Char8 {- bytestring -} + +import qualified Sound.Osc.Coding.Byte as Byte {- hosc -} +import qualified Sound.Osc.Coding.Convert as Convert {- hosc -} +import Sound.Osc.Datum {- hosc -} +import Sound.Osc.Packet {- hosc -} +import qualified Sound.Osc.Time as Time {- hosc -} + +-- | Get an aligned Osc string. +get_string :: Binary.Get String +get_string = do + s <- Binary.getLazyByteStringNul + Binary.skip (Convert.int64_to_int (Byte.align (ByteString.Lazy.length s + 1))) + return (ByteString.Lazy.Char8.unpack s) + +-- | Get an aligned Osc string. +get_ascii :: Binary.Get Ascii +get_ascii = do + s <- Binary.getLazyByteStringNul + Binary.skip (Convert.int64_to_int (Byte.align (ByteString.Lazy.length s + 1))) + return (ByteString.Char8.pack (ByteString.Lazy.Char8.unpack s)) + +-- | Get binary data prefixed by byte count. +get_bytes :: Word32 -> Binary.Get ByteString.Lazy.ByteString +get_bytes n = do + b <- Binary.getLazyByteString (Convert.word32_to_int64 n) + if n /= Convert.int64_to_word32 (ByteString.Lazy.length b) + then fail "get_bytes: end of stream" + else Binary.skip (Convert.word32_to_int (Byte.align n)) + return b + +-- | Get an Osc datum. +get_datum :: DatumType -> Binary.Get Datum +get_datum ty = + case ty of + 'i' -> fmap Int32 Binary.getInt32be + 'h' -> fmap Int64 Binary.getInt64be + 'f' -> fmap Float Binary.getFloatbe + 'd' -> fmap Double Binary.getDoublebe + 's' -> fmap AsciiString get_ascii + 'b' -> fmap Blob (get_bytes =<< Binary.getWord32be) + 't' -> fmap (TimeStamp . Time.ntpi_to_ntpr) Binary.getWord64be + 'm' -> fmap Midi (liftM4 MidiData Binary.getWord8 Binary.getWord8 Binary.getWord8 Binary.getWord8) + _ -> fail ("get_datum: illegal type " ++ show ty) + +-- | Get an Osc 'Message', fail if type descriptor is invalid. +get_message :: Binary.Get Message +get_message = do + cmd <- get_string + dsc <- get_ascii + case ByteString.Char8.unpack dsc of + ',' : tags -> do + arg <- mapM get_datum tags + return (Message cmd arg) + e -> fail ("get_message: invalid type descriptor string: " ++ e) + +-- | Get a sequence of Osc 'Message's, each one headed by its length. +get_message_seq :: Binary.Get [Message] +get_message_seq = do + b <- Binary.isEmpty + if b + then return [] + else do + p <- flip Binary.isolate get_message . Convert.word32_to_int =<< Binary.getWord32be + ps <- get_message_seq + return (p : ps) + +-- | Get a bundle. Fail if bundle header is not found in packet. +get_bundle :: Binary.Get (BundleOf Message) +get_bundle = do + h <- Binary.getByteString (ByteString.Char8.length Byte.bundleHeader_strict) + when (h /= Byte.bundleHeader_strict) (fail "get_bundle: not a bundle") + t <- fmap Time.ntpi_to_ntpr Binary.getWord64be + fmap (Bundle t) get_message_seq + +-- | Get an Osc 'Packet'. +get_packet :: Binary.Get (PacketOf Message) +get_packet = fmap Packet_Bundle get_bundle <|> fmap Packet_Message get_message + +{-# INLINE decodeMessage #-} +{-# INLINE decodeBundle #-} +{-# INLINE decodePacket #-} +{-# INLINE decodePacket_strict #-} + +{- | Decode an Osc 'Message' from a lazy ByteString. + +>>> let b = ByteString.Lazy.pack [47,103,95,102,114,101,101,0,44,105,0,0,0,0,0,0] +>>> decodeMessage b == Message "/g_free" [Int32 0] +True +-} +decodeMessage :: ByteString.Lazy.ByteString -> Message +decodeMessage = Binary.runGet get_message + +-- | Decode an Osc 'Bundle' from a lazy ByteString. +decodeBundle :: ByteString.Lazy.ByteString -> BundleOf Message +decodeBundle = Binary.runGet get_bundle + +-- | Run decoder and report any error. +runDecoder :: Binary.Get t -> ByteString.Lazy.Char8.ByteString -> Either String t +runDecoder f p = + case Binary.runGetOrFail f p of + Left (_, _, err) -> Left err + Right (_, _, decoded) -> Right decoded + +{- | Decode an Osc packet from a lazy ByteString. + +>>> let b = ByteString.Lazy.pack [47,103,95,102,114,101,101,0,44,105,0,0,0,0,0,0] +>>> decodePacket b == Packet_Message (Message "/g_free" [Int32 0]) +True +-} +decodePacket :: ByteString.Lazy.ByteString -> PacketOf Message +decodePacket = Binary.runGet get_packet + +-- | Decode an Osc packet from a strict Char8 ByteString. +decodePacket_strict :: ByteString.Char8.ByteString -> PacketOf Message +decodePacket_strict = Binary.runGet get_packet . ByteString.Lazy.fromChunks . (: []) + +{- | Either decode Osc message or return an error message. +Prevents application halt for non-valid message/bundle/packet arrives. + +>>> let b = ByteString.Lazy.pack [1,2,3,2,1] +>>> decodePacketOr b +Left "not enough bytes" +-} +decodeMessageOr :: ByteString.Lazy.ByteString -> Either String Message +decodeMessageOr = runDecoder get_message + +decodeBundleOr :: ByteString.Lazy.ByteString -> Either String Bundle +decodeBundleOr = runDecoder get_bundle + +decodePacketOr :: ByteString.Lazy.ByteString -> Either String Packet +decodePacketOr = runDecoder get_packet diff --git a/Sound/Osc/Coding/Encode/Base.hs b/Sound/Osc/Coding/Encode/Base.hs new file mode 100644 --- /dev/null +++ b/Sound/Osc/Coding/Encode/Base.hs @@ -0,0 +1,117 @@ +{- | Base-level encode function for Osc packets (slow). + For ordinary use see 'Sound.Osc.Coding.Encode.Builder'. +-} +module Sound.Osc.Coding.Encode.Base where + +import Data.Binary {- base -} +import qualified Data.ByteString.Char8 as C {- bytestring -} +import qualified Data.ByteString.Lazy as B {- bytestring -} + +import Sound.Osc.Coding.Byte {- hosc -} +import Sound.Osc.Coding.Convert {- hosc -} +import Sound.Osc.Datum {- hosc -} +import Sound.Osc.Packet {- hosc -} +import Sound.Osc.Time {- hosc -} + +-- | Align byte string, if required. +extend :: Word8 -> B.ByteString -> B.ByteString +extend p s = B.append s (B.replicate (align (B.length s)) p) + +{- | Encode Osc 'Datum'. + +MidiData: Bytes from MSB to LSB are: port id, status byte, data1, data2. + +>>> encode_datum (blob [1, 2, 3, 4]) == B.pack [0, 0, 0, 4, 1, 2, 3, 4] +True + +>>> encode_datum (Float 1) == B.pack [63, 128, 0, 0] +True + +>>> encode_datum (Float 2) == B.pack [64, 0, 0, 0] +True + +>>> encode_datum (Float 3) == B.pack [64, 64, 0, 0] +True + +>>> encode_datum (Float 4) == B.pack [64, 128, 0, 0] +True + +>>> encode_datum (Float 5) == B.pack [64, 160, 0, 0] +True + +>>> encode_datum (Int32 65536) == B.pack [0, 1, 0, 0] +True + +>>> encode_datum (Int32 (-65536)) == B.pack [255, 255, 0, 0] +True +-} +encode_datum :: Datum -> B.ByteString +encode_datum dt = + case dt of + Int32 i -> encode i + Int64 i -> encode i + Float f -> encode_f32 f + Double d -> encode_f64 d + TimeStamp t -> encode_word64 $ ntpr_to_ntpi t + AsciiString s -> extend 0 (B.snoc (encode_ascii s) 0) + Midi (MidiData b0 b1 b2 b3) -> B.pack [b0, b1, b2, b3] + Blob b -> + let n = encode (int64_to_int32 (B.length b)) + in B.append n (extend 0 b) + +{- | Encode Osc 'Message'. + +>>> blob_unpack (encodeMessage (Message "/x" [])) +[47,120,0,0,44,0,0,0] + +>>> blob_unpack (encodeMessage (Message "/y" [float 3.141])) +[47,121,0,0,44,102,0,0,64,73,6,37] + +>>> let m = Message "/n_set" [int32 (-1), string "freq", float 440, string "amp", float 0.1] +>>> let e = blob_unpack (encodeMessage m) +>>> length e +40 + +>>> take 20 e +[47,110,95,115,101,116,0,0,44,105,115,102,115,102,0,0,255,255,255,255] +-} +encodeMessage :: Message -> B.ByteString +encodeMessage (Message c l) = + B.concat + [ encode_datum (AsciiString (C.pack c)) + , encode_datum (AsciiString (descriptor l)) + , B.concat (map encode_datum l) + ] + +-- | Encode Osc 'Message' as an Osc blob. +encode_message_blob :: Message -> Datum +encode_message_blob = Blob . encodeMessage + +{- | Encode Osc 'Bundle'. + +>>> blob_unpack (encodeBundle (Bundle immediately [Message "/x" []])) +[35,98,117,110,100,108,101,0,0,0,0,0,0,0,0,1,0,0,0,8,47,120,0,0,44,0,0,0] + +>>> let m = Message "/n_set" [int32 (-1), string "freq", float 440, string "amp", float 0.1] +>>> let b = Bundle 0.0 [m] +>>> let e = blob_unpack (encodeBundle b) +>>> length e +60 + +>> take 20 e +[35,98,117,110,100,108,101,0,0,0,0,0,0,0,0,0,0,0,0,40] +-} +encodeBundle :: BundleOf Message -> B.ByteString +encodeBundle (Bundle t m) = + B.concat + [ bundleHeader + , encode_word64 (ntpr_to_ntpi t) + , B.concat (map (encode_datum . encode_message_blob) m) + ] + +-- | Encode Osc 'Packet'. +encodePacket :: PacketOf Message -> B.ByteString +encodePacket o = + case o of + Packet_Message m -> encodeMessage m + Packet_Bundle b -> encodeBundle b diff --git a/Sound/Osc/Coding/Encode/Builder.hs b/Sound/Osc/Coding/Encode/Builder.hs new file mode 100644 --- /dev/null +++ b/Sound/Osc/Coding/Encode/Builder.hs @@ -0,0 +1,115 @@ +-- | Optimised encode function for Osc packets. +module Sound.Osc.Coding.Encode.Builder ( + build_packet, + encodeMessage, + encodeBundle, + encodePacket, + encodePacket_strict, +) where + +import Data.Word {- base -} + +import qualified Blaze.ByteString.Builder as B {- bytestring -} +import qualified Blaze.ByteString.Builder.Char8 as B {- bytestring -} +import qualified Data.ByteString as S {- bytestring -} +import qualified Data.ByteString.Lazy as L {- bytestring -} + +import qualified Sound.Osc.Coding.Byte as Byte {- hosc -} +import qualified Sound.Osc.Coding.Cast as Cast {- hosc -} +import qualified Sound.Osc.Coding.Convert as Convert {- hosc -} +import Sound.Osc.Datum {- hosc -} +import Sound.Osc.Packet {- hosc -} +import Sound.Osc.Time {- hosc -} + +-- | Generate a list of zero bytes for padding. +padding :: Int -> [Word8] +padding n = replicate n 0 + +-- | Nul byte (0) and then zero padding. +nul_and_padding :: Int -> B.Builder +nul_and_padding n = B.fromWord8s (0 : padding (Byte.align n)) + +-- Encode a string with zero padding. +build_ascii :: Ascii -> B.Builder +build_ascii s = B.fromByteString s <> nul_and_padding (S.length s + 1) + +-- Encode a string with zero padding. +build_string :: String -> B.Builder +build_string s = B.fromString s <> nul_and_padding (length s + 1) + +-- Encode a byte string with prepended length and zero padding. +build_bytes :: L.ByteString -> B.Builder +build_bytes s = + B.fromInt32be (Convert.int64_to_int32 (L.length s)) + <> B.fromLazyByteString s + <> B.fromWord8s (padding (Convert.int64_to_int (Byte.align (L.length s)))) + +-- Encode an Osc datum. +build_datum :: Datum -> B.Builder +build_datum d = + case d of + Int32 i -> B.fromInt32be i + Int64 i -> B.fromInt64be i + Float n -> B.fromWord32be (Cast.f32_w32 n) + Double n -> B.fromWord64be (Cast.f64_w64 n) + TimeStamp t -> B.fromWord64be (ntpr_to_ntpi t) + AsciiString s -> build_ascii s + Midi (MidiData b0 b1 b2 b3) -> B.fromWord8s [b0, b1, b2, b3] + Blob b -> build_bytes b + +-- Encode an Osc 'Message'. +build_message :: Message -> B.Builder +build_message (Message c l) = + mconcat + [ build_string c + , build_ascii (descriptor l) + , mconcat (map build_datum l) + ] + +-- Encode an Osc 'Bundle'. +build_bundle_ntpi :: Ntp64 -> [Message] -> B.Builder +build_bundle_ntpi t l = + mconcat + [ B.fromLazyByteString Byte.bundleHeader + , B.fromWord64be t + , mconcat (map (build_bytes . B.toLazyByteString . build_message) l) + ] + +-- | Builder for an Osc 'Packet'. +build_packet :: PacketOf Message -> B.Builder +build_packet o = + case o of + Packet_Message m -> build_message m + Packet_Bundle (Bundle t m) -> build_bundle_ntpi (ntpr_to_ntpi t) m + +{-# INLINE encodePacket #-} +{-# INLINE encodeMessage #-} +{-# INLINE encodeBundle #-} +{-# INLINE encodePacket_strict #-} + +-- | Encode an Osc 'Packet'. +encodePacket :: PacketOf Message -> L.ByteString +encodePacket = B.toLazyByteString . build_packet + +{- | Encode an Osc 'Message', ie. 'encodePacket' of 'Packet_Message'. + +>>> let m = [47,103,95,102,114,101,101,0,44,105,0,0,0,0,0,0] +>>> encodeMessage (Message "/g_free" [Int32 0]) == L.pack m +True +-} +encodeMessage :: Message -> L.ByteString +encodeMessage = encodePacket . Packet_Message + +{- | Encode an Osc 'Bundle', ie. 'encodePacket' of 'Packet_Bundle'. + +>>> let m = [47,103,95,102,114,101,101,0,44,105,0,0,0,0,0,0] +>>> let b = [35,98,117,110,100,108,101,0,0,0,0,0,0,0,0,1,0,0,0,16] ++ m +>>> encodeBundle (Bundle immediately [Message "/g_free" [Int32 0]]) == L.pack b +True +-} +encodeBundle :: BundleOf Message -> L.ByteString +encodeBundle = encodePacket . Packet_Bundle + +-- | Encode an Osc 'Packet' to a strict 'S.ByteString'. +encodePacket_strict :: PacketOf Message -> S.ByteString +encodePacket_strict = B.toByteString . build_packet diff --git a/Sound/Osc/Core.hs b/Sound/Osc/Core.hs new file mode 100644 --- /dev/null +++ b/Sound/Osc/Core.hs @@ -0,0 +1,21 @@ +{- | Composite of non-transport related modules. + +Provides the 'Datum', 'Message', 'Time', 'Bundle' and 'Packet' types +and the coding functions 'encodePacket' and 'decodePacket'. + +>>> let o = bundle immediately [message "/g_free" [Int32 0]] +>>> let e = encodeBundle o +>>> decodePacket e == Packet_Bundle o +True +-} +module Sound.Osc.Core (module M) where + +import Sound.Osc.Coding.Decode.Binary as M +import Sound.Osc.Coding.Encode.Builder as M +import Sound.Osc.Datum as M +import Sound.Osc.Packet as M +import Sound.Osc.Time as M +import Sound.Osc.Time.System as M +import Sound.Osc.Time.Thread as M +import Sound.Osc.Time.Thread.MonadIO as M +import Sound.Osc.Wait as M diff --git a/Sound/Osc/Datum.hs b/Sound/Osc/Datum.hs new file mode 100644 --- /dev/null +++ b/Sound/Osc/Datum.hs @@ -0,0 +1,264 @@ +-- | Osc data types. +module Sound.Osc.Datum where + +import Data.Int {- base -} +import Data.Maybe {- base -} +import Data.Word {- base -} + +import qualified Data.ByteString.Char8 as ByteString.Char8 {- bytestring -} +import qualified Data.ByteString.Lazy as ByteString.Lazy {- bytestring -} + +-- * Datum + +-- | Type enumerating Datum categories. +type DatumType = Char + +-- | Type for Ascii strings (strict Char8 ByteString) +type Ascii = ByteString.Char8.ByteString + +-- | Type-specialised pack. +ascii :: String -> Ascii +ascii = ByteString.Char8.pack + +-- | Type-specialised unpack. +ascii_to_string :: Ascii -> String +ascii_to_string = ByteString.Char8.unpack + +-- | Type for 'Word8' arrays, these are stored with an 'Int32' length prefix. +type Blob = ByteString.Lazy.ByteString + +-- | Type-specialised pack. +blob_pack :: [Word8] -> Blob +blob_pack = ByteString.Lazy.pack + +-- | Type-specialised pack. +blob_pack_int :: [Int] -> Blob +blob_pack_int = ByteString.Lazy.pack . map fromIntegral + +-- | Type-specialised unpack. +blob_unpack :: Blob -> [Word8] +blob_unpack = ByteString.Lazy.unpack + +-- | Type-specialised unpack. +blob_unpack_int :: Blob -> [Int] +blob_unpack_int = map fromIntegral . blob_unpack + +-- | Four-byte midi message: port-id, status-byte, data, data. +data MidiData = MidiData !Word8 !Word8 !Word8 !Word8 + deriving (Ord, Eq, Show, Read) + +midi_pack :: [Word8] -> MidiData +midi_pack w = + case w of + [m1, m2, m3, m4] -> MidiData m1 m2 m3 m4 + _ -> error "midi_pack?" + +-- | Type-specialised pack. +midi_pack_int :: [Int] -> MidiData +midi_pack_int = midi_pack . map fromIntegral + +-- | Type-specialised unpack. +midi_unpack_int :: MidiData -> [Int] +midi_unpack_int (MidiData m1 m2 m3 m4) = map fromIntegral [m1, m2, m3, m4] + +{- | A real-valued time stamp. +For Osc proper this is an Ntp64 time in real-valued (fractional) form. +For SuperCollider Nrt programs this is elapsed time since the start of the score. +This is the primary form of timestamp used by hosc. +-} +type Time = Double + +-- | The basic elements of Osc messages. +data Datum + = Int32 {d_int32 :: !Int32} + | Int64 {d_int64 :: !Int64} + | Float {d_float :: !Float} + | Double {d_double :: !Double} + | AsciiString {d_ascii_string :: !Ascii} + | Blob {d_blob :: !Blob} + | TimeStamp {d_timestamp :: !Time} -- ie. real valued Ntp + | Midi {d_midi :: !MidiData} + deriving (Ord, Eq, Read, Show) + +-- * Datum types + +-- | List of required data types (tag, name). +osc_types_required :: [(DatumType, String)] +osc_types_required = + [ ('i', "Int32") + , ('f', "Float") + , ('s', "String") -- Ascii + , ('b', "Blob") + ] + +-- | List of optional data types (tag,name). +osc_types_optional :: [(DatumType, String)] +osc_types_optional = + [ ('h', "Int64") + , ('t', "TimeStamp") + , ('d', "Double") + , -- ,('S',"Symbol") + -- ,('c',"Character") + -- ,('r',"RGBA") + ('m', "Midi") + -- ,('T',"True") + -- ,('F',"False") + -- ,('N',"Nil") + -- ,('I',"Infinitum") + -- ,('[',"Array_Begin") + -- ,(']',"Array_End") + ] + +-- | List of all data types (tag,name). +osc_types :: [(DatumType, String)] +osc_types = osc_types_required ++ osc_types_optional + +-- | Lookup name of type. +osc_type_name :: DatumType -> Maybe String +osc_type_name c = lookup c osc_types + +-- | Erroring variant. +osc_type_name_err :: DatumType -> String +osc_type_name_err = fromMaybe (error "osc_type_name") . osc_type_name + +-- | Single character identifier of an Osc datum. +datum_tag :: Datum -> DatumType +datum_tag d = + case d of + Int32 _ -> 'i' + Int64 _ -> 'h' + Float _ -> 'f' + Double _ -> 'd' + AsciiString _ -> 's' + Blob _ -> 'b' + TimeStamp _ -> 't' + Midi _ -> 'm' + +-- | Type and name of 'Datum'. +datum_type_name :: Datum -> (DatumType, String) +datum_type_name d = let c = datum_tag d in (c, osc_type_name_err c) + +-- * Generalised element access + +{- | 'Datum' as 'Integral' if Int32 or Int64. + +>>> let d = [Int32 5,Int64 5,Float 5.5,Double 5.5] +>>> map datum_integral d == [Just (5::Int),Just 5,Nothing,Nothing] +True +-} +datum_integral :: Integral i => Datum -> Maybe i +datum_integral d = + case d of + Int32 x -> Just (fromIntegral x) + Int64 x -> Just (fromIntegral x) + _ -> Nothing + +{- | 'Datum' as 'Floating' if Int32, Int64, Float, Double or TimeStamp. + +>>> let d = [Int32 5,Int64 5,Float 5,Double 5,TimeStamp 5] +>>> mapMaybe datum_floating d == replicate 5 (5::Double) +True +-} +datum_floating :: Floating n => Datum -> Maybe n +datum_floating d = + case d of + Int32 n -> Just (fromIntegral n) + Int64 n -> Just (fromIntegral n) + Float n -> Just (realToFrac n) + Double n -> Just (realToFrac n) + TimeStamp n -> Just (realToFrac n) + _ -> Nothing + +-- * Constructors + +{- | Type generalised 'Int32'. + +>>> int32 (1::Int32) == int32 (1::Integer) +True + +>>> d_int32 (int32 (maxBound::Int32)) == maxBound +True + +>>> int32 (((2::Int) ^ (64::Int))::Int) == Int32 0 +True +-} +int32 :: Integral n => n -> Datum +int32 = Int32 . fromIntegral + +{- | Type generalised Int64. + +>>> int64 (1::Int32) == int64 (1::Integer) +True + +>>> d_int64 (int64 (maxBound::Int64)) == maxBound +True +-} +int64 :: Integral n => n -> Datum +int64 = Int64 . fromIntegral + +{- | Type generalised Float. + +>>> float (1::Int) == float (1::Double) +True + +>>> floatRange (undefined::Float) +(-125,128) + +>>> isInfinite (d_float (float (encodeFloat 1 256 :: Double))) +True +-} +float :: Real n => n -> Datum +float = Float . realToFrac + +{- | Type generalised Double. + +>>> double (1::Int) == double (1::Double) +True + +>>> double (encodeFloat 1 256 :: Double) == Double 1.157920892373162e77 +True +-} +double :: Real n => n -> Datum +double = Double . realToFrac + +{- | 'AsciiString' of pack. + +>>> string "string" == AsciiString (ByteString.Char8.pack "string") +True +-} +string :: String -> Datum +string = AsciiString . ascii + +{- | Four-tuple variant of 'Midi' '.' 'MidiData'. + +>>> midi (0,0,0,0) == Midi (MidiData 0 0 0 0) +True +-} +midi :: (Word8, Word8, Word8, Word8) -> Datum +midi (p, q, r, s) = Midi (MidiData p q r s) + +-- | 'Blob' of 'blob_pack'. +blob :: [Word8] -> Datum +blob = Blob . blob_pack + +-- * Descriptor + +{- | Message argument types are given by a signature. + +>>> signatureFor [Int32 1,Float 1,string "1"] +",ifs" +-} +signatureFor :: [Datum] -> String +signatureFor = (',' :) . map datum_tag + +{- | The descriptor is an Ascii encoded signature. + +>>> descriptor [Int32 1,Float 1,string "1"] == ascii ",ifs" +True +-} +descriptor :: [Datum] -> Ascii +descriptor = ascii . signatureFor + +-- | Descriptor tags are @comma@ prefixed. +descriptor_tags :: Ascii -> Ascii +descriptor_tags = ByteString.Char8.drop 1 diff --git a/Sound/Osc/Fd.hs b/Sound/Osc/Fd.hs new file mode 100644 --- /dev/null +++ b/Sound/Osc/Fd.hs @@ -0,0 +1,6 @@ +-- | Composite of "Sound.Osc.Core" and "Sound.Osc.Transport.Fd". +module Sound.Osc.Fd (module M) where + +import Sound.Osc.Core as M +import Sound.Osc.Transport.Fd as M +import Sound.Osc.Transport.Fd.Socket as M diff --git a/Sound/Osc/Packet.hs b/Sound/Osc/Packet.hs new file mode 100644 --- /dev/null +++ b/Sound/Osc/Packet.hs @@ -0,0 +1,142 @@ +-- | Data types for Osc messages, bundles and packets. +module Sound.Osc.Packet where + +import Sound.Osc.Datum {- hosc -} + +-- * Message + +{- | Osc address pattern. This is strictly an Ascii value, however it + is very common to pattern match on addresses and matching on + Data.ByteString.Char8 requires @OverloadedStrings@. +-} +type Address_Pattern = String + +-- | An Osc message, an 'Address_Pattern' and a sequence of 'Datum'. +data Message = Message + { messageAddress :: !Address_Pattern + , messageDatum :: ![Datum] + } + deriving (Ord, Eq, Read, Show) + +{- | 'Message' constructor. It is an 'error' if the 'Address_Pattern' +doesn't conform to the Osc specification. +-} +message :: Address_Pattern -> [Datum] -> Message +message a xs = + case a of + '/' : _ -> Message a xs + _ -> error "message: ill-formed address pattern" + +messageSignature :: Message -> String +messageSignature = signatureFor . messageDatum + +messageDescriptor :: Message -> Ascii +messageDescriptor = descriptor . messageDatum + +-- * Bundle + +{- | An Osc bundle, a 'Time' and a sequence of 'Message's. +The type parameter specifies the element type. +Ordinarily this is Message, which does not allow recursion. +-} +data BundleOf t = Bundle + { bundleTime :: !Time + , bundleMessages :: ![t] + } + deriving (Eq, Read, Show) + +type Bundle = BundleOf Message + +-- | Osc 'Bundle's can be ordered (time ascending). +instance Eq t => Ord (BundleOf t) where + compare (Bundle a _) (Bundle b _) = compare a b + +-- | 'Bundle' constructor. It is an 'error' if the 'Message' list is empty. +bundle :: Time -> [t] -> BundleOf t +bundle t xs = + case xs of + [] -> error "bundle: empty?" + _ -> Bundle t xs + +-- * Packet + +-- | An Osc 'Packet' is either a 'Message' or a 'Bundle t'. +data PacketOf t + = Packet_Message {packetMessage :: !Message} + | Packet_Bundle {packetBundle :: !(BundleOf t)} + deriving (Eq, Read, Show) + +type Packet = PacketOf Message + +-- | 'Packet_Bundle' of 'bundle'. +p_bundle :: Time -> [t] -> PacketOf t +p_bundle t = Packet_Bundle . bundle t + +-- | 'Packet_Message' of 'message'. +p_message :: Address_Pattern -> [Datum] -> PacketOf t +p_message a = Packet_Message . message a + +{- | Constant indicating a bundle to be executed immediately. +It has the Ntp64 representation of @1@. + +>>> immediately == (1 / (2 ^ 32)) +True +-} +immediately :: Time +immediately = 1 / 2 ^ (32 :: Int) + +-- | The 'Time' of 'Packet', if the 'Packet' is a 'Message' this is 'immediately'. +packetTime :: PacketOf t -> Time +packetTime = at_packet (const immediately) bundleTime + +-- | Retrieve the set of 'Message's from a 'Packet'. +packetMessages :: PacketOf Message -> [Message] +packetMessages = at_packet return bundleMessages + +-- | If 'Packet' is a 'Message' add 'immediately' timestamp, else 'id'. +packet_to_bundle :: PacketOf Message -> BundleOf Message +packet_to_bundle = at_packet (\m -> Bundle immediately [m]) id + +{- | If 'Packet' is a 'Message' or a 'Bundle' with an /immediate/ time +tag and with one element, return the 'Message', else 'Nothing'. +-} +packet_to_message :: PacketOf Message -> Maybe Message +packet_to_message p = + case p of + Packet_Bundle b -> + case b of + Bundle t [m] -> if t == immediately then Just m else Nothing + _ -> Nothing + Packet_Message m -> Just m + +-- | Is 'Packet' immediate, ie. a 'Bundle' with timestamp 'immediately', or a plain Message. +packet_is_immediate :: PacketOf t -> Bool +packet_is_immediate = (== immediately) . packetTime + +-- | Variant of 'either' for 'Packet'. +at_packet :: (Message -> a) -> (BundleOf t -> a) -> PacketOf t -> a +at_packet f g p = + case p of + Packet_Message m -> f m + Packet_Bundle b -> g b + +-- * Address Query + +-- | Does 'Message' have the specified 'Address_Pattern'. +message_has_address :: Address_Pattern -> Message -> Bool +message_has_address x = (== x) . messageAddress + +{- | Do any of the 'Message's at 'Bundle Message' have the specified +'Address_Pattern'. +-} +bundle_has_address :: Address_Pattern -> BundleOf Message -> Bool +bundle_has_address x = any (message_has_address x) . bundleMessages + +{- | Does 'Packet' have the specified 'Address_Pattern', ie. +'message_has_address' or 'bundle_has_address'. +-} +packet_has_address :: Address_Pattern -> PacketOf Message -> Bool +packet_has_address x = + at_packet + (message_has_address x) + (bundle_has_address x) diff --git a/Sound/Osc/Text.hs b/Sound/Osc/Text.hs new file mode 100644 --- /dev/null +++ b/Sound/Osc/Text.hs @@ -0,0 +1,279 @@ +-- | A simple and unambigous text encoding for Osc. +module Sound.Osc.Text where + +import Control.Monad {- base -} +import Data.Char {- base -} +import Numeric {- base -} +import Text.Printf {- base -} + +import qualified Safe {- safe -} + +import qualified Text.ParserCombinators.Parsec as P {- parsec -} + +import Sound.Osc.Datum {- hosc -} +import Sound.Osc.Packet {- hosc3 -} +import qualified Sound.Osc.Time as Time {- hosc3 -} + +-- | Precision value for floating point numbers. +type FpPrecision = Maybe Int + +{- | Variant of 'showFFloat' that deletes trailing zeros. + +>>> map (showFloatWithPrecision (Just 4)) [1, 2.0, pi] +["1.0","2.0","3.1416"] +-} +showFloatWithPrecision :: RealFloat n => FpPrecision -> n -> String +showFloatWithPrecision p n = + let s = showFFloat p n "" + s' = dropWhile (== '0') (reverse s) + in case s' of + '.' : _ -> reverse ('0' : s') + _ -> reverse s' + +{- | Hex encoded byte sequence. + +>>> showBytes [0, 15, 16, 144, 255] +"000f1090ff" +-} +showBytes :: [Int] -> String +showBytes = concatMap (printf "%02x") + +{- | Escape whites space (space, tab, newline) and the escape character (backslash). + +>>> map escapeString ["str", "str ", "st r", "s\tr", "s\\tr", "\nstr"] +["str","str\\ ","st\\ r","s\\\tr","s\\\\tr","\\\nstr"] +-} +escapeString :: String -> String +escapeString txt = + case txt of + [] -> [] + c : txt' -> if c `elem` "\\\t\n " then '\\' : c : escapeString txt' else c : escapeString txt' + +{- | Printer for Datum. + +>>> let aDatumSeq = [Int32 1,Float 1.2,string "str",midi (0,0x90,0x40,0x60),blob [12,16], TimeStamp 100.0] +>>> map (showDatum (Just 5)) aDatumSeq +["1","1.2","str","00904060","0c10","429496729600"] +-} +showDatum :: FpPrecision -> Datum -> String +showDatum p d = + case d of + Int32 n -> show n + Int64 n -> show n + Float n -> showFloatWithPrecision p n + Double n -> showFloatWithPrecision p n + AsciiString s -> escapeString (ascii_to_string s) + Blob s -> showBytes (blob_unpack_int s) + TimeStamp t -> show (Time.ntpr_to_ntpi t) + Midi m -> showBytes (midi_unpack_int m) + +{- | Printer for Message. + +>>> let aMessage = Message "/addr" [Int32 1, Int64 2, Float 3, Double 4, string "five", blob [6, 7], midi (8, 9, 10, 11)] +>>> showMessage (Just 4) aMessage +"/addr ,ihfdsbm 1 2 3.0 4.0 five 0607 08090a0b" + +>>> let aMessageSeq = [Message "/c_set" [Int32 1, Float 2.3], Message "/s_new" [string "sine", Int32 (-1), Int32 1, Int32 1]] +>>> map (showMessage (Just 4)) aMessageSeq +["/c_set ,if 1 2.3","/s_new ,siii sine -1 1 1"] +-} +showMessage :: FpPrecision -> Message -> String +showMessage precision aMessage = + unwords + [ messageAddress aMessage + , messageSignature aMessage + , unwords (map (showDatum precision) (messageDatum aMessage)) + ] + +{- | Printer for Bundle + +>>> let aBundle = Bundle 1 [Message "/c_set" [Int32 1, Float 2.3, Int64 4, Double 5.6], Message "/memset" [string "addr", blob [7, 8]]] +>>> showBundle (Just 4) aBundle +"#bundle 4294967296 2 /c_set ,ifhd 1 2.3 4 5.6 /memset ,sb addr 0708" +-} +showBundle :: FpPrecision -> BundleOf Message -> String +showBundle precision aBundle = + let messages = bundleMessages aBundle + in unwords + [ "#bundle" + , show (Time.ntpr_to_ntpi (bundleTime aBundle)) + , show (length messages) + , unwords (map (showMessage precision) messages) + ] + +-- | Printer for Packet. +showPacket :: FpPrecision -> PacketOf Message -> String +showPacket precision = at_packet (showMessage precision) (showBundle precision) + +-- * Parser + +-- | A character parser with no user state. +type P a = P.GenParser Char () a + +-- | Run p then q, returning result of p. +(>>~) :: Monad m => m t -> m u -> m t +p >>~ q = p >>= \x -> q >> return x + +-- | /p/ as lexeme, i.e. consuming any trailing white space. +lexemeP :: P t -> P t +lexemeP p = p >>~ P.many P.space + +-- | Any non-space character. Allow escaped space. +stringCharP :: P Char +stringCharP = (P.char '\\' >> P.space) P.<|> P.satisfy (\c -> not (isSpace c)) + +-- | Parser for string. +stringP :: P String +stringP = lexemeP (P.many1 stringCharP) + +-- | Parser for Osc address. +oscAddressP :: P String +oscAddressP = do + forwardSlash <- P.char '/' + address <- stringP + return (forwardSlash : address) + +-- | Parser for Osc signature. +oscSignatureP :: P String +oscSignatureP = + lexemeP + ( do + comma <- P.char ',' + types <- P.many1 (P.oneOf "ifsbhtdm") -- 1.0 = ifsb 2.0 = htdm + return (comma : types) + ) + +-- | Parser for decimal digit. +digitP :: P Char +digitP = P.oneOf "0123456789" + +allowNegativeP :: Num n => P n -> P n +allowNegativeP p = do + let optionMaybe x = P.option Nothing (liftM Just x) -- hugs... + maybeNegative <- optionMaybe (P.char '-') + number <- p + return (maybe number (const (negate number)) maybeNegative) + +-- | Parser for non-negative integer. +nonNegativeIntegerP :: (Integral n, Read n) => P n +nonNegativeIntegerP = lexemeP (fmap read (P.many1 digitP)) + +-- | Parser for integer. +integerP :: (Integral n, Read n) => P n +integerP = allowNegativeP nonNegativeIntegerP + +-- | Parser for non-negative float. +nonNegativeFloatP :: (Fractional n, Read n) => P n +nonNegativeFloatP = + lexemeP + ( do + integerPart <- P.many1 digitP + _ <- P.char '.' + fractionalPart <- P.many1 digitP + return (read (concat [integerPart, ".", fractionalPart])) + ) + +-- | Parser for non-negative float. +floatP :: (Fractional n, Read n) => P n +floatP = allowNegativeP nonNegativeFloatP + +-- | Parser for hexadecimal digit. +hexdigitP :: P Char +hexdigitP = P.oneOf "0123456789abcdef" + +-- | Byte parser. +byteP :: (Integral n, Read n) => P n +byteP = do + c1 <- hexdigitP + c2 <- hexdigitP + case readHex [c1, c2] of + [(r, "")] -> return r + _ -> error "byteP?" + +-- | Byte sequence parser. +byteSeqP :: (Integral n, Read n) => P [n] +byteSeqP = lexemeP (P.many1 byteP) + +-- | Datum parser. +datumP :: Char -> P Datum +datumP typeChar = do + case typeChar of + 'i' -> fmap Int32 integerP + 'f' -> fmap Float floatP + 's' -> fmap string stringP + 'b' -> fmap blob byteSeqP + 'h' -> fmap Int64 integerP + 'd' -> fmap Double floatP + 'm' -> fmap (Midi . midi_pack) (replicateM 4 byteP) + 't' -> fmap (TimeStamp . Time.ntpi_to_ntpr) integerP + _ -> error "datumP: type?" + +-- | Message parser. +messageP :: P Message +messageP = do + address <- oscAddressP + typeSignature <- oscSignatureP + datum <- mapM datumP (Safe.tailNote "messageP" typeSignature) + return (Message address datum) + +-- | Bundle tag parser. +bundleTagP :: P String +bundleTagP = lexemeP (P.string "#bundle") + +-- | Bundle parser. +bundleP :: P (BundleOf Message) +bundleP = do + _ <- bundleTagP + timestamp <- fmap Time.ntpi_to_ntpr integerP + messageCount <- integerP + messages <- replicateM messageCount messageP + return (Bundle timestamp messages) + +-- | Packet parser. +packetP :: P (PacketOf Message) +packetP = (fmap Packet_Bundle bundleP) P.<|> (fmap Packet_Message messageP) + +-- | Run parser. +runP :: P t -> String -> t +runP p txt = + case P.parse p "" txt of + Left err -> error (show err) + Right r -> r + +{- | Run datum parser. + +>>> parseDatum 'i' "-1" == Int32 (-1) +True + +>>> parseDatum 'f' "-2.3" == Float (-2.3) +True +-} +parseDatum :: Char -> String -> Datum +parseDatum typ = runP (datumP typ) + +{- | Run message parser. + +>>> let aMessageSeq = [Message "/c_set" [Int32 1, Float 2.3, Int64 4, Double 5.6], Message "/memset" [string "addr", blob [7, 8]]] +>>> map (parseMessage . showMessage (Just 4)) aMessageSeq == aMessageSeq +True +-} +parseMessage :: String -> Message +parseMessage = runP messageP + +{- | Run bundle parser. + +>>> let aBundle = Bundle 1 [Message "/c_set" [Int32 1, Float 2.3, Int64 4, Double 5.6], Message "/memset" [string "addr", blob [7, 8]]] +>>> parseBundle (showBundle (Just 4) aBundle) == aBundle +True +-} +parseBundle :: String -> BundleOf Message +parseBundle = runP bundleP + +{- | Run packet parser. + +>>> let aPacket = Packet_Bundle (Bundle 1 [Message "/c_set" [Int32 1, Float 2.3, Int64 4, Double 5.6], Message "/memset" [string "addr", blob [7, 8]]]) +>>> parsePacket (showPacket (Just 4) aPacket) == aPacket +True +-} +parsePacket :: String -> PacketOf Message +parsePacket = runP packetP diff --git a/Sound/Osc/Time.hs b/Sound/Osc/Time.hs new file mode 100644 --- /dev/null +++ b/Sound/Osc/Time.hs @@ -0,0 +1,116 @@ +{- | Osc related timing functions. + Osc timestamps are 64-bit @Ntp@ values, . +-} +module Sound.Osc.Time where + +import Data.Word {- base -} + +import qualified Data.Time as Time {- time -} +import qualified Data.Time.Clock as Clock {- time -} +import qualified Data.Time.Clock.POSIX as Clock.Posix {- time -} + +import Sound.Osc.Coding.Convert {- hosc -} + +-- * Temporal types + +{- | Type for binary (integeral) representation of a 64-bit Ntp timestamp (ie. ntpi). + The Ntp epoch is January 1, 1900. + Ntp v4 also includes a 128-bit format, which is not used by Osc. +-} +type Ntp64 = Word64 + +-- | @Ntp@ time in real-valued (fractional) form. +type NtpReal = Double + +{- | @Unix/Posix@ time in real-valued (fractional) form. + The Unix/Posix epoch is January 1, 1970. +-} +type PosixReal = Double + +-- * Time conversion + +{- | Convert an NtpReal timestamp to an Ntp64 timestamp. + +>>> ntpr_to_ntpi 0 +0 + +> fmap ntpr_to_ntpi time +-} +ntpr_to_ntpi :: NtpReal -> Ntp64 +ntpr_to_ntpi t = round (t * (2 ^ (32 :: Int))) + +{- | Convert an 'Ntp64' timestamp to a real-valued Ntp timestamp. + +>>> ntpi_to_ntpr 0 +0.0 +-} +ntpi_to_ntpr :: Ntp64 -> NtpReal +ntpi_to_ntpr t = word64_to_double t / 2 ^ (32 :: Int) + +{- | Difference (in seconds) between /Ntp/ and /Posix/ epochs. + +>>> ntp_posix_epoch_diff / (24 * 60 * 60) +25567.0 + +>>> 25567 `div` 365 +70 +-} +ntp_posix_epoch_diff :: Num n => n +ntp_posix_epoch_diff = (70 * 365 + 17) * 24 * 60 * 60 + +-- | Convert a PosixReal timestamp to an Ntp64 timestamp. +posix_to_ntpi :: PosixReal -> Ntp64 +posix_to_ntpi t = ntpr_to_ntpi (t + ntp_posix_epoch_diff) + +-- | Convert @Unix/Posix@ to @Ntp@. +posix_to_ntpr :: Num n => n -> n +posix_to_ntpr = (+) ntp_posix_epoch_diff + +-- | Convert @Ntp@ to @Unix/Posix@. +ntpr_to_posix :: Num n => n -> n +ntpr_to_posix = (+) (negate ntp_posix_epoch_diff) + +-- | Convert 'Ntp64' to @Unix/Posix@. +ntpi_to_posix :: Ntp64 -> PosixReal +ntpi_to_posix = ntpr_to_posix . ntpi_to_ntpr + +-- | Convert 'Time' to 'Clock.Posix.POSIXTime'. +ntpr_to_posixtime :: NtpReal -> Clock.Posix.POSIXTime +ntpr_to_posixtime = realToFrac . ntpr_to_posix + +-- | Convert 'Clock.Posix.POSIXTime' to 'Time'. +posixtime_to_ntpr :: Clock.Posix.POSIXTime -> NtpReal +posixtime_to_ntpr = posix_to_ntpr . realToFrac + +-- * 'Data.Time' inter-operation. + +-- | The time at 1970-01-01:00:00:00 which is the Unix/Posix epoch. +posix_epoch :: Time.UTCTime +posix_epoch = + let d = Time.fromGregorian 1970 1 1 + s = fromInteger 0 -- Time.secondsToDiffTime + in Time.UTCTime d s + +-- | Convert 'Time.UTCTime' to @Unix/Posix@. +utc_to_posix :: Fractional n => Time.UTCTime -> n +utc_to_posix t = realToFrac (Time.diffUTCTime t posix_epoch) + +-- * Clock operations + +-- | utc_to_posix of Clock.getCurrentTime. +getCurrentTimeAsPosix :: IO PosixReal +getCurrentTimeAsPosix = fmap utc_to_posix Clock.getCurrentTime + +{- | realToFrac of Clock.Posix.getPOSIXTime + +> get_ct = getCurrentTimeAsPosix +> get_pt = getPosixTimeAsPosix +> (ct,pt) <- get_ct >>= \t0 -> get_pt >>= \t1 -> return (t0,t1) +> print (pt - ct,pt - ct < 1e-5) +-} +getPosixTimeAsPosix :: IO PosixReal +getPosixTimeAsPosix = fmap realToFrac Clock.Posix.getPOSIXTime + +-- | Read current real-valued @Ntp@ timestamp. +currentTime :: IO NtpReal +currentTime = fmap posixtime_to_ntpr Clock.Posix.getPOSIXTime diff --git a/Sound/Osc/Time/System.hs b/Sound/Osc/Time/System.hs new file mode 100644 --- /dev/null +++ b/Sound/Osc/Time/System.hs @@ -0,0 +1,25 @@ +-- | System time +module Sound.Osc.Time.System where + +import Data.Int {- base -} +import Data.Word {- base -} + +import qualified Data.Time.Clock.System as Clock.System {- time >= 1.8 -} + +import qualified Sound.Osc.Time as Time {- hosc -} + +{- | Get the system time, epoch start of 1970 UTC, leap-seconds ignored. + getSystemTime is typically much faster than getCurrentTime, however it is not available in Hugs. +-} +getSystemTimeAsNtpReal :: IO Time.NtpReal +getSystemTimeAsNtpReal = do + tm <- Clock.System.getSystemTime + return (fromIntegral (Clock.System.systemSeconds tm) + (fromIntegral (Clock.System.systemNanoseconds tm) * 1.0e-9)) + +-- | System time with fractional part in microseconds (us) instead of nanoseconds (ns). +getSystemTimeInMicroseconds :: IO (Int64, Word32) +getSystemTimeInMicroseconds = do + tm <- Clock.System.getSystemTime + let sec = Clock.System.systemSeconds tm + usec = Clock.System.systemNanoseconds tm `div` 1000 + return (sec, usec) diff --git a/Sound/Osc/Time/Thread.hs b/Sound/Osc/Time/Thread.hs new file mode 100644 --- /dev/null +++ b/Sound/Osc/Time/Thread.hs @@ -0,0 +1,39 @@ +-- | Thread operations. +module Sound.Osc.Time.Thread where + +import Control.Concurrent {- base -} +import Control.Monad {- base -} + +import qualified Sound.Osc.Time as Time {- hosc -} + +{- | The 'pauseThread' limit (in seconds). + Values larger than this require a different thread delay mechanism, see 'sleepThread'. + The value is the number of microseconds in @maxBound::Int@. +-} +pauseThreadLimit :: Fractional n => n +pauseThreadLimit = fromIntegral (maxBound :: Int) / 1e6 + +-- | Pause current thread for the indicated duration (in seconds), see 'pauseThreadLimit'. +pauseThreadFor :: RealFrac n => n -> IO () +pauseThreadFor n = when (n > 0) (threadDelay (floor (n * 1e6))) + +-- | Pause current thread until the given time, see 'pauseThreadLimit'. +pauseThreadUntilTime :: RealFrac n => n -> IO () +pauseThreadUntilTime t = pauseThreadFor . (t -) . realToFrac =<< Time.currentTime + +{- | Sleep current thread for the indicated duration (in seconds). + Divides long sleeps into parts smaller than 'pauseThreadLimit'. +-} +sleepThreadFor :: RealFrac n => n -> IO () +sleepThreadFor n = + if n >= pauseThreadLimit + then + let n' = pauseThreadLimit - 1 + in pauseThreadFor n' >> sleepThreadFor (n - n') + else pauseThreadFor n + +{- | Sleep current thread until the given time. + Divides long sleeps into parts smaller than 'pauseThreadLimit'. +-} +sleepThreadUntilTime :: RealFrac n => n -> IO () +sleepThreadUntilTime t = sleepThreadFor . (t -) . realToFrac =<< Time.currentTime diff --git a/Sound/Osc/Time/Thread/MonadIO.hs b/Sound/Osc/Time/Thread/MonadIO.hs new file mode 100644 --- /dev/null +++ b/Sound/Osc/Time/Thread/MonadIO.hs @@ -0,0 +1,25 @@ +-- | MonadIO lifted forms of Sound.Osc.Time.Thread functions +module Sound.Osc.Time.Thread.MonadIO where + +import Control.Monad.IO.Class {- base >= 4.9 -} + +import qualified Sound.Osc.Time as Time {- hosc -} +import qualified Sound.Osc.Time.Thread as Time.Thread {- hosc -} + +time :: MonadIO m => m Time.NtpReal +time = liftIO Time.currentTime + +pauseThread :: (MonadIO m, RealFrac n) => n -> m () +pauseThread = liftIO . Time.Thread.pauseThreadFor + +wait :: MonadIO m => Double -> m () +wait = pauseThread + +pauseThreadUntil :: (MonadIO m, RealFrac n) => n -> m () +pauseThreadUntil = liftIO . Time.Thread.pauseThreadUntilTime + +sleepThread :: (RealFrac n, MonadIO m) => n -> m () +sleepThread = liftIO . Time.Thread.sleepThreadFor + +sleepThreadUntil :: (RealFrac n, MonadIO m) => n -> m () +sleepThreadUntil = liftIO . Time.Thread.sleepThreadUntilTime diff --git a/Sound/Osc/Time/Timeout.hs b/Sound/Osc/Time/Timeout.hs new file mode 100644 --- /dev/null +++ b/Sound/Osc/Time/Timeout.hs @@ -0,0 +1,15 @@ +-- | Timeout, implemented independently of socket timeout setting. +module Sound.Osc.Time.Timeout where + +import System.Timeout {- base -} + +import Sound.Osc.Packet {- hsoc -} +import Sound.Osc.Transport.Fd {- hosc -} + +-- | Variant of 'timeout' where time is given in fractional seconds. +timeout_r :: Double -> IO a -> IO (Maybe a) +timeout_r = timeout . floor . (* 1000000) + +-- | Variant of 'recvPacket' that implements an /n/ second 'timeout'. +recvPacketTimeout :: Transport t => Double -> t -> IO (Maybe (PacketOf Message)) +recvPacketTimeout n fd = timeout_r n (recvPacket fd) diff --git a/Sound/Osc/Transport/Fd.hs b/Sound/Osc/Transport/Fd.hs new file mode 100644 --- /dev/null +++ b/Sound/Osc/Transport/Fd.hs @@ -0,0 +1,101 @@ +-- | An abstract transport layer with implementations for @Udp@ and @Tcp@ transport. +module Sound.Osc.Transport.Fd where + +import Control.Exception {- base -} +import Data.List {- base -} +import Data.Maybe {- base -} + +import Sound.Osc.Datum {- hosc -} +import Sound.Osc.Packet {- hosc -} +import qualified Sound.Osc.Wait as Wait {- hosc -} + +-- | Abstract over the underlying transport protocol. +class Transport t where + -- | Encode and send an Osc packet. + sendPacket :: t -> PacketOf Message -> IO () + + -- | Receive and decode an Osc packet. + recvPacket :: t -> IO (PacketOf Message) + + -- | Receive and either decode an Osc packet. + recvPacketOr :: t -> IO (Either String Packet) + + -- | Close an existing connection. + close :: t -> IO () + +-- | Bracket Osc communication. +withTransport :: Transport t => IO t -> (t -> IO a) -> IO a +withTransport u = bracket u close + +-- * Send + +-- | 'sendPacket' of 'Packet_Message'. +sendMessage :: Transport t => t -> Message -> IO () +sendMessage t = sendPacket t . Packet_Message + +-- | 'sendPacket' of 'Packet_Bundle'. +sendBundle :: Transport t => t -> BundleOf Message -> IO () +sendBundle t = sendPacket t . Packet_Bundle + +-- * Receive + +-- | Variant of 'recvPacket' that runs 'packet_to_bundle'. +recvBundle :: (Transport t) => t -> IO (BundleOf Message) +recvBundle = fmap packet_to_bundle . recvPacket + +-- | Variant of 'recvPacket' that runs 'packet_to_message'. +recvMessage :: (Transport t) => t -> IO (Maybe Message) +recvMessage = fmap packet_to_message . recvPacket + +-- | Erroring variant. +recvMessage_err :: (Transport t) => t -> IO Message +recvMessage_err = fmap (fromMaybe (error "recvMessage")) . recvMessage + +-- | Variant of 'recvPacket' that runs 'packetMessages'. +recvMessages :: (Transport t) => t -> IO [Message] +recvMessages = fmap packetMessages . recvPacket + +-- * Wait + +{- | Wait for a 'Packet' where the supplied predicate is 'True', +discarding intervening packets. +-} +waitUntil :: (Transport t) => t -> (PacketOf Message -> Bool) -> IO (PacketOf Message) +waitUntil t f = Wait.untilPredicate f (recvPacket t) + +{- | Wait for a 'Packet' where the supplied function does not give +'Nothing', discarding intervening packets. +-} +waitFor :: (Transport t) => t -> (PacketOf Message -> Maybe a) -> IO a +waitFor t f = Wait.untilMaybe f (recvPacket t) + +-- | 'waitUntil' 'packet_is_immediate'. +waitImmediate :: Transport t => t -> IO (PacketOf Message) +waitImmediate t = waitUntil t packet_is_immediate + +{- | 'waitFor' 'packet_to_message', ie. an incoming 'Message' or +immediate mode 'Bundle' with one element. +-} +waitMessage :: Transport t => t -> IO Message +waitMessage t = waitFor t packet_to_message + +{- | A 'waitFor' for variant using 'packet_has_address' to match on +the 'Address_Pattern' of incoming 'Packets'. +-} +waitAddress :: Transport t => t -> Address_Pattern -> IO (PacketOf Message) +waitAddress t s = + let f o = if packet_has_address s o then Just o else Nothing + in waitFor t f + +-- | Variant on 'waitAddress' that returns matching 'Message'. +waitReply :: Transport t => t -> Address_Pattern -> IO Message +waitReply t s = + let f = + fromMaybe (error "waitReply: message not located?") + . find (message_has_address s) + . packetMessages + in fmap f (waitAddress t s) + +-- | Variant of 'waitReply' that runs 'messageDatum'. +waitDatum :: Transport t => t -> Address_Pattern -> IO [Datum] +waitDatum t = fmap messageDatum . waitReply t diff --git a/Sound/Osc/Transport/Fd/Socket.hs b/Sound/Osc/Transport/Fd/Socket.hs new file mode 100644 --- /dev/null +++ b/Sound/Osc/Transport/Fd/Socket.hs @@ -0,0 +1,40 @@ +-- | Osc over Udp/Tcp implementation. +module Sound.Osc.Transport.Fd.Socket where + +import qualified Sound.Osc.Transport.Fd as Fd {- hosc -} +import qualified Sound.Osc.Transport.Fd.Tcp as Fd.Tcp {- hosc -} +import qualified Sound.Osc.Transport.Fd.Udp as Fd.Udp {- hosc -} + +-- | Protocol, either Udp or Tcp +data OscProtocol = Udp | Tcp + deriving (Eq, Read, Show) + +-- | Hostname +type OscHostname = String + +-- | Port number +type OscPort = Int + +-- | Socket address +type OscSocketAddress = (OscProtocol, OscHostname, OscPort) + +-- | Socket +data OscSocket = OscUdpSocket Fd.Udp.Udp | OscTcpSocket Fd.Tcp.Tcp + +-- | Open socket at address +openOscSocket :: OscSocketAddress -> IO OscSocket +openOscSocket address = + case address of + (Tcp, hostname, port) -> fmap OscTcpSocket (Fd.Tcp.openTcp hostname port) + (Udp, hostname, port) -> fmap OscUdpSocket (Fd.Udp.openUdp hostname port) + +-- | 'OscSocket' is an instance of 'Fd.Transport'. +instance Fd.Transport OscSocket where + sendPacket (OscTcpSocket fd) = Fd.Tcp.tcp_send_packet fd + sendPacket (OscUdpSocket fd) = Fd.Udp.udp_send_packet fd + recvPacket (OscTcpSocket fd) = Fd.Tcp.tcp_recv_packet fd + recvPacket (OscUdpSocket fd) = Fd.Udp.udp_recv_packet fd + recvPacketOr (OscTcpSocket fd) = Fd.Tcp.tcp_recv_packet_or fd + recvPacketOr (OscUdpSocket fd) = Fd.Udp.udp_recv_packet_or fd + close (OscTcpSocket fd) = Fd.Tcp.tcp_close fd + close (OscUdpSocket fd) = Fd.Udp.udp_close fd diff --git a/Sound/Osc/Transport/Fd/Tcp.hs b/Sound/Osc/Transport/Fd/Tcp.hs new file mode 100644 --- /dev/null +++ b/Sound/Osc/Transport/Fd/Tcp.hs @@ -0,0 +1,101 @@ +-- | Osc over Tcp implementation. +module Sound.Osc.Transport.Fd.Tcp where + +import qualified Control.Exception as Exception {- base -} +import qualified Data.ByteString.Lazy as ByteString.Lazy {- bytestring -} +import qualified Network.Socket as Socket {- network -} +import qualified System.IO as Io {- base -} + +import qualified Sound.Osc.Coding.Byte as Byte {- hosc -} +import qualified Sound.Osc.Coding.Convert as Convert {- hosc -} +import qualified Sound.Osc.Coding.Decode.Binary as Decode.Binary {- hosc -} +import qualified Sound.Osc.Coding.Encode.Builder as Encode.Builder {- hosc -} +import qualified Sound.Osc.Packet as Packet {- hosc -} +import qualified Sound.Osc.Transport.Fd as Fd {- hosc -} + +-- | The Tcp transport handle data type. +newtype Tcp = Tcp {tcpHandle :: Io.Handle} + +-- | Send data over Tcp. +tcp_send_data :: Tcp -> ByteString.Lazy.ByteString -> IO () +tcp_send_data (Tcp fd) d = do + let n = Convert.int64_to_word32 (ByteString.Lazy.length d) + ByteString.Lazy.hPut fd (ByteString.Lazy.append (Byte.encode_word32 n) d) + Io.hFlush fd + +-- | Send packet over Tcp. +tcp_send_packet :: Tcp -> Packet.PacketOf Packet.Message -> IO () +tcp_send_packet tcp p = tcp_send_data tcp (Encode.Builder.encodePacket p) + +-- | Receive packet over Tcp. +tcp_recv_packet :: Tcp -> IO (Packet.PacketOf Packet.Message) +tcp_recv_packet (Tcp fd) = do + b0 <- ByteString.Lazy.hGet fd 4 + b1 <- ByteString.Lazy.hGet fd (Convert.word32_to_int (Byte.decode_word32 b0)) + return (Decode.Binary.decodePacket b1) + +tcp_recv_packet_or :: Tcp -> IO (Either String Packet.Packet) +tcp_recv_packet_or (Tcp fd) = do + b0 <- ByteString.Lazy.hGet fd 4 + b1 <- ByteString.Lazy.hGet fd (Convert.word32_to_int (Byte.decode_word32 b0)) + return (Decode.Binary.decodePacketOr b1) + +-- | Close Tcp. +tcp_close :: Tcp -> IO () +tcp_close = Io.hClose . tcpHandle + +-- | 'Tcp' is an instance of 'Transport'. +instance Fd.Transport Tcp where + sendPacket = tcp_send_packet + recvPacket = tcp_recv_packet + recvPacketOr = tcp_recv_packet_or + close = tcp_close + +-- | Bracket Tcp communication. +with_tcp :: IO Tcp -> (Tcp -> IO t) -> IO t +with_tcp u = Exception.bracket u tcp_close + +-- | Create and initialise Tcp socket. +tcp_socket :: (Socket.Socket -> Socket.SockAddr -> IO ()) -> Maybe String -> Int -> IO Socket.Socket +tcp_socket f host port = do + fd <- Socket.socket Socket.AF_INET Socket.Stream 0 + let hints = Socket.defaultHints {Socket.addrFamily = Socket.AF_INET} -- localhost=ipv4 + i : _ <- Socket.getAddrInfo (Just hints) host (Just (show port)) + let sa = Socket.addrAddress i + _ <- f fd sa + return fd + +-- | Convert 'Socket.Socket' to 'Tcp'. +socket_to_tcp :: Socket.Socket -> IO Tcp +socket_to_tcp fd = fmap Tcp (Socket.socketToHandle fd Io.ReadWriteMode) + +-- | Create and initialise Tcp. +tcp_handle :: (Socket.Socket -> Socket.SockAddr -> IO ()) -> String -> Int -> IO Tcp +tcp_handle f host port = tcp_socket f (Just host) port >>= socket_to_tcp + +{- | Make a 'Tcp' connection. + +> import Sound.Osc.Datum +> import Sound.Osc.Time +> let t = openTcp "127.0.0.1" 57110 +> let m1 = Packet.message "/dumpOsc" [Int32 1] +> let m2 = Packet.message "/g_new" [Int32 1] +> Fd.withTransport t (\fd -> let f = Fd.sendMessage fd in f m1 >> pauseThread 0.25 >> f m2) +-} +openTcp :: String -> Int -> IO Tcp +openTcp = tcp_handle Socket.connect + +-- | 'Socket.accept' connection at /s/ and run /f/. +tcp_server_f :: Socket.Socket -> (Tcp -> IO ()) -> IO () +tcp_server_f s f = do + (fd, _) <- Socket.accept s + h <- socket_to_tcp fd + f h + +-- | A trivial 'Tcp' /Osc/ server. +tcp_server :: Int -> (Tcp -> IO ()) -> IO () +tcp_server port f = do + s <- tcp_socket Socket.bind Nothing port + Socket.listen s 1 + let repeatM_ = sequence_ . repeat + repeatM_ (tcp_server_f s f) diff --git a/Sound/Osc/Transport/Fd/Udp.hs b/Sound/Osc/Transport/Fd/Udp.hs new file mode 100644 --- /dev/null +++ b/Sound/Osc/Transport/Fd/Udp.hs @@ -0,0 +1,119 @@ +-- | Osc over Udp implementation. +module Sound.Osc.Transport.Fd.Udp where + +import Control.Exception {- base -} +import Control.Monad {- base -} +import Data.Bifunctor {- base -} + +import qualified Data.ByteString as B {- bytestring -} +import qualified Data.ByteString.Lazy as BL {- bytestring -} +import qualified Network.Socket as N {- network -} +import qualified Network.Socket.ByteString as C {- network -} + +import qualified Sound.Osc.Coding.Decode.Binary as Binary {- hosc -} +import qualified Sound.Osc.Coding.Encode.Builder as Builder {- hosc -} +import qualified Sound.Osc.Packet as Packet {- hosc -} +import qualified Sound.Osc.Transport.Fd as Fd {- hosc -} + +-- | The Udp transport handle data type. +newtype Udp = Udp {udpSocket :: N.Socket} + +-- | Return the port number associated with the Udp socket. +udpPort :: Integral n => Udp -> IO n +udpPort = fmap fromIntegral . N.socketPort . udpSocket + +-- | Send data over Udp using 'C.send'. +udp_send_data :: Udp -> B.ByteString -> IO () +udp_send_data (Udp fd) d = do + let l = B.length d + n <- C.send fd d + when (n /= l) (error (show ("udp_send_data", l, n))) + +-- | Send data over Udp using 'C.sendAll'. +udp_sendAll_data :: Udp -> B.ByteString -> IO () +udp_sendAll_data (Udp fd) = C.sendAll fd + +-- | Send packet over Udp. +udp_send_packet :: Udp -> Packet.PacketOf Packet.Message -> IO () +udp_send_packet udp = udp_sendAll_data udp . Builder.encodePacket_strict + +-- | Receive packet over Udp. +udp_recv_packet :: Udp -> IO (Packet.PacketOf Packet.Message) +udp_recv_packet (Udp fd) = fmap Binary.decodePacket_strict (C.recv fd 8192) + +udp_recv_packet_or :: Udp -> IO (Either String Packet.Packet) +udp_recv_packet_or (Udp fd) = Binary.decodePacketOr . BL.fromStrict <$> C.recv fd 8192 + +-- | Close Udp. +udp_close :: Udp -> IO () +udp_close (Udp fd) = N.close fd + +-- | 'Udp' is an instance of 'Fd.Transport'. +instance Fd.Transport Udp where + sendPacket = udp_send_packet + recvPacket = udp_recv_packet + recvPacketOr = udp_recv_packet_or + close = udp_close + +-- | Bracket Udp communication. +with_udp :: IO Udp -> (Udp -> IO t) -> IO t +with_udp u = bracket u udp_close + +-- | Create and initialise Udp socket. +udp_socket :: (N.Socket -> N.SockAddr -> IO ()) -> String -> Int -> IO Udp +udp_socket f host port = do + fd <- N.socket N.AF_INET N.Datagram 0 + let hints = N.defaultHints {N.addrFamily = N.AF_INET} -- localhost=ipv4 + i : _ <- N.getAddrInfo (Just hints) (Just host) (Just (show port)) + let sa = N.addrAddress i + f fd sa + return (Udp fd) + +-- | Set option, ie. 'N.Broadcast' or 'N.RecvTimeOut'. +set_udp_opt :: N.SocketOption -> Int -> Udp -> IO () +set_udp_opt k v (Udp s) = N.setSocketOption s k v + +-- | Get option. +get_udp_opt :: N.SocketOption -> Udp -> IO Int +get_udp_opt k (Udp s) = N.getSocketOption s k + +-- | Make a 'Udp' connection. +openUdp :: String -> Int -> IO Udp +openUdp = udp_socket N.connect + +{- | Trivial 'Udp' server socket. + +> import Control.Concurrent + +> let u0 = udpServer "127.0.0.1" 57300 +> t0 <- forkIO (Fd.withTransport u0 (\fd -> forever (Fd.recvMessage fd >>= print >> print "Received message, continuing"))) +> killThread t0 + +> let u1 = openUdp "127.0.0.1" 57300 +> Fd.withTransport u1 (\fd -> Fd.sendMessage fd (Packet.message "/n" [])) +-} +udpServer :: String -> Int -> IO Udp +udpServer = udp_socket N.bind + +-- | Variant of 'udpServer' that doesn't require the host address. +udp_server :: Int -> IO Udp +udp_server p = do + let hints = + N.defaultHints + { N.addrFamily = N.AF_INET -- localhost=ipv4 + , N.addrFlags = [N.AI_PASSIVE, N.AI_NUMERICSERV] + , N.addrSocketType = N.Datagram + } + a : _ <- N.getAddrInfo (Just hints) Nothing (Just (show p)) + s <- N.socket (N.addrFamily a) (N.addrSocketType a) (N.addrProtocol a) + N.setSocketOption s N.ReuseAddr 1 + N.bind s (N.addrAddress a) + return (Udp s) + +-- | Send to specified address using 'C.sendAllTo. +sendTo :: Udp -> Packet.PacketOf Packet.Message -> N.SockAddr -> IO () +sendTo (Udp fd) p = C.sendAllTo fd (Builder.encodePacket_strict p) + +-- | Recv variant to collect message source address. +recvFrom :: Udp -> IO (Packet.PacketOf Packet.Message, N.SockAddr) +recvFrom (Udp fd) = fmap (first Binary.decodePacket_strict) (C.recvFrom fd 8192) diff --git a/Sound/Osc/Transport/Monad.hs b/Sound/Osc/Transport/Monad.hs new file mode 100644 --- /dev/null +++ b/Sound/Osc/Transport/Monad.hs @@ -0,0 +1,128 @@ +-- | Monad class implementing an Open Sound Control transport. +module Sound.Osc.Transport.Monad where + +import Control.Monad {- base -} +import Control.Monad.IO.Class {- base -} +import Data.List {- base -} +import Data.Maybe {- base -} + +import qualified Control.Monad.Trans.Reader as R {- transformers -} + +import qualified Sound.Osc.Datum as Datum {- hosc -} +import qualified Sound.Osc.Packet as Packet {- hosc -} +import qualified Sound.Osc.Transport.Fd as Fd {- hosc -} +import qualified Sound.Osc.Wait as Wait {- hosc -} + +-- | Sender monad. +class Monad m => SendOsc m where + -- | Encode and send an Osc packet. + sendPacket :: Packet.PacketOf Packet.Message -> m () + +-- | Receiver monad. +class Monad m => RecvOsc m where + -- | Receive and decode an Osc packet. + recvPacket :: m (Packet.PacketOf Packet.Message) + +-- | 'DuplexOsc' is the union of 'SendOsc' and 'RecvOsc'. +class (SendOsc m, RecvOsc m) => DuplexOsc m + +-- | 'Transport' is 'DuplexOsc' with a 'MonadIO' constraint. +class (DuplexOsc m, MonadIO m) => Transport m + +-- | 'SendOsc' over 'ReaderT'. +instance (Fd.Transport t, MonadIO io) => SendOsc (R.ReaderT t io) where + sendPacket p = R.ReaderT (liftIO . flip Fd.sendPacket p) + +-- | 'RecvOsc' over 'ReaderT'. +instance (Fd.Transport t, MonadIO io) => RecvOsc (R.ReaderT t io) where + recvPacket = R.ReaderT (liftIO . Fd.recvPacket) + +-- | 'DuplexOsc' over 'ReaderT'. +instance (Fd.Transport t, MonadIO io) => DuplexOsc (R.ReaderT t io) + +-- | 'Transport' over 'ReaderT'. +instance (Fd.Transport t, MonadIO io) => Transport (R.ReaderT t io) + +-- | Transport connection. +type Connection t a = R.ReaderT t IO a + +-- | Bracket Open Sound Control communication. +withTransport :: Fd.Transport t => IO t -> Connection t r -> IO r +withTransport u = Fd.withTransport u . R.runReaderT + +-- | 'void' of 'withTransport'. +withTransport_ :: Fd.Transport t => IO t -> Connection t r -> IO () +withTransport_ u = void . withTransport u + +-- * Send + +-- | Type restricted synonym for 'sendOsc'. +sendMessage :: SendOsc m => Packet.Message -> m () +sendMessage = sendPacket . Packet.Packet_Message + +-- | Type restricted synonym for 'sendOsc'. +sendBundle :: SendOsc m => Packet.BundleOf Packet.Message -> m () +sendBundle = sendPacket . Packet.Packet_Bundle + +-- * Receive + +-- | Variant of 'recvPacket' that runs 'packet_to_bundle'. +recvBundle :: (RecvOsc m) => m (Packet.BundleOf Packet.Message) +recvBundle = fmap Packet.packet_to_bundle recvPacket + +-- | Variant of 'recvPacket' that runs 'packet_to_message'. +recvMessage :: (RecvOsc m) => m (Maybe Packet.Message) +recvMessage = fmap Packet.packet_to_message recvPacket + +-- | Erroring variant. +recvMessage_err :: RecvOsc m => m Packet.Message +recvMessage_err = fmap (fromMaybe (error "recvMessage")) recvMessage + +-- | Variant of 'recvPacket' that runs 'packetMessages'. +recvMessages :: (RecvOsc m) => m [Packet.Message] +recvMessages = fmap Packet.packetMessages recvPacket + +-- * Wait + +{- | Wait for a 'Packet' where the supplied predicate is 'True', +discarding intervening packets. +-} +waitUntil :: (RecvOsc m) => (Packet.PacketOf Packet.Message -> Bool) -> m (Packet.PacketOf Packet.Message) +waitUntil f = Wait.untilPredicate f recvPacket + +{- | Wait for a 'Packet' where the supplied function does not give 'Nothing', +discarding intervening packets. +-} +waitFor :: (RecvOsc m) => (Packet.PacketOf Packet.Message -> Maybe a) -> m a +waitFor f = Wait.untilMaybe f recvPacket + +-- | 'waitUntil' 'packet_is_immediate'. +waitImmediate :: RecvOsc m => m (Packet.PacketOf Packet.Message) +waitImmediate = waitUntil Packet.packet_is_immediate + +{- | 'waitFor' 'packet_to_message', +ie. an incoming 'Message' or immediate mode 'Bundle' with one element. +-} +waitMessage :: RecvOsc m => m Packet.Message +waitMessage = waitFor Packet.packet_to_message + +{- | A 'waitFor' for variant using 'packet_has_address' to match on +the 'Address_Pattern' of incoming 'Packets'. +-} +waitAddress :: RecvOsc m => Packet.Address_Pattern -> m (Packet.PacketOf Packet.Message) +waitAddress s = + let f o = if Packet.packet_has_address s o then Just o else Nothing + in waitFor f + +-- | Variant on 'waitAddress' that returns matching 'Message'. +waitReply :: RecvOsc m => Packet.Address_Pattern -> m Packet.Message +waitReply s = + let f = + fromMaybe (error "waitReply: message not located?") + . find (Packet.message_has_address s) + . Packet.packetMessages + in fmap f (waitAddress s) + +-- | Variant of 'waitReply' that runs 'messageDatum'. +waitDatum :: RecvOsc m => Packet.Address_Pattern -> m [Datum.Datum] +waitDatum = fmap Packet.messageDatum . waitReply diff --git a/Sound/Osc/Wait.hs b/Sound/Osc/Wait.hs new file mode 100644 --- /dev/null +++ b/Sound/Osc/Wait.hs @@ -0,0 +1,18 @@ +-- | Waiting (for replies). +module Sound.Osc.Wait where + +-- * Wait + +-- | Repeat action until predicate /f/ is 'True' when applied to result. +untilPredicate :: Monad m => (a -> Bool) -> m a -> m a +untilPredicate f act = + let g p = if f p then recur else return p + recur = act >>= g + in recur + +-- | Repeat action until /f/ does not give 'Nothing' when applied to result. +untilMaybe :: Monad m => (a -> Maybe b) -> m a -> m b +untilMaybe f act = + let g p = maybe recur return (f p) + recur = act >>= g + in recur diff --git a/benchmarks/Sound/OSC/NFData.hs b/benchmarks/Sound/OSC/NFData.hs deleted file mode 100644 --- a/benchmarks/Sound/OSC/NFData.hs +++ /dev/null @@ -1,26 +0,0 @@ -module Sound.OSC.NFData () where - -import Control.DeepSeq (NFData(..)) {- deepseq -} -import Sound.OSC.Type - -instance NFData Datum where - rnf (Int32 x1) = rnf x1 `seq` () - rnf (Float x1) = rnf x1 `seq` () - rnf (Double x1) = rnf x1 `seq` () - rnf (ASCII_String x1) = rnf x1 `seq` () - rnf (Blob x1) = rnf x1 `seq` () - rnf (TimeStamp x1) = rnf x1 `seq` () - rnf (Midi x1) = rnf x1 `seq` () - -instance NFData MIDI where - rnf (MIDI x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` () - -instance NFData Message where - rnf (Message x1 x2) = rnf x1 `seq` rnf x2 `seq` () - -instance NFData Bundle where - rnf (Bundle x1 x2) = rnf x1 `seq` rnf x2 `seq` () - -instance NFData Packet where - rnf (Packet_Message x1) = rnf x1 `seq` () - rnf (Packet_Bundle x1) = rnf x1 `seq` () diff --git a/benchmarks/benchmark.hs b/benchmarks/benchmark.hs deleted file mode 100644 --- a/benchmarks/benchmark.hs +++ /dev/null @@ -1,32 +0,0 @@ -import Criterion.Main {- criterion -} -import qualified Data.ByteString.Lazy as B {- bytestring -} - -import Sound.OSC -import qualified Sound.OSC.Coding.Decode.Binary as Binary -import qualified Sound.OSC.Coding.Encode.Builder as Builder -import qualified Sound.OSC.Coding.Decode.Base as Decode -import qualified Sound.OSC.Coding.Encode.Base as Encode -import Sound.OSC.NFData () - -type EncodingFunc = Bundle -> B.ByteString -type DecodingFunc = B.ByteString -> Packet - -main :: IO () -main = - defaultMain [ - bgroup "encodeOSC" [ - bench "Encode" (nf (Encode.encodeBundle :: EncodingFunc) b) - , bench "Builder" (nf (Builder.encodeBundle :: EncodingFunc) b) - ] - , bgroup "decodeOSC" [ - bench "Decode" (nf (Decode.decodePacket :: DecodingFunc) p) - , bench "Binary" (nf (Binary.decodePacket :: DecodingFunc) p) - ] - ] - where - m = Message "/fooblah" [Float 42.0 - ,Int32 16 - ,string "yeah" - ,Blob (B.pack [0..128])] - b = Bundle pi (replicate 12 m) - p = Encode.encodeBundle b diff --git a/contrib/LICENSE b/contrib/LICENSE new file mode 100644 --- /dev/null +++ b/contrib/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/hosc.cabal b/hosc.cabal --- a/hosc.cabal +++ b/hosc.cabal @@ -1,93 +1,57 @@ +Cabal-Version: 2.4 Name: hosc -Version: 0.15 +Version: 0.21.1 Synopsis: Haskell Open Sound Control -Description: @hosc@ implements a subset of the /Open Sound Control/ - byte protocol, . - . - "Sound.OSC.Core" implements the actual protocol. - . - "Sound.OSC.Transport.FD" implements a - /file descriptor/ based transport layer for @UDP@ - and @TCP@. - . - "Sound.OSC.Transport.Monad" implements a - monadic interface to the @FD@ transport layer. - . - Composite modules are at "Sound.OSC" and "Sound.OSC.FD". -License: GPL +Description: Haskell library implementing the Open Sound Control protocol +License: GPL-3.0-only +License-File: contrib/LICENSE Category: Sound -Copyright: (c) Rohan Drape, Stefan Kersten and others, 2007-2014 +Copyright: (c) Rohan Drape, Stefan Kersten and others, 2007-2024 Author: Rohan Drape, Stefan Kersten -Maintainer: rd@slavepianos.org +Maintainer: rd@rohandrape.net Stability: Experimental -Homepage: http://rd.slavepianos.org/t/hosc -Tested-With: GHC == 7.8.2 +Homepage: http://rohandrape.net/t/hosc +Tested-With: GHC == 9.10.1 Build-Type: Simple -Cabal-Version: >= 1.8 -Data-Files: README +Data-Files: README.md Library - Build-Depends: base == 4.*, - binary >= 0.7.2, + Build-Depends: base >= 4.8 && < 5, + binary >= 0.7.2, blaze-builder >= 0.3, bytestring, - data-binary-ieee754, network >= 2.3, - time, + parsec, + safe, + time >= 1.5, transformers - GHC-Options: -Wall -fwarn-tabs - Exposed-modules: Sound.OSC - Sound.OSC.Class - Sound.OSC.Coding - Sound.OSC.Coding.Byte - Sound.OSC.Coding.Cast - Sound.OSC.Coding.Decode.Base - Sound.OSC.Coding.Decode.Binary - Sound.OSC.Coding.Encode.Base - Sound.OSC.Coding.Encode.Builder - Sound.OSC.Core - Sound.OSC.Datum - Sound.OSC.FD - Sound.OSC.Normalise - Sound.OSC.Time - Sound.OSC.Transport.FD - Sound.OSC.Transport.FD.TCP - Sound.OSC.Transport.FD.UDP - Sound.OSC.Transport.Monad - Sound.OSC.Type - Sound.OSC.Wait + Default-Language:Haskell2010 + GHC-Options: -Wall -Wno-x-partial -Wno-incomplete-uni-patterns + Exposed-modules: Sound.Osc + Sound.Osc.Coding.Byte + Sound.Osc.Coding.Cast + Sound.Osc.Coding.Convert + Sound.Osc.Coding.Decode.Base + Sound.Osc.Coding.Decode.Binary + Sound.Osc.Coding.Encode.Base + Sound.Osc.Coding.Encode.Builder + Sound.Osc.Core + Sound.Osc.Datum + Sound.Osc.Fd + Sound.Osc.Packet + Sound.Osc.Text + Sound.Osc.Time + Sound.Osc.Time.System + Sound.Osc.Time.Thread + Sound.Osc.Time.Thread.MonadIO + Sound.Osc.Time.Timeout + Sound.Osc.Transport.Fd + Sound.Osc.Transport.Fd.Socket + Sound.Osc.Transport.Fd.Tcp + Sound.Osc.Transport.Fd.Udp + Sound.Osc.Transport.Monad + Sound.Osc.Wait Source-Repository head - Type: darcs - Location: http://rd.slavepianos.org/sw/hosc/ - -Benchmark hosc-benchmark - Type: exitcode-stdio-1.0 - Hs-Source-Dirs: benchmarks - Main-Is: benchmark.hs - Other-Modules: - Sound.OSC.NFData - Build-Depends: - base == 4.* - , hosc == 0.15.* - , bytestring - , criterion - , deepseq - GHC-Options: -Wall -fwarn-tabs -rtsopts -fno-warn-orphans - GHC-Prof-Options: -Wall -fwarn-tabs -rtsopts -auto-all - -Test-Suite hosc-test - Type: exitcode-stdio-1.0 - Hs-Source-Dirs: tests - Main-Is: test.hs - Other-Modules: - Sound.OSC.Arbitrary - Build-Depends: - base == 4.* - , bytestring >= 0.10 - , hosc == 0.15.* - , QuickCheck >= 2 - , test-framework >= 0.2 - , test-framework-quickcheck2 >= 0.2 - GHC-Options: -Wall -fwarn-tabs -rtsopts -fno-warn-orphans - GHC-Prof-Options: -Wall -fwarn-tabs -rtsopts -auto-all + Type: git + Location: https://gitlab.com/rd--/hosc diff --git a/tests/Sound/OSC/Arbitrary.hs b/tests/Sound/OSC/Arbitrary.hs deleted file mode 100644 --- a/tests/Sound/OSC/Arbitrary.hs +++ /dev/null @@ -1,43 +0,0 @@ -module Sound.OSC.Arbitrary () where - -import Control.Applicative {- base -} -import qualified Data.ByteString.Char8 as C {- bytestring -} -import qualified Data.ByteString.Lazy as B {- bytestring -} -import Test.QuickCheck {- QuickCheck -} - -import Sound.OSC - --- Avoid floating point representation/conversion errors -genTime :: Gen Time -genTime = ntpi_to_ntpr <$> arbitrary - -genString :: Gen String -genString = resize 128 (listOf (arbitrary `suchThat` (/= '\0'))) - -genASCII :: Gen ASCII -genASCII = fmap C.pack genString - -genMIDI :: Gen MIDI -genMIDI = do - (p,q,r,s) <- arbitrary - return (MIDI p q r s) - -instance Arbitrary Datum where - arbitrary = oneof [ - Int32 <$> arbitrary - , Float <$> realToFrac <$> (arbitrary :: Gen Float) - , Double <$> arbitrary - , ASCII_String <$> genASCII - , Blob <$> B.pack <$> resize 128 arbitrary - , TimeStamp <$> genTime - , Midi <$> genMIDI - ] - -genMessage :: Gen Message -genMessage = message <$> ("/"++) <$> genString <*> resize 32 (listOf1 arbitrary) - -instance Arbitrary Packet where - arbitrary = oneof [ - Packet_Message <$> genMessage - , p_bundle <$> genTime <*> resize 32 (listOf1 genMessage) - ] diff --git a/tests/test.hs b/tests/test.hs deleted file mode 100644 --- a/tests/test.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -import Sound.OSC.Arbitrary () -import qualified Sound.OSC.Coding.Decode.Base as DecodeBase -import qualified Sound.OSC.Coding.Encode.Base as EncodeBase -import qualified Sound.OSC.Coding.Decode.Binary as DecodeBinary -import qualified Sound.OSC.Coding.Encode.Builder as EncodeBuilder -import Sound.OSC.Type (Packet) -import Test.Framework (Test, defaultMain) -import Test.Framework.Providers.QuickCheck2 (testProperty) - -tests :: [Test] -tests = - [ testProperty "encodePacket (Builder)" $ \(osc :: Packet) -> - EncodeBuilder.encodePacket osc == EncodeBase.encodePacket osc - , testProperty "encodePacket/decodePacket" $ \(osc :: Packet) -> - DecodeBase.decodePacket (EncodeBase.encodePacket osc) == osc - , testProperty "decodePacket (Get)" $ \(osc :: Packet) -> - DecodeBinary.decodePacket (EncodeBase.encodePacket osc) == osc - ] - -main :: IO () -main = defaultMain tests