packages feed

hosc (empty) → 0.1

raw patch · 10 files changed

+403/−0 lines, 10 filesdep +arraydep +basedep +binarybuild-type:Customsetup-changed

Dependencies added: array, base, binary, bytestring, network, time

Files

+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ Sound/OpenSoundControl.hs view
@@ -0,0 +1,15 @@+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
+ Sound/OpenSoundControl/Byte.hs view
@@ -0,0 +1,61 @@+module Sound.OpenSoundControl.Byte where++import Data.Int+import Data.Char+import qualified Data.ByteString.Lazy as B+import Data.Binary+import Sound.OpenSoundControl.Cast (f32_i32, f64_i64, i32_f32, i64_f64)++encode_i8 :: Int -> B.ByteString+encode_i8 n = encode (fromIntegral n :: Int8)++encode_i16 :: Int -> B.ByteString+encode_i16 n = encode (fromIntegral n :: Int16)++encode_i32 :: Int -> B.ByteString+encode_i32 n = encode (fromIntegral n :: Int32)++encode_u32 :: Int -> B.ByteString+encode_u32 n = encode (fromIntegral n :: Word32)++encode_i64 :: Integer -> B.ByteString+encode_i64 n = encode (fromIntegral n :: Int64)++encode_u64 :: Integer -> B.ByteString+encode_u64 n = encode (fromIntegral n :: Word64)++encode_f32 :: Double -> B.ByteString+encode_f32 n = encode (f32_i32 (realToFrac n))++encode_f64 :: Double -> B.ByteString+encode_f64 n = encode (f64_i64 n)++encode_str :: String -> B.ByteString+encode_str s = B.pack (map (fromIntegral . ord) s)++decode_i8 :: B.ByteString -> Int+decode_i8 b = fromIntegral (decode b :: Int8)++decode_i16 :: B.ByteString -> Int+decode_i16 b = fromIntegral (decode b :: Int16)++decode_i32 :: B.ByteString -> Int+decode_i32 b = fromIntegral (decode b :: Int32)++decode_u32 :: B.ByteString -> Int+decode_u32 b = fromIntegral (decode b :: Word32)++decode_i64 :: B.ByteString -> Integer+decode_i64 b = fromIntegral (decode b :: Int64)++decode_u64 :: B.ByteString -> Integer+decode_u64 b = fromIntegral (decode b :: Word64)++decode_f32 :: B.ByteString -> Double+decode_f32 b = realToFrac (i32_f32 (decode b :: Int32))++decode_f64 :: B.ByteString -> Double+decode_f64 b = i64_f64 (decode b :: Int64)++decode_str :: B.ByteString -> String+decode_str b = map (chr . fromIntegral) (B.unpack b)
+ Sound/OpenSoundControl/Cast.hs view
@@ -0,0 +1,42 @@+module Sound.OpenSoundControl.Cast (f32_i32, i32_f32,+                                    f64_i64, i64_f64,+                                    str_cstr, cstr_str,+                                    str_pstr, pstr_str) where++import Data.Word (Word8)+import Data.Int (Int32, Int64)+import Data.Char (chr, ord)+import Control.Monad.ST (runST, ST)+import Data.Array.ST (MArray, newArray, readArray, castSTUArray)++f32_i32 :: Float -> Int32+f32_i32 d = runST ((fromArray =<< castSTUArray =<< singletonArray d) :: ST s Int32)++f64_i64 :: Double -> Int64+f64_i64 d = runST ((fromArray =<< castSTUArray =<< singletonArray d) :: ST s Int64)++i32_f32 :: Int32 -> Float+i32_f32 d = runST ((fromArray =<< castSTUArray =<< singletonArray d) :: ST s Float)++i64_f64 :: Int64 -> Double+i64_f64 d = runST ((fromArray =<< castSTUArray =<< singletonArray d) :: ST s Double)++-- | C strings are null suffixed byte strings.+str_cstr :: String -> [Word8]+str_cstr s = map (fromIntegral . ord) s ++ [0]++cstr_str :: [Word8] -> String+cstr_str s = map (chr . fromIntegral) (takeWhile (/= 0) s)++-- | Pascal strings are length prefixed byte strings.+str_pstr :: String -> [Word8]+str_pstr s = (fromIntegral (length s)) : map (fromIntegral . ord) s++pstr_str :: [Word8] -> String+pstr_str s = map (chr . fromIntegral) (drop 1 s)++singletonArray :: (MArray a e m) => e -> m (a Int e)+singletonArray = newArray (0, 0::Int)++fromArray :: (MArray a e m) => a Int e -> m e+fromArray = flip readArray 0
+ Sound/OpenSoundControl/OSC.hs view
@@ -0,0 +1,125 @@+module Sound.OpenSoundControl.OSC ( OSC(..)+                                  , Datum(..)+                                  , encodeOSC+                                  , encodeOSC_NTP+                                  , decodeOSC ) where++import Sound.OpenSoundControl.Time (ntpr_ntp)+import Sound.OpenSoundControl.Byte+import Sound.OpenSoundControl.Cast (str_cstr)++import Data.Word (Word8)+import Data.List (mapAccumL)+import Data.Maybe (fromMaybe)+import qualified Data.ByteString.Lazy as B++-- | The basic elements of OSC messages.+data Datum = Int Int+           | Float Double+           | Double Double+           | String String+           | Blob [Word8]+             deriving (Eq, Show)++-- | An OSC packet.+data OSC = Message String [Datum]+         | Bundle Double [OSC]+           deriving (Eq, Show)++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'++-- | 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 = mod (-n) 4++-- | Align a byte string if required.+extend :: a -> [a] -> [a]+extend p s = s ++ replicate (align (length s)) p++-- | Encode an OSC datum.+encodeDatum :: Datum -> B.ByteString+encodeDatum (Int i)    = encode_i32 i+encodeDatum (Float f)  = encode_f32 f+encodeDatum (Double d) = encode_f64 d+encodeDatum (String s) = B.pack (extend 0 (str_cstr s))+encodeDatum (Blob b)   = B.concat [encode_i32 (length b), B.pack (extend 0 b)]++-- | Encode an OSC packet (NTP epoch).+encodeOSC_NTP :: OSC -> B.ByteString+encodeOSC_NTP (Message c l) = B.concat [ encodeDatum (String c)+                                       , encodeDatum (descriptor l)+                                       , B.concat (map encodeDatum l) ]+encodeOSC_NTP (Bundle t l) = B.concat [ encodeDatum (String "#bundle")+                                      , encode_u64 (ntpr_ntp t)+                                      , B.concat (map f l) ]+    where f = encodeDatum . Blob . B.unpack . encodeOSC++-- | Encode an OSC packet.+encodeOSC :: OSC -> B.ByteString+encodeOSC (Message c l) = encodeOSC_NTP (Message c l)+encodeOSC (Bundle t l) = encodeOSC_NTP (Bundle (t + n) l) +    where n = (70 * 365 + 17) * 24 * 60 * 60++-- | The plain byte count of an OSC value.+size :: Char -> B.ByteString -> Int+size 'i' _ = 4+size 'f' _ = 4+size 'd' _ = 8+size 's' b = fromIntegral (fromMaybe +                           (error ("no terminating zero found in " ++ show b))+                           (B.elemIndex 0 b))+size 'b' b = decode_i32 (B.take 4 b)+size _   _ = error "illegal osc 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++decodeDatum :: Char -> B.ByteString -> Datum+decodeDatum 'i' b = Int (decode_i32 b)+decodeDatum 'f' b = Float (decode_f32 b)+decodeDatum 'd' b = Double (decode_f64 b)+decodeDatum 's' b = String (decode_str (take' n b)) where n = size 's' b+decodeDatum 'b' b = Blob (B.unpack (take' n (B.drop 4 b))) where n = size 'b' b+decodeDatum _   _ = error "illegal osc type"++-- | Trivial utility.+swap :: (a,b) -> (b,a)+swap (x,y) = (y,x)++-- | Decode data given a type descriptor string.+decodeData :: [Char] -> B.ByteString -> [Datum]+decodeData cs b =+   zipWith decodeDatum cs $ snd $+   mapAccumL (\bRest c -> swap (B.splitAt (fromIntegral (storage c bRest)) bRest)) b cs++-- | Decode an OSC packet.+decodeOSC :: B.ByteString -> OSC+decodeOSC b = Message cmd arg+    where n            = storage 's' b+          (String cmd) = decodeDatum 's' b+          m            = storage 's' (drop' n b)+          (String dsc) = decodeDatum 's' (drop' n b)+          arg          = decodeData (drop 1 dsc) (drop' (n + m) b)++take' :: Int -> B.ByteString -> B.ByteString+take' n b = B.take (fromIntegral n) b++drop' :: Int -> B.ByteString -> B.ByteString+drop' n b = B.drop (fromIntegral n) b
+ Sound/OpenSoundControl/Time.hs view
@@ -0,0 +1,39 @@+module Sound.OpenSoundControl.Time ( UTC+                                   , utc+                                   , NTP+                                   , ntp+                                   , ntpr_ntp+                                   , utc_ntp ) where++import qualified Data.Time as T+import Control.Monad (liftM)++-- | UTC time is represented as a real number.+type UTC = Double++-- | NTP time is represented as an integer.+type NTP = Integer++-- | Convert a real-valued NTP timestamp to an NTP timestamp.+ntpr_ntp :: Double -> NTP+ntpr_ntp t = round (t * 2^(32::Int))++-- | Convert UTC timestamp to NTP timestamp.+utc_ntp :: UTC -> NTP+utc_ntp t = ntpr_ntp (t + secdif)+    where secdif = (70 * 365 + 17) * 24 * 60 * 60++-- | 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 UTC timestamp.+utc :: IO UTC+utc = do t <- T.getCurrentTime+         return (realToFrac (T.diffUTCTime t utc_base))++-- | Read current NTP timestamp.+ntp :: IO NTP+ntp = liftM utc_ntp utc
+ Sound/OpenSoundControl/Transport.hs view
@@ -0,0 +1,34 @@+module Sound.OpenSoundControl.Transport ( Transport(..)+                                        , withTransport+                                        , wait ) where++import Sound.OpenSoundControl.OSC (OSC(..))+import Control.Exception (bracket)++-- | 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.+hasAddress :: String -> OSC -> Bool+hasAddress addr (Message s _) = s == addr+hasAddress _    (Bundle _ _)  = False++-- | Repeat action until predicate holds on result.+untilM :: Monad m => (a -> Bool) -> m a -> m a+untilM p act = recurse+    where recurse = act >>= (\r -> if p r then return r else recurse)++-- | Wait for an OSC message with the specified address, +--   discarding intervening messages.+wait :: Transport t => t -> String -> IO OSC+wait t s = untilM (hasAddress s) (recv t)++-- | Bracket OSC communication.+withTransport :: Transport t => IO t -> (t -> IO a) -> IO a+withTransport u = bracket u close
+ Sound/OpenSoundControl/Transport/TCP.hs view
@@ -0,0 +1,38 @@+module Sound.OpenSoundControl.Transport.TCP (TCP, openTCP, tcpServer) where++import Sound.OpenSoundControl.Transport+import Sound.OpenSoundControl.Byte (encode_u32, decode_u32)+import Sound.OpenSoundControl.OSC (encodeOSC, decodeOSC)++import Control.Monad (liftM)+import qualified Data.ByteString.Lazy as B+import Network (PortID(PortNumber), connectTo, listenOn, accept)+import System.IO (Handle, hFlush, hClose)++-- | 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 port = liftM TCP (connectTo host (PortNumber (fromIntegral port)))++-- | 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 ())
+ Sound/OpenSoundControl/Transport/UDP.hs view
@@ -0,0 +1,24 @@+module Sound.OpenSoundControl.Transport.UDP (UDP, openUDP) where++import Sound.OpenSoundControl.Transport+import Sound.OpenSoundControl.Byte (encode_str, decode_str)+import Sound.OpenSoundControl.OSC (encodeOSC, decodeOSC)++import Control.Monad (liftM)+import qualified Network.Socket as N++-- | The UDP transport handle data type.+data UDP = UDP 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+                       N.connect fd (N.SockAddrInet (fromIntegral port) a)+                       -- N.setSocketOption fd N.RecvTimeOut 1000+                       return (UDP fd)
+ hosc.cabal view
@@ -0,0 +1,22 @@+Name:             hosc+Version:          0.1+License:          GPL+Copyright:        Rohan Drape, 2006-2007+Author:           Rohan Drape+Maintainer:       rd@slavepianos.org+Stability:        Experimental+Homepage:         http://slavepianos.org/rd/f/269573/+Synopsis:         Haskell Open Sound Control+Description:      Haskell implementation of the Open Sound Control byte protocol+Category:         Sound+Tested-With:      GHC+Build-Depends:    array, base, bytestring, binary, network, time+GHC-Options:      -Wall -O2+Exposed-modules:  Sound.OpenSoundControl+                  Sound.OpenSoundControl.OSC+                  Sound.OpenSoundControl.Time+                  Sound.OpenSoundControl.Cast+                  Sound.OpenSoundControl.Byte+                  Sound.OpenSoundControl.Transport+                  Sound.OpenSoundControl.Transport.TCP+                  Sound.OpenSoundControl.Transport.UDP