module Monky.Alsa
( VOLHandle
, destroyVOLHandle
, getMute
, getVolumeRaw
, getVolumePercent
, updateVOLH
, getVOLHandle
, isLoaded
, getPollFDs
)
where
import Control.Monad.Trans
import Control.Monad.Trans.Except
import Data.IORef
import Foreign.C.String (CString, withCString)
import Foreign.C.Types (CInt(..), CShort, CLong)
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.Ptr
import Foreign.Storable
import Monky.Template
import System.Posix.Types
data PollFD = POLLFD CInt CShort CShort
instance Storable PollFD where
sizeOf _ = (8)
alignment _ = alignment (undefined :: CLong)
peek p = do
fd <- (\hsc_ptr -> peekByteOff hsc_ptr 0) p
events <- (\hsc_ptr -> peekByteOff hsc_ptr 4) p
revents <- (\hsc_ptr -> peekByteOff hsc_ptr 6) p
return (POLLFD fd events revents)
poke p (POLLFD fd events revents) = do
(\hsc_ptr -> pokeByteOff hsc_ptr 0) p fd
(\hsc_ptr -> pokeByteOff hsc_ptr 4) p events
(\hsc_ptr -> pokeByteOff hsc_ptr 6) p revents
type PollFDPtr = Ptr PollFD
liftExceptT :: ((a -> m (Either e b)) -> m (Either e b)) -> (a -> ExceptT e m b) -> ExceptT e m b
liftExceptT g f = ExceptT (g (runExceptT . f))
data RegOpt
data MClass
data Mixer
type MixerHandle = Ptr Mixer
type MixerHandleAlloc = Ptr MixerHandle
data Sid
type SidHandle = Ptr Sid
type SidHandleAlloc = Ptr SidHandle
data Elem
type ElemHandle = Ptr Elem
importLib "LibAlsa" "libasound.so.2"
[ ("mixer_open", "snd_mixer_open", "MixerHandleAlloc -> Int -> IO CInt")
, ("mixer_attach", "snd_mixer_attach", "MixerHandle -> CString -> IO CInt")
, ("mixer_register", "snd_mixer_selem_register", "MixerHandle -> Ptr RegOpt -> Ptr MClass -> IO CInt")
, ("mixer_load", "snd_mixer_load", "MixerHandle -> IO CInt")
, ("sid_sindex", "snd_mixer_selem_id_set_index", "SidHandle -> CInt -> IO ()")
, ("sid_sname", "snd_mixer_selem_id_set_name", "SidHandle -> CString -> IO ()")
, ("sid_alloc", "snd_mixer_selem_id_malloc", "SidHandleAlloc -> IO CInt")
, ("sid_free", "snd_mixer_selem_id_free", "SidHandle -> IO ()")
, ("elem_gvrange", "snd_mixer_selem_get_playback_volume_range", "ElemHandle -> Ptr CInt -> Ptr CInt -> IO CInt")
, ("elem_gvol", "snd_mixer_selem_get_playback_volume", "ElemHandle -> CInt -> Ptr CInt -> IO CInt")
, ("elem_gmute", "snd_mixer_selem_get_playback_switch", "ElemHandle -> CInt -> Ptr CInt -> IO CInt")
, ("elem_find", "snd_mixer_find_selem", "MixerHandle -> SidHandle -> IO ElemHandle")
, ("mixer_handle_events", "snd_mixer_handle_events", "MixerHandle -> IO ()")
, ("get_pdescs", "snd_mixer_poll_descriptors", "MixerHandle -> PollFDPtr -> CInt -> IO CInt")
, ("get_pdescc", "snd_mixer_poll_descriptors_count", "MixerHandle -> IO CInt")
, ("mixer_close", "snd_mixer_close", "MixerHandle -> IO Int")
]
getPollDescs :: MixerHandle -> LibAlsa -> IO [CInt]
getPollDescs h l = do
count <- get_pdescc l h
allocaArray (fromIntegral count) $ \ptr -> do
c2 <- get_pdescs l h ptr count
if count == c2
then map (\(POLLFD fd _ _) -> fd) <$> (peekArray (fromIntegral c2) ptr)
else error "libalsa returned more (or less) fds than it adveritses!"
openMixer :: LibAlsa -> ExceptT Int IO MixerHandle
openMixer l = liftExceptT alloca $ \ptr -> do
rval <- liftIO (mixer_open l ptr 0)
if rval < 0
then throwE $ fromIntegral rval
else liftIO (peek ptr)
mixerAttach :: MixerHandle -> String -> LibAlsa -> ExceptT Int IO ()
mixerAttach handle card l = do
rval <- liftIO (withCString card $ mixer_attach l handle)
if rval < 0
then throwE $ fromIntegral rval
else liftIO (return ())
mixerRegister :: MixerHandle -> LibAlsa -> ExceptT Int IO ()
mixerRegister handle l = do
rval <- liftIO (mixer_register l handle nullPtr nullPtr)
if rval < 0
then throwE $ fromIntegral rval
else liftIO (return ())
mixerLoad :: MixerHandle -> LibAlsa -> ExceptT Int IO ()
mixerLoad handle l = do
rval <- liftIO (mixer_load l handle)
if rval < 0
then throwE $ fromIntegral rval
else liftIO (return ())
withSid :: LibAlsa -> (SidHandle -> IO a) -> IO a
withSid l fun = alloca $ \ptr -> do
rval <- sid_alloc l ptr
if rval < 0
then error "Failed to allocate sid"
else do
handle <- peek ptr
comp <- fun handle
sid_free l handle
return comp
sidSet :: SidHandle -> Int -> String -> LibAlsa -> IO ()
sidSet handle index name l = do
withCString name $ sid_sname l handle
sid_sindex l handle $ fromIntegral index
getElem :: MixerHandle -> String -> Int -> LibAlsa -> IO ElemHandle
getElem handle name index l = withSid l $ \sid -> do
sidSet sid index name l
elem_find l handle sid
isMute :: ElemHandle -> LibAlsa -> IO Bool
isMute handle l = alloca $ \ptr -> do
_ <- elem_gmute l handle 0 ptr
val <- peek ptr
return $ val == 0
getVolumeRange :: ElemHandle -> LibAlsa -> IO (Int, Int)
getVolumeRange handle l = alloca $ \lower -> alloca $ \upper -> do
_ <- elem_gvrange l handle lower upper
lowerv <- peek lower
upperv <- peek upper
return (fromIntegral lowerv, fromIntegral upperv)
getVolume :: ElemHandle -> LibAlsa -> IO Int
getVolume handle l = alloca $ \ptr -> do
_ <- elem_gvol l handle 0 ptr
val <- peek ptr
return $ fromIntegral val
getMixerHandle :: String -> LibAlsa -> ExceptT Int IO MixerHandle
getMixerHandle card l = do
handle <- openMixer l
mixerAttach handle card l
mixerRegister handle l
mixerLoad handle l
return handle
percentize :: Int -> Int -> Int -> Int
percentize val lower upper = 100 * (val lower) `div` (upperlower)
data VOLHandle = VOLH LibAlsa MixerHandle ElemHandle (IORef Int) (IORef Bool) Int Int | Err
updateVOLH :: VOLHandle -> IO ()
updateVOLH (VOLH l handle ehandle valr muter _ _) = do
mixer_handle_events l handle
val <- getVolume ehandle l
mute <- isMute ehandle l
writeIORef valr val
writeIORef muter mute
updateVOLH Err = return ()
getVolumeRaw :: VOLHandle -> IO Int
getVolumeRaw (VOLH _ _ _ valr _ _ _) = readIORef valr
getVolumeRaw Err = return 0
getVolumePercent :: VOLHandle -> IO Int
getVolumePercent (VOLH _ _ _ valr _ lower upper) = do
val <- readIORef valr
return $ percentize val lower upper
getVolumePercent Err = return 0
getMute :: VOLHandle -> IO Bool
getMute (VOLH _ _ _ _ muter _ _) = readIORef muter
getMute Err = return True
getVOLHandleInt :: Either Int MixerHandle -> LibAlsa -> IO VOLHandle
getVOLHandleInt (Right handle) l = do
ehandle <- getElem handle "Master" 0 l
if ehandle == nullPtr
then return Err
else do
(lower, upper) <- getVolumeRange ehandle l
val <- getVolume ehandle l
mute <- isMute ehandle l
volref <- newIORef val
muteref <- newIORef mute
return (VOLH l handle ehandle volref muteref lower upper)
getVOLHandleInt _ _ = return Err
isLoaded :: VOLHandle -> Bool
isLoaded Err = False
isLoaded _ = True
getPollFDs :: VOLHandle -> IO [Fd]
getPollFDs (VOLH l h _ _ _ _ _) = map Fd <$> getPollDescs h l
getPollFDs Err = return []
destroyVOLHandle :: VOLHandle -> IO ()
destroyVOLHandle (VOLH a m _ _ _ _ _) =
mixer_close a m >> destroyLibAlsa a
destroyVOLHandle Err = return ()
getVOLHandle :: String
-> IO VOLHandle
getVOLHandle card = do
l <- getLibAlsa
handle <- runExceptT (getMixerHandle card l)
getVOLHandleInt handle l