diff --git a/Help/timer.hs b/Help/timer.hs deleted file mode 100644 --- a/Help/timer.hs +++ /dev/null @@ -1,17 +0,0 @@ --- hosc does not directly support a timeout at recv, however the --- standard libraries have the 'System.Timeout.timeout' function that --- works for interupting socket reads. - -import Sound.OpenSoundControl -import qualified System.Timeout as T - -timeout :: Double -> IO a -> IO (Maybe a) -timeout t = - let i = floor (t * 1000000) - in T.timeout i - -main :: IO () -main = do - fd <- openUDP "127.0.0.1" 57110 - r <- timeout 0.5 (recv fd) - print r diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,14 +0,0 @@ -hosc - haskell open sound control - -hosc provides Sound.OpenSoundControl, a haskell -module implementing a subset of the Open Sound -Control byte protocol. - - http://slavepianos.org/rd/?t=hosc - http://haskell.org/ - http://opensoundcontrol.org/ - -(c) rohan drape and others, 2006-2010 - gpl, http://gnu.org/copyleft/ - with contributions by alex mclean - see darcs history for details 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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env runhaskell -> import Distribution.Simple -> main = defaultMain diff --git a/Sound/OpenSoundControl.hs b/Sound/OpenSoundControl.hs deleted file mode 100644 --- a/Sound/OpenSoundControl.hs +++ /dev/null @@ -1,17 +0,0 @@ --- | hosc implements a subset of the Open Sound Control byte protocol. --- The protocol is documented at . -module Sound.OpenSoundControl (module Sound.OpenSoundControl.OSC, - module Sound.OpenSoundControl.Time, - module Sound.OpenSoundControl.Cast, - module Sound.OpenSoundControl.Byte, - module Sound.OpenSoundControl.Transport, - module Sound.OpenSoundControl.Transport.UDP, - module Sound.OpenSoundControl.Transport.TCP) where - -import Sound.OpenSoundControl.OSC -import Sound.OpenSoundControl.Time -import Sound.OpenSoundControl.Cast -import Sound.OpenSoundControl.Byte -import Sound.OpenSoundControl.Transport -import Sound.OpenSoundControl.Transport.UDP -import Sound.OpenSoundControl.Transport.TCP diff --git a/Sound/OpenSoundControl/Byte.hs b/Sound/OpenSoundControl/Byte.hs deleted file mode 100644 --- a/Sound/OpenSoundControl/Byte.hs +++ /dev/null @@ -1,80 +0,0 @@ --- | Byte-level encoding and decoding functions. -module Sound.OpenSoundControl.Byte where - -import Data.Binary -import qualified Data.ByteString.Lazy as B -import Data.Char -import Data.Int -import Sound.OpenSoundControl.Cast - --- | Encode a signed 8-bit integer. -encode_i8 :: Int -> B.ByteString -encode_i8 n = encode (fromIntegral n :: Int8) - --- | Encode a signed 16-bit integer. -encode_i16 :: Int -> B.ByteString -encode_i16 n = encode (fromIntegral n :: Int16) - --- | Encode a signed 32-bit integer. -encode_i32 :: Int -> B.ByteString -encode_i32 n = encode (fromIntegral n :: Int32) - --- | Encode an unsigned 16-bit integer. -encode_u32 :: Int -> B.ByteString -encode_u32 n = encode (fromIntegral n :: Word32) - --- | Encode a signed 64-bit integer. -encode_i64 :: Integer -> B.ByteString -encode_i64 n = encode (fromIntegral n :: Int64) - --- | Encode an unsigned 64-bit integer. -encode_u64 :: Integer -> B.ByteString -encode_u64 n = encode (fromIntegral n :: Word64) - --- | Encode a 32-bit IEEE floating point number. -encode_f32 :: Double -> B.ByteString -encode_f32 = encode . f32_i32 . realToFrac - --- | Encode a 64-bit IEEE floating point number. -encode_f64 :: Double -> B.ByteString -encode_f64 = encode . f64_i64 - --- | Encode an ASCII string. -encode_str :: String -> B.ByteString -encode_str = B.pack . map (fromIntegral . ord) - --- | Decode a signed 8-bit integer. -decode_i8 :: B.ByteString -> Int -decode_i8 b = fromIntegral (decode b :: Int8) - --- | Decode a signed 16-bit integer. -decode_i16 :: B.ByteString -> Int -decode_i16 b = fromIntegral (decode b :: Int16) - --- | Decode a signed 32-bit integer. -decode_i32 :: B.ByteString -> Int -decode_i32 b = fromIntegral (decode b :: Int32) - --- | Decode an unsigned 32-bit integer. -decode_u32 :: B.ByteString -> Int -decode_u32 b = fromIntegral (decode b :: Word32) - --- | Decode a signed 64-bit integer. -decode_i64 :: B.ByteString -> Integer -decode_i64 b = fromIntegral (decode b :: Int64) - --- | Decode an unsigned 64-bit integer. -decode_u64 :: B.ByteString -> Integer -decode_u64 b = fromIntegral (decode b :: Word64) - --- | Decode a 32-bit IEEE floating point number. -decode_f32 :: B.ByteString -> Double -decode_f32 b = realToFrac (i32_f32 (decode b :: Int32)) - --- | Decode a 64-bit IEEE floating point number. -decode_f64 :: B.ByteString -> Double -decode_f64 b = i64_f64 (decode b :: Int64) - --- | Decode an ASCII string. -decode_str :: B.ByteString -> String -decode_str = map (chr . fromIntegral) . B.unpack diff --git a/Sound/OpenSoundControl/Cast.hs b/Sound/OpenSoundControl/Cast.hs deleted file mode 100644 --- a/Sound/OpenSoundControl/Cast.hs +++ /dev/null @@ -1,62 +0,0 @@ --- | Bit-level type casts and byte layout string typecasts. -module Sound.OpenSoundControl.Cast (f32_i32, i32_f32, - f64_i64, i64_f64, - str_cstr, cstr_str, - str_pstr, pstr_str) where - -import Control.Monad.ST -import Data.Array.ST -import Data.Char -import Data.Int -import Data.Word - --- | The IEEE byte representation of a float packed into an integer. -f32_i32 :: Float -> Int32 -f32_i32 d = runST ((from_array =<< castSTUArray =<< unit_array d) :: ST s Int32) - --- | Inverse of 'f32_i32'. -i32_f32 :: Int32 -> Float -i32_f32 d = runST ((from_array =<< castSTUArray =<< unit_array d) :: ST s Float) - --- | The IEEE byte representation of a double packed into an integer. -f64_i64 :: Double -> Int64 -f64_i64 d = runST ((from_array =<< castSTUArray =<< unit_array d) :: ST s Int64) - -{- -http://www.haskell.org/pipermail/haskell-cafe/2008-February/040000.html - -{-# LANGUAGE MagicHash #-} -import Data.Int -import GHC.Exts - -f64_i64 :: Double -> Int64 --ghc only -f64_i64 (D# x) = I64# (unsafeCoerce# x) --} - --- | Inverse of 'f64_i64'. -i64_f64 :: Int64 -> Double -i64_f64 d = runST ((from_array =<< castSTUArray =<< unit_array d) :: ST s Double) - --- | 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 - --- One element marray. -unit_array :: (MArray a e m) => e -> m (a Int e) -unit_array = newArray (0, 0::Int) - --- Extract first element from array. -from_array :: (MArray a e m) => a Int e -> m e -from_array = flip readArray 0 diff --git a/Sound/OpenSoundControl/Coerce.hs b/Sound/OpenSoundControl/Coerce.hs deleted file mode 100644 --- a/Sound/OpenSoundControl/Coerce.hs +++ /dev/null @@ -1,30 +0,0 @@ --- | OSC packet coercion and normalization. -module Sound.OpenSoundControl.Coerce where - -import Sound.OpenSoundControl.OSC - --- | Map a normalizing function over datum at an osc packet. -coerce :: (Datum -> Datum) -> OSC -> OSC -coerce f (Message s xs) = Message s (map f xs) -coerce f (Bundle t xs) = Bundle t (map (coerce f) xs) - --- | Coerce Float to Double. -f_to_d :: Datum -> Datum -f_to_d (Float n) = Double n -f_to_d x = x - --- | Coerce Int and Float to Double. -if_to_d :: Datum -> Datum -if_to_d (Int n) = Double (fromIntegral n) -if_to_d (Float n) = Double n -if_to_d x = x - --- | Coerce Float and Double to Int. -fd_to_i :: Datum -> Datum -fd_to_i (Float n) = Int (round n) -fd_to_i (Double n) = Int (round n) -fd_to_i x = x - --- | A normalized osc packet has only Int and Double numerical values. -normalize :: OSC -> OSC -normalize = coerce f_to_d diff --git a/Sound/OpenSoundControl/OSC.hs b/Sound/OpenSoundControl/OSC.hs deleted file mode 100644 --- a/Sound/OpenSoundControl/OSC.hs +++ /dev/null @@ -1,161 +0,0 @@ --- | Alegbraic data types for OSC packets and encode and decode --- functions. -module Sound.OpenSoundControl.OSC ( OSC(..) - , Datum(..) - , encodeOSC - , decodeOSC ) where - -import qualified Data.ByteString.Lazy as B -import Data.List -import Data.Maybe -import Data.Word -import Sound.OpenSoundControl.Time -import Sound.OpenSoundControl.Byte -import Sound.OpenSoundControl.Cast - --- | The basic elements of OSC messages. -data Datum = Int Int - | Float Double - | Double Double - | String String - | Blob [Word8] - | TimeStamp Time - deriving (Eq, Show) - --- | An OSC packet. -data OSC = Message String [Datum] - | Bundle Time [OSC] - deriving (Eq, Show) - --- | OSC bundles can be ordered (time ascending). -instance Ord OSC where - compare (Bundle a _) (Bundle b _) = compare a b - compare _ _ = EQ - --- OSC types have single character identifiers. -tag :: Datum -> Char -tag (Int _) = 'i' -tag (Float _) = 'f' -tag (Double _) = 'd' -tag (String _) = 's' -tag (Blob _) = 'b' -tag (TimeStamp _) = 't' - --- Command argument types are given by a descriptor. -descriptor :: [Datum] -> Datum -descriptor l = String (',' : map tag l) - --- The number of bytes required to align an OSC value. -align :: Int -> Int -align n = (-n) `mod` 4 - --- Align a byte string if required. -extend :: a -> [a] -> [a] -extend p s = s ++ replicate (align (length s)) p - --- Encode an OSC datum. -encode_datum :: Datum -> B.ByteString -encode_datum (Int i) = encode_i32 i -encode_datum (Float f) = encode_f32 f -encode_datum (Double d) = encode_f64 d -encode_datum (TimeStamp t) = encode_u64 $ as_ntpi t -encode_datum (String s) = B.pack (extend 0 (str_cstr s)) -encode_datum (Blob b) = B.concat [encode_i32 (length b), B.pack (extend 0 b)] - --- Encode an OSC message. -encode_message :: String -> [Datum] -> B.ByteString -encode_message c l = - B.concat [ encode_datum (String c) - , encode_datum (descriptor l) - , B.concat (map encode_datum l) ] - --- Encode an OSC packet as an OSC blob. -encode_osc_blob :: OSC -> Datum -encode_osc_blob = Blob . B.unpack . encodeOSC - --- Encode an OSC bundle. -encode_bundle_ntpi :: Integer -> [OSC] -> B.ByteString -encode_bundle_ntpi t l = - B.concat [ bundle_header - , encode_u64 t - , B.concat (map (encode_datum . encode_osc_blob) l) ] - --- | Encode an OSC packet. -encodeOSC :: OSC -> B.ByteString -encodeOSC (Message c l) = encode_message c l -encodeOSC (Bundle (NTPi t) l) = encode_bundle_ntpi t l -encodeOSC (Bundle (NTPr t) l) = encode_bundle_ntpi (ntpr_ntpi t) l -encodeOSC (Bundle (UTCr t) l) = encode_bundle_ntpi (utcr_ntpi t) l - --- The plain byte count of an OSC value. -size :: Char -> B.ByteString -> Int -size 'i' _ = 4 -size 'f' _ = 4 -size 'd' _ = 8 -size 't' _ = 8 -- timetag -size 's' b = fromIntegral (fromMaybe - (error ("size: no terminating zero: " ++ show b)) - (B.elemIndex 0 b)) -size 'b' b = decode_i32 (B.take 4 b) -size _ _ = error "size: illegal type" - --- The storage byte count of an OSC value. -storage :: Char -> B.ByteString -> Int -storage 's' b = n + align n where n = size 's' b + 1 -storage 'b' b = n + align n + 4 where n = size 'b' b -storage c _ = size c B.empty - --- Decode an OSC datum -decode_datum :: Char -> B.ByteString -> Datum -decode_datum 'i' b = Int (decode_i32 b) -decode_datum 'f' b = Float (decode_f32 b) -decode_datum 'd' b = Double (decode_f64 b) -decode_datum 's' b = String (decode_str (b_take n b)) where n = size 's' b -decode_datum 'b' b = Blob (B.unpack (b_take n (B.drop 4 b))) where n = size 'b' b -decode_datum 't' b = TimeStamp $ NTPi (decode_u64 b) -decode_datum t _ = error ("decode_datum: illegal type (" ++ [t] ++ ")") - --- Decode a sequence of OSC datum given a type descriptor string. -decode_datum_seq :: [Char] -> B.ByteString -> [Datum] -decode_datum_seq cs b = zipWith decode_datum cs (snd (mapAccumL f b cs)) - where swap (x,y) = (y,x) - f b' c = swap (B.splitAt (fromIntegral (storage c b')) b') - --- Decode an OSC message. -decode_message :: B.ByteString -> OSC -decode_message b = Message cmd arg - where n = storage 's' b - (String cmd) = decode_datum 's' b - m = storage 's' (b_drop n b) - (String dsc) = decode_datum 's' (b_drop n b) - arg = decode_datum_seq (drop 1 dsc) (b_drop (n + m) b) - --- Decode a sequence of OSC messages, each one headed by its length -decode_message_seq :: B.ByteString -> [OSC] -decode_message_seq b | B.length b == 0 = [] - | otherwise = m:nxt - where s = decode_i32 b - m = decode_message $ b_drop 4 b - nxt = decode_message_seq $ b_drop (4+s) b - -decode_bundle :: B.ByteString -> OSC -decode_bundle b = Bundle timeStamp ms - where 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 - --- | Decode an OSC packet. -decodeOSC :: B.ByteString -> OSC -decodeOSC b | bundle_header `B.isPrefixOf` b = decode_bundle b - | otherwise = decode_message 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 - -bundle_header :: B.ByteString -bundle_header = encode_datum (String "#bundle") - diff --git a/Sound/OpenSoundControl/Time.hs b/Sound/OpenSoundControl/Time.hs deleted file mode 100644 --- a/Sound/OpenSoundControl/Time.hs +++ /dev/null @@ -1,79 +0,0 @@ --- | Temporal representations and clock operations (read current time --- and pause thread). -module Sound.OpenSoundControl.Time where - -import Control.Concurrent -import Control.Monad -import qualified Data.Time as T - --- | Time is represented in either UTC or NTP form. -data Time = UTCr Double | NTPr Double | NTPi Integer - deriving (Eq, Show) - --- | Coerce to NTPi form. -as_ntpi :: Time -> Integer -as_ntpi (UTCr t) = utcr_ntpi t -as_ntpi (NTPr t) = ntpr_ntpi t -as_ntpi (NTPi t) = t - --- | Coerce to UTCr form. -as_utcr :: Time -> Double -as_utcr (UTCr t) = t -as_utcr (NTPr t) = ntpr_utcr t -as_utcr (NTPi t) = ntpi_utcr t - --- | Times can be ordered, avoid coercion if not required. -instance Ord Time where - compare (UTCr p) (UTCr q) = compare p q - compare (NTPr p) (NTPr q) = compare p q - compare (NTPi p) (NTPi q) = compare p q - compare p q = compare (as_ntpi p) (as_ntpi q) - --- | Convert a real-valued NTP timestamp to an NTP timestamp. -ntpr_ntpi :: Double -> Integer -ntpr_ntpi t = round (t * 2^(32::Int)) - --- | Convert an NTP timestamp to a real-valued NTP timestamp. -ntpi_ntpr :: Integer -> Double -ntpi_ntpr t = fromIntegral t / 2^(32::Int) - --- | Convert UTC timestamp to NTP timestamp. -utcr_ntpi :: Double -> Integer -utcr_ntpi t = ntpr_ntpi (t + secdif) - where secdif = (70 * 365 + 17) * 24 * 60 * 60 - --- | Convert NTP timestamp to UTC timestamp. -ntpr_utcr :: Double -> Double -ntpr_utcr t = t - secdif - where secdif = (70 * 365 + 17) * 24 * 60 * 60 - --- | Convert NTP timestamp to UTC timestamp. -ntpi_utcr :: Integer -> Double -ntpi_utcr = ntpr_utcr . ntpi_ntpr - --- | The time at 1970-01-01:00:00:00. -utc_base :: T.UTCTime -utc_base = T.UTCTime d s - where d = T.fromGregorian 1970 1 1 - s = T.secondsToDiffTime 0 - --- | Read current UTCr timestamp. -utcr :: IO Double -utcr = do t <- T.getCurrentTime - return (realToFrac (T.diffUTCTime t utc_base)) - --- | Read current NTP timestamp. -ntpi :: IO Integer -ntpi = liftM utcr_ntpi utcr - --- | Pause current thread for the indicated duration, given in seconds. -pauseThread :: Double -> IO () -pauseThread n = when (n > 1e-4) (threadDelay (floor (n * 1e6))) - --- | Pause current thread until the given utcr time. -pauseThreadUntil :: Double -> IO () -pauseThreadUntil t = pauseThread . (t -) =<< utcr - --- | Execute the bundle immediately. -immediately :: Time -immediately = NTPi 1 diff --git a/Sound/OpenSoundControl/Transport.hs b/Sound/OpenSoundControl/Transport.hs deleted file mode 100644 --- a/Sound/OpenSoundControl/Transport.hs +++ /dev/null @@ -1,42 +0,0 @@ --- | An abstract transport layer with implementations for UDP and TCP --- transport. -module Sound.OpenSoundControl.Transport ( Transport(..) - , withTransport - , waitFor, wait ) where - -import Control.Exception -import Sound.OpenSoundControl.OSC - --- | Abstract over the underlying transport protocol. -class Transport t where - -- | Encode and send an OSC packet. - send :: t -> OSC -> IO () - -- | Receive and decode an OSC packet. - recv :: t -> IO OSC - -- | Close an existing connection. - close :: t -> IO () - --- Does the OSC message have the specified address. -has_address :: String -> OSC -> Bool -has_address x (Message y _) = x == y -has_address _ _ = False - --- Repeat action until function does not give Nothing when applied to result. -untilM :: Monad m => (a -> Maybe b) -> m a -> m b -untilM f act = recurse - where g p = let q = f p in case q of { Nothing -> recurse - ; Just r -> return r } - recurse = act >>= g - --- | Wait for an OSC message where the supplied function does not give --- Nothing, discarding intervening messages. -waitFor :: Transport t => t -> (OSC -> Maybe a) -> IO a -waitFor t f = untilM f (recv t) - --- | A 'waitFor' for variant matching on address string of messages. -wait :: Transport t => t -> String -> IO OSC -wait t s = waitFor t (\o -> if has_address s o then Just o else Nothing) - --- | Bracket OSC communication. -withTransport :: Transport t => IO t -> (t -> IO a) -> IO a -withTransport u = bracket u close diff --git a/Sound/OpenSoundControl/Transport/TCP.hs b/Sound/OpenSoundControl/Transport/TCP.hs deleted file mode 100644 --- a/Sound/OpenSoundControl/Transport/TCP.hs +++ /dev/null @@ -1,38 +0,0 @@ --- | OSC over TCP implementation. -module Sound.OpenSoundControl.Transport.TCP (TCP, openTCP, tcpServer) where - -import qualified Data.ByteString.Lazy as B -import Control.Monad -import Network -import Sound.OpenSoundControl.Transport -import Sound.OpenSoundControl.Byte -import Sound.OpenSoundControl.OSC -import System.IO - --- | The TCP transport handle data type. -data TCP = TCP Handle deriving (Eq, Show) - -instance Transport TCP where - send (TCP fd) msg = - do let b = encodeOSC msg - n = fromIntegral (B.length b) - B.hPut fd (B.append (encode_u32 n) b) - hFlush fd - - recv (TCP fd) = - do b0 <- B.hGet fd 4 - b1 <- B.hGet fd (fromIntegral (decode_u32 b0)) - return (decodeOSC 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/OpenSoundControl/Transport/UDP.hs b/Sound/OpenSoundControl/Transport/UDP.hs deleted file mode 100644 --- a/Sound/OpenSoundControl/Transport/UDP.hs +++ /dev/null @@ -1,52 +0,0 @@ --- | OSC over UDP implementation. -module Sound.OpenSoundControl.Transport.UDP ( UDP(udpSocket) - , openUDP - , udpServer - , udpPort - , sendTo, recvFrom ) where - -import Control.Monad -import qualified Network.Socket as N -import Sound.OpenSoundControl.Byte -import Sound.OpenSoundControl.OSC -import Sound.OpenSoundControl.Transport - --- | The UDP transport handle data type. -data UDP = UDP { udpSocket :: N.Socket } - deriving (Eq, Show) - -instance Transport UDP where - send (UDP fd) msg = N.send fd (decode_str (encodeOSC msg)) >> return () - recv (UDP fd) = liftM (decodeOSC . encode_str) (N.recv fd 8192) - close (UDP fd) = N.sClose fd - --- | Make a UDP connection. -openUDP :: String -> Int -> IO UDP -openUDP host port = do fd <- N.socket N.AF_INET N.Datagram 0 - a <- N.inet_addr host - let sa = N.SockAddrInet (fromIntegral port) a - N.connect fd sa - -- N.setSocketOption fd N.RecvTimeOut 1000 - return (UDP fd) - --- | Trivial udp server. -udpServer :: String -> Int -> IO UDP -udpServer host port = do fd <- N.socket N.AF_INET N.Datagram 0 - a <- N.inet_addr host - let sa = N.SockAddrInet (fromIntegral port) a - N.bindSocket fd sa - return (UDP fd) - -sendTo :: UDP -> OSC -> N.SockAddr -> IO () -sendTo (UDP fd) o a = - do N.sendTo fd (decode_str (encodeOSC o)) a - return () - -recvFrom :: UDP -> IO (OSC, N.SockAddr) -recvFrom (UDP fd) = - do (s, _, a) <- N.recvFrom fd 8192 - let o = (decodeOSC . encode_str) s - return (o, a) - -udpPort :: Integral n => UDP -> IO n -udpPort (UDP fd) = fmap fromIntegral (N.socketPort fd) 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/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,40 +1,57 @@ +Cabal-Version: 2.4 Name: hosc -Version: 0.8 +Version: 0.21.1 Synopsis: Haskell Open Sound Control -Description: hosc provides Sound.OpenSoundControl, a haskell - module implementing a subset of the Open Sound - Control byte protocol. -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, 2006-2010 -Author: Rohan Drape -Maintainer: rd@slavepianos.org +Copyright: (c) Rohan Drape, Stefan Kersten and others, 2007-2024 +Author: Rohan Drape, Stefan Kersten +Maintainer: rd@rohandrape.net Stability: Experimental -Homepage: http://slavepianos.org/rd/?t=hosc -Tested-With: GHC == 6.10.3 +Homepage: http://rohandrape.net/t/hosc +Tested-With: GHC == 9.10.1 Build-Type: Simple -Cabal-Version: >= 1.6 -Data-Files: README - Help/timer.hs +Data-Files: README.md Library - Build-Depends: array, - base == 4.*, + Build-Depends: base >= 4.8 && < 5, + binary >= 0.7.2, + blaze-builder >= 0.3, bytestring, - binary, - network, - time - GHC-Options: -Wall -fwarn-tabs - Exposed-modules: Sound.OpenSoundControl - Sound.OpenSoundControl.Byte - Sound.OpenSoundControl.Cast - Sound.OpenSoundControl.Coerce - Sound.OpenSoundControl.OSC - Sound.OpenSoundControl.Time - Sound.OpenSoundControl.Transport - Sound.OpenSoundControl.Transport.TCP - Sound.OpenSoundControl.Transport.UDP + network >= 2.3, + parsec, + safe, + time >= 1.5, + transformers + 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://slavepianos.org/~rd/sw/hosc/ + Type: git + Location: https://gitlab.com/rd--/hosc