diff --git a/Foreign/Extra/BitSet.hs b/Foreign/Extra/BitSet.hs new file mode 100644 --- /dev/null +++ b/Foreign/Extra/BitSet.hs @@ -0,0 +1,26 @@ +module Foreign.Extra.BitSet + ( fromBitSet + , toBitSet + ) where + +import Data.Bits (Bits, (.&.), (.|.), complement) +import Data.Set (Set, empty, insert, toList) + +fromBitSet :: (Ord h, Bits c) => [(h, c)] -> (c -> h) -> c -> Set h +fromBitSet spec unknown bits + | unmatched == 0 = matched + | otherwise = insert (unknown unmatched) matched + where + (matched, unmatched) = foldr test (empty, bits) spec + test (h, v) (m, um) + | v == v .&. um = (insert h m, um .&. complement v) + | otherwise = (m, um) + +toBitSet ::(Eq h, Bits c) => [(h, c)] -> (h -> Bool) -> (h -> c) -> Set h -> c +toBitSet spec isUnknown unUnknown = foldr (.|.) 0 . map f . toList + where + f h + | isUnknown h = unUnknown h + | otherwise = case h `lookup` spec of + Just c -> c + Nothing -> error "toBitSet" diff --git a/Foreign/Extra/CEnum.hs b/Foreign/Extra/CEnum.hs new file mode 100644 --- /dev/null +++ b/Foreign/Extra/CEnum.hs @@ -0,0 +1,18 @@ +module Foreign.Extra.CEnum + ( fromCEnum + , toCEnum + ) where + +fromCEnum :: (Ord h, Eq c) => [(h, c)] -> (c -> h) -> c -> h +fromCEnum spec unknown enum = case enum `lookup` map swap spec of + Nothing -> unknown enum + Just h -> h + where + swap (a, b) = (b, a) + +toCEnum :: Eq h => [(h, c)] -> (h -> Bool) -> (h -> c) -> h -> c +toCEnum spec isUnknown unUnknown h + | isUnknown h = unUnknown h + | otherwise = case h `lookup` spec of + Nothing -> error "toCEnum" + Just c -> c diff --git a/Foreign/Extra/String.hs b/Foreign/Extra/String.hs new file mode 100644 --- /dev/null +++ b/Foreign/Extra/String.hs @@ -0,0 +1,8 @@ +module Foreign.Extra.String + ( fromString + ) where + +import Data.Word (Word8) + +fromString :: [Word8] -> String +fromString = map (toEnum . fromEnum) . takeWhile (/= 0) diff --git a/Graphics/V4L2.hs b/Graphics/V4L2.hs new file mode 100644 --- /dev/null +++ b/Graphics/V4L2.hs @@ -0,0 +1,84 @@ +{- | +Module : Graphics.V4L2 +Maintainer : claudiusmaximus@goto10.org +Stability : no +Portability : no +-} +module Graphics.V4L2 ( + module Graphics.V4L2.Device + , module Graphics.V4L2.Capability + , module Graphics.V4L2.Priority + , module Graphics.V4L2.Control + , module Graphics.V4L2.Field + , module Graphics.V4L2.PixelFormat + , module Graphics.V4L2.ColorSpace + , module Graphics.V4L2.Format + , module Graphics.V4L2.VideoInput + , module Graphics.V4L2.VideoStandard + , module Graphics.V4L2.VideoCapture + ) where + +import Graphics.V4L2.Device +import Graphics.V4L2.Capability +import Graphics.V4L2.Priority +import Graphics.V4L2.Control +import Graphics.V4L2.Field +import Graphics.V4L2.PixelFormat +import Graphics.V4L2.ColorSpace +import Graphics.V4L2.Format +import Graphics.V4L2.VideoInput +import Graphics.V4L2.VideoStandard +import Graphics.V4L2.VideoCapture + +{- + -- * Buffers and formats. + , BufferType(..) + -- ** Image formats. + -- * Audio inputs. + , AudioIndex + -- * Tuners. + , TunerIndex + -- * Exceptions + , V4L2Bug(..) + ) where +import Prelude hiding (null, catch) +import Foreign +import Foreign.C +import Foreign.Helper +import Control.Monad (when) +import Control.Exception +import GHC.IO.Exception (IOErrorType(InvalidArgument, ResourceBusy), ioe_type) +import System.Posix.Types (Fd(Fd), CMode) +import System.Posix.IOCtl (IOControl(ioctlReq)) +import Data.Set (Set, empty, fromList, singleton, union, insert, null) +import Data.Word (Word8, Word32, Word64) +import Data.Bits (shiftR, (.&.), testBit) +import Data.Maybe (fromMaybe) +import Bindings.Linux.VideoDev2 +import Bindings.LibV4L2 + +{- | Buffer type identifiers. -} +enum "BufferType" "C'v4l2_buf_type" "c'V4L2_BUF_TYPE_" "B" $ words "VIDEO_CAPTURE VIDEO_CAPTURE_MPLANE VIDEO_OUTPUT VIDEO_OUTPUT_MPLANE VIDEO_OVERLAY VBI_CAPTURE VBI_OUTPUT SLICED_VBI_CAPTURE SLICED_VBI_OUTPUT VIDEO_OUTPUT_OVERLAY" + +{- | Audio input index. -} +newtype AudioIndex = AudioIndex Int + deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Typeable, Num, Integral, Real) + +{- | Tuner index. -} +newtype TunerIndex = TunerIndex Int + deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Typeable, Num, Integral, Real) + + +zero :: Storable a => IO a +zero = alloca $ \p -> c'memset p 0 (fromIntegral $ sizeOf (undefined `asTypeOf` unsafePerformIO (peek p))) >> peek p + +{- | Internal errors. Please report these as bugs. -} +data V4L2Bug + = V4L2BugUnparseableInput C'v4l2_input + | V4L2BugUnparseableFormat C'v4l2_format + | V4L2BugUnparseableFormatDescription C'v4l2_fmtdesc + | V4L2BugUnexpectedFrameSizeType C'v4l2_frmsizeenum + | V4L2BugUnexpectedFrameIntervalType C'v4l2_frmivalenum + deriving (Show, Typeable) +instance Exception V4L2Bug +-} diff --git a/Graphics/V4L2/Capability.hs b/Graphics/V4L2/Capability.hs new file mode 100644 --- /dev/null +++ b/Graphics/V4L2/Capability.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{- | +Module : Graphics.V4L2.Capability +Maintainer : claudiusmaximus@goto10.org +Stability : no +Portability : no +-} +module Graphics.V4L2.Capability + ( DeviceInfo(..) + , DeviceCapability(..) + , deviceInfoCapabilities + , deviceInfo + , deviceCapabilities + ) where + +import Data.Bits ((.&.), shiftR) +import Data.Data (Data) +import Data.Set (Set) +import Data.Typeable (Typeable) +import Data.Version (Version(..)) +import Data.Word (Word32) + +import Bindings.Linux.VideoDev2 + +import Foreign.Extra.BitSet (fromBitSet) +import Foreign.Extra.String (fromString) +import Graphics.V4L2.Device (Device) +import Graphics.V4L2.IOCtl (ioctl') + +{- | Device information. -} +data DeviceInfo = DeviceInfo{ deviceDriver, deviceCard, deviceBus :: String, deviceVersion :: Version } + deriving (Eq, Ord, Read, Show, Typeable) + +{- | Device capabilities. -} +data DeviceCapability + = DeviceVideoCapture + | DeviceVideoOutput + | DeviceVideoOverlay + | DeviceVbiCapture + | DeviceVbiOutput + | DeviceSlicedVbiCapture + | DeviceSlicedVbiOutput + | DeviceRdsCapture + | DeviceVideoOutputOverlay + | DeviceHwFreqSeek + | DeviceRdsOutput + | DeviceTuner + | DeviceAudio + | DeviceRadio + | DeviceModulator + | DeviceReadWrite + | DeviceAsyncIO + | DeviceStreaming + | DeviceTimePerFrame + | DeviceUnknown Word32 + deriving (Eq, Ord, Read, Show, Data, Typeable) + +fromCapability :: Word32 -> Set DeviceCapability +fromCapability = fromBitSet + [ ( DeviceVideoCapture , c'V4L2_CAP_VIDEO_CAPTURE ) + , ( DeviceVideoOutput , c'V4L2_CAP_VIDEO_OUTPUT ) + , ( DeviceVideoOverlay , c'V4L2_CAP_VIDEO_OVERLAY ) + , ( DeviceVbiCapture , c'V4L2_CAP_VBI_CAPTURE ) + , ( DeviceVbiOutput , c'V4L2_CAP_VBI_OUTPUT ) + , ( DeviceSlicedVbiCapture , c'V4L2_CAP_SLICED_VBI_CAPTURE ) + , ( DeviceSlicedVbiOutput , c'V4L2_CAP_SLICED_VBI_OUTPUT ) + , ( DeviceRdsCapture , c'V4L2_CAP_RDS_CAPTURE ) + , ( DeviceVideoOutputOverlay , c'V4L2_CAP_VIDEO_OUTPUT_OVERLAY ) + , ( DeviceHwFreqSeek , c'V4L2_CAP_HW_FREQ_SEEK ) + , ( DeviceRdsOutput , c'V4L2_CAP_RDS_OUTPUT ) + , ( DeviceTuner , c'V4L2_CAP_TUNER ) + , ( DeviceAudio , c'V4L2_CAP_AUDIO ) + , ( DeviceRadio , c'V4L2_CAP_RADIO ) + , ( DeviceModulator , c'V4L2_CAP_MODULATOR ) + , ( DeviceReadWrite , c'V4L2_CAP_READWRITE ) + , ( DeviceAsyncIO , c'V4L2_CAP_ASYNCIO ) + , ( DeviceStreaming , c'V4L2_CAP_STREAMING ) + , ( DeviceTimePerFrame , c'V4L2_CAP_TIMEPERFRAME ) + ] DeviceUnknown + +{- | Get device information and capabilities. -} +deviceInfoCapabilities :: Device -> IO (DeviceInfo, Set DeviceCapability) +deviceInfoCapabilities d = do + c <- ioctl' d C'VIDIOC_QUERYCAP + return + ( DeviceInfo + { deviceDriver = fromString $ c'v4l2_capability'driver c + , deviceCard = fromString $ c'v4l2_capability'card c + , deviceBus = fromString $ c'v4l2_capability'bus_info c + , deviceVersion = fromVersion $ c'v4l2_capability'version c + } + , fromCapability $ c'v4l2_capability'capabilities c + ) + +{- | Get device information. -} +deviceInfo :: Device -> IO DeviceInfo +deviceInfo d = fst `fmap` deviceInfoCapabilities d + +{- | Get device capabilities. -} +deviceCapabilities :: Device -> IO (Set DeviceCapability) +deviceCapabilities d = snd `fmap` deviceInfoCapabilities d + +fromVersion :: Word32 -> Version +fromVersion v = Version + { versionBranch = + [ fromIntegral $ (v `shiftR` 16) .&. 0xFF + , fromIntegral $ (v `shiftR` 8) .&. 0xFF + , fromIntegral $ (v ) .&. 0xFF + ] + , versionTags = [] + } diff --git a/Graphics/V4L2/ColorSpace.hs b/Graphics/V4L2/ColorSpace.hs new file mode 100644 --- /dev/null +++ b/Graphics/V4L2/ColorSpace.hs @@ -0,0 +1,11 @@ +{- | +Module : Graphics.V4L2.ColorSpace +Maintainer : claudiusmaximus@goto10.org +Stability : no +Portability : no +-} +module Graphics.V4L2.ColorSpace + ( module Graphics.V4L2.ColorSpace.Internal + ) where + +import Graphics.V4L2.ColorSpace.Internal hiding (fromColorSpace, toColorSpace) diff --git a/Graphics/V4L2/ColorSpace/Internal.hs b/Graphics/V4L2/ColorSpace/Internal.hs new file mode 100644 --- /dev/null +++ b/Graphics/V4L2/ColorSpace/Internal.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{- | +Module : Graphics.V4L2.ColorSpace.Internal +Maintainer : claudiusmaximus@goto10.org +Stability : no +Portability : no +-} +module Graphics.V4L2.ColorSpace.Internal + ( ColorSpace(..) + , fromColorSpace + , toColorSpace + ) where + +import Data.Data (Data) +import Data.Typeable (Typeable) +import Data.Word (Word32) + +import Bindings.Linux.VideoDev2 + +import Foreign.Extra.CEnum (toCEnum, fromCEnum) + +{- | Color spaces. -} +data ColorSpace + = ColorSMPTE170M + | ColorSMPTE240M + | ColorREC709 + | ColorBT878 + | Color470SystemM + | Color470SystemBG + | ColorJPEG + | ColorSRGB + | ColorUnknown Word32 + deriving (Eq, Ord, Read, Show, Data, Typeable) + +{- | internal -} +fromColorSpace :: C'v4l2_colorspace -> ColorSpace +{- | internal -} +toColorSpace :: ColorSpace -> C'v4l2_colorspace + +(fromColorSpace, toColorSpace) = (fromCEnum spec (ColorUnknown . fromIntegral), toCEnum spec isUnknown unUnknown) where + spec = + [ ( ColorSMPTE170M , c'V4L2_COLORSPACE_SMPTE170M ) + , ( ColorSMPTE240M , c'V4L2_COLORSPACE_SMPTE240M ) + , ( ColorREC709 , c'V4L2_COLORSPACE_REC709 ) + , ( ColorBT878 , c'V4L2_COLORSPACE_BT878 ) + , ( Color470SystemM , c'V4L2_COLORSPACE_470_SYSTEM_M ) + , ( Color470SystemBG , c'V4L2_COLORSPACE_470_SYSTEM_BG ) + , ( ColorJPEG , c'V4L2_COLORSPACE_JPEG ) + , ( ColorSRGB , c'V4L2_COLORSPACE_SRGB ) + ] + isUnknown (ColorUnknown _) = True + isUnknown _ = False + unUnknown (ColorUnknown f) = fromIntegral f + unUnknown _ = error "Graphice.V4L2.ColorSpace.Internal.toColorSpace" diff --git a/Graphics/V4L2/Control.hs b/Graphics/V4L2/Control.hs new file mode 100644 --- /dev/null +++ b/Graphics/V4L2/Control.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} +{- | +Module : Graphics.V4L2.Control +Maintainer : claudiusmaximus@goto10.org +Stability : no +Portability : no +-} +module Graphics.V4L2.Control + ( ControlID() + , MenuID() + , ControlFlag(..) + , ControlInfo(..) + , queryControls + , Activate(..) + , ControlData() + , getControl + , setControl + ) where + +import Prelude hiding (catch) + +import Control.Exception (catch, throwIO) +import Control.Monad (liftM) +import Data.Data (Data) +import Data.Int (Int32) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (catMaybes) +import Data.Set (Set) +import Data.Typeable (Typeable) +import Data.Word (Word32) +import Foreign.Marshal.Utils (fromBool, toBool) +import GHC.IO.Exception (IOErrorType(InvalidArgument), ioe_type) + +import Bindings.Linux.VideoDev2 + +import Foreign.Extra.BitSet (fromBitSet) +import Foreign.Extra.String (fromString) +import Graphics.V4L2.Device (Device) +import Graphics.V4L2.IOCtl (ioctl, ioctl_, zero) + +{- | Control index. -} +newtype ControlID = ControlID Int + deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Typeable, Num, Integral, Real) + +{- | Menu index. -} +newtype MenuID = MenuID Int + deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Typeable, Num, Integral, Real) + +{- | Control flags. -} +data ControlFlag + = ControlDisabled + | ControlGrabbed + | ControlReadOnly + | ControlUpdate + | ControlInactive + | ControlSlider + | ControlWriteOnly + | ControlUnknown Word32 + deriving (Eq, Ord, Read, Show, Data, Typeable) + +fromControlFlag :: Word32 -> Set ControlFlag +fromControlFlag = fromBitSet + [ ( ControlDisabled , c'V4L2_CTRL_FLAG_DISABLED ) + , ( ControlGrabbed , c'V4L2_CTRL_FLAG_GRABBED ) + , ( ControlReadOnly , c'V4L2_CTRL_FLAG_READ_ONLY ) + , ( ControlUpdate , c'V4L2_CTRL_FLAG_UPDATE ) + , ( ControlInactive , c'V4L2_CTRL_FLAG_INACTIVE ) + , ( ControlSlider , c'V4L2_CTRL_FLAG_SLIDER ) + , ( ControlWriteOnly , c'V4L2_CTRL_FLAG_WRITE_ONLY ) + ] ControlUnknown + +{- | Control information. -} +data ControlInfo + = ControlInteger { controlName :: String, controlFlags :: Set ControlFlag, controlDefaultInt, controlMinimum, controlMaximum, controlStep :: Int } + | ControlBoolean { controlName :: String, controlFlags :: Set ControlFlag, controlDefaultBool :: Bool } + | ControlButton { controlName :: String, controlFlags :: Set ControlFlag } + | ControlInteger64{ controlName :: String, controlFlags :: Set ControlFlag } + | ControlString { controlName :: String, controlFlags :: Set ControlFlag, controlLengthWithout0 :: Int } + | ControlMenu { controlName :: String, controlFlags :: Set ControlFlag, controlDefaultMenu :: MenuID, controlMenu :: Map MenuID String } + deriving (Eq, Ord, Read, Show, Data, Typeable) + +{- | Enumerate controls. -} +queryControls :: Device -> IO (Map ControlID ControlInfo) +queryControls d = do + cs1 <- (M.fromList . catMaybes) `fmap` mapM (queryctrl d) [c'V4L2_CID_BASE .. c'V4L2_CID_LASTP1 - 1] + cs2 <- M.fromList `fmap` unfoldM q (c'V4L2_CID_PRIVATE_BASE) + return $ cs1 `M.union` cs2 + where + q c = fmap (flip (,) (c + 1)) `fmap` queryctrl d c + +queryctrl :: Device -> ControlID -> IO (Maybe (ControlID, ControlInfo)) +queryctrl d n = do + mq <- (return . Just =<< ioctl d C'VIDIOC_QUERYCTRL . (\s->s{ c'v4l2_queryctrl'id = fromIntegral n }) =<< zero + ) `catch` (\e -> case ioe_type e of + InvalidArgument -> return Nothing + _ -> throwIO e) + case mq of + Nothing -> return Nothing + Just q -> return . Just . (,) n =<< case c'v4l2_queryctrl'type q of + x | x == c'V4L2_CTRL_TYPE_INTEGER -> return ControlInteger + { controlName = fromString $ c'v4l2_queryctrl'name q + , controlFlags = fromControlFlag $ c'v4l2_queryctrl'flags q + , controlDefaultInt = fromIntegral $ c'v4l2_queryctrl'default_value q + , controlMinimum = fromIntegral $ c'v4l2_queryctrl'minimum q + , controlMaximum = fromIntegral $ c'v4l2_queryctrl'maximum q + , controlStep = fromIntegral $ c'v4l2_queryctrl'step q } + | x == c'V4L2_CTRL_TYPE_BOOLEAN -> return ControlBoolean + { controlName = fromString $ c'v4l2_queryctrl'name q + , controlFlags = fromControlFlag $ c'v4l2_queryctrl'flags q + , controlDefaultBool = toBool $ c'v4l2_queryctrl'default_value q } + | x == c'V4L2_CTRL_TYPE_BUTTON -> return ControlButton + { controlName = fromString $ c'v4l2_queryctrl'name q + , controlFlags = fromControlFlag $ c'v4l2_queryctrl'flags q } + | x == c'V4L2_CTRL_TYPE_INTEGER64 -> return ControlInteger64 + { controlName = fromString $ c'v4l2_queryctrl'name q + , controlFlags = fromControlFlag $ c'v4l2_queryctrl'flags q } + | x == c'V4L2_CTRL_TYPE_STRING -> return ControlString + { controlName = fromString $ c'v4l2_queryctrl'name q + , controlFlags = fromControlFlag $ c'v4l2_queryctrl'flags q + , controlLengthWithout0 = fromIntegral $ c'v4l2_queryctrl'maximum q } + | x == c'V4L2_CTRL_TYPE_MENU -> (\m -> ControlMenu + { controlName = fromString $ c'v4l2_queryctrl'name q + , controlFlags = fromControlFlag $ c'v4l2_queryctrl'flags q + , controlDefaultMenu = fromIntegral $ c'v4l2_queryctrl'default_value q + , controlMenu = m }) `fmap` querymenus d n (fromIntegral $ c'v4l2_queryctrl'minimum q) (fromIntegral $ c'v4l2_queryctrl'maximum q) + | otherwise -> error "queryctrl" + +-- FIXME: V4L2_CTRL_TYPE_CTRL_CLASS + + +querymenus :: Device -> ControlID -> MenuID -> MenuID -> IO (Map MenuID String) +querymenus d c mi ma = (M.fromList . catMaybes) `fmap` mapM (querymenu d c) [mi .. ma] + +querymenu :: Device -> ControlID -> MenuID -> IO (Maybe (MenuID, String)) +querymenu d c m = do + i <- (return . Just =<< ioctl d C'VIDIOC_QUERYMENU . (\s->s{ c'v4l2_querymenu'id = fromIntegral c, c'v4l2_querymenu'index = fromIntegral m }) =<< zero + ) `catch` (\e -> case ioe_type e of + InvalidArgument -> return Nothing + _ -> throwIO e) + return $ case i of + Nothing -> Nothing + Just fs -> Just (m, fromString $ c'v4l2_querymenu'name fs) + +{- | Control data values -} +class ControlData d where + toControlData :: d -> Int32 + fromControlData :: Int32 -> d + +instance ControlData Bool where + toControlData = fromBool + fromControlData = toBool + +instance ControlData MenuID where + toControlData = fromIntegral + fromControlData = fromIntegral + +instance ControlData Int32 where + toControlData = id + fromControlData = id + +{- | Button control data. -} +data Activate = Activate + deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Typeable) + +instance ControlData Activate where + toControlData Activate = 0 + fromControlData _ = Activate + +getControl :: ControlData d => Device -> ControlID -> IO d +getControl d c = return . fromControlData . c'v4l2_control'value =<< ioctl d C'VIDIOC_G_CTRL . (\s->s{ c'v4l2_control'id = fromIntegral c }) =<< zero + +setControl :: ControlData d => Device -> ControlID -> d -> IO () +setControl d c x = ioctl_ d C'VIDIOC_S_CTRL . (\s->s{ c'v4l2_control'id = fromIntegral c, c'v4l2_control'value = toControlData x }) =<< zero + + +unfoldM :: Monad m => (b -> m (Maybe (a, b))) -> b -> m [a] +unfoldM f b = do + fb <- f b + case fb of + Just (a, b') -> (a :) `liftM` unfoldM f b' + Nothing -> return [] diff --git a/Graphics/V4L2/Device.hs b/Graphics/V4L2/Device.hs new file mode 100644 --- /dev/null +++ b/Graphics/V4L2/Device.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} +{- | +Module : Graphics.V4L2.Device +Maintainer : claudiusmaximus@goto10.org +Stability : no +Portability : no +-} +module Graphics.V4L2.Device + ( Device() + , openDevice + , closeDevice + , withDevice + ) where + +import Control.Exception (bracket) +import Data.Bits (Bits) +import Data.Typeable (Typeable) +import Foreign.C.Error (throwErrnoIfMinus1, throwErrnoIfMinus1_) +import Foreign.C.String (withCString) +import Foreign.Storable (Storable) +import System.Posix.Types (Fd) + +import Bindings.LibV4L2 (c'v4l2_open, c'v4l2_close) +import Bindings.Posix.Fcntl (c'O_RDWR) + +{- | Device handle. -} +newtype Device = Device Fd + deriving (Bits, Bounded, Enum, Eq, Integral, Num, Ord, Read, Real, Show, Storable, Typeable) + +{- | Open a device. + Fails with invalid argument when the device is not a V4L2 device. +-} +openDevice :: FilePath {- ^ device name -} -> IO Device +openDevice f = withCString f $ \s -> do + h <- throwErrnoIfMinus1 "Graphics.V4L2.Device.openDevice" (c'v4l2_open s c'O_RDWR 0) + return (fromIntegral h) + +{- | Close a device. -} +closeDevice :: Device {- ^ device handle -} -> IO () +closeDevice d = throwErrnoIfMinus1_ "Graphics.V4L2.Device.closeDevice" (c'v4l2_close (fromIntegral d)) + +{- | Perform an action with a device. + The device will be close on exit from withDevice, whether by + normal termination or by raising an exception. If closing the + device raises an exception, then this exception will be raised by + 'withDevice' rather than any exception raised by the action. +-} +withDevice :: FilePath {- ^ device name -} -> (Device -> IO a) {- ^ action -} -> IO a +withDevice f = bracket (openDevice f) closeDevice diff --git a/Graphics/V4L2/Field.hs b/Graphics/V4L2/Field.hs new file mode 100644 --- /dev/null +++ b/Graphics/V4L2/Field.hs @@ -0,0 +1,11 @@ +{- | +Module : Graphics.V4L2.Field +Maintainer : claudiusmaximus@goto10.org +Stability : no +Portability : no +-} +module Graphics.V4L2.Field + ( module Graphics.V4L2.Field.Internal + ) where + +import Graphics.V4L2.Field.Internal hiding (fromField, toField) diff --git a/Graphics/V4L2/Field/Internal.hs b/Graphics/V4L2/Field/Internal.hs new file mode 100644 --- /dev/null +++ b/Graphics/V4L2/Field/Internal.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{- | +Module : Graphics.V4L2.Field.Internal +Maintainer : claudiusmaximus@goto10.org +Stability : no +Portability : no +-} +module Graphics.V4L2.Field.Internal + ( Field(..) + , fieldHasTop + , fieldHasBottom + , fieldHasBoth + , fromField + , toField + ) where + +import Data.Data (Data) +import Data.Typeable (Typeable) +import Data.Word (Word32) +import Foreign (unsafePerformIO) +import Foreign.Marshal.Utils (toBool) + +import Bindings.Linux.VideoDev2 + +import Foreign.Extra.CEnum (toCEnum, fromCEnum) + +{- | Interlacing modes. -} +data Field + = FieldAny + | FieldNone + | FieldTop + | FieldBottom + | FieldInterlaced + | FieldSeqTB + | FieldSeqBT + | FieldAlternate + | FieldInterlacedTB + | FieldInterlacedBT + | FieldUnknown Word32 + deriving (Eq, Ord, Read, Show, Data, Typeable) + +{- | internal -} +fromField :: C'v4l2_field -> Field +{- | internal -} +toField :: Field -> C'v4l2_field + +(fromField, toField) = (fromCEnum spec (FieldUnknown . fromIntegral), toCEnum spec isUnknown unUnknown) where + spec = + [ ( FieldAny , c'V4L2_FIELD_ANY ) + , ( FieldNone , c'V4L2_FIELD_NONE ) + , ( FieldTop , c'V4L2_FIELD_TOP ) + , ( FieldBottom , c'V4L2_FIELD_BOTTOM ) + , ( FieldInterlaced , c'V4L2_FIELD_INTERLACED ) + , ( FieldSeqTB , c'V4L2_FIELD_SEQ_TB ) + , ( FieldSeqBT , c'V4L2_FIELD_SEQ_BT ) + , ( FieldAlternate , c'V4L2_FIELD_ALTERNATE ) + , ( FieldInterlacedTB , c'V4L2_FIELD_INTERLACED_TB ) + , ( FieldInterlacedBT , c'V4L2_FIELD_INTERLACED_BT ) + ] + isUnknown (FieldUnknown _) = True + isUnknown _ = False + unUnknown (FieldUnknown f) = fromIntegral f + unUnknown _ = error "Graphice.V4L2.Field.Internal.toField" + +{- | Inspect field interlacing. -} +fieldHasTop :: Field -> Bool +fieldHasTop f = unsafePerformIO $ toBool `fmap` c'V4L2_FIELD_HAS_TOP (toField f) + +{- | Inspect field interlacing. -} +fieldHasBottom :: Field -> Bool +fieldHasBottom f = unsafePerformIO $ toBool `fmap` c'V4L2_FIELD_HAS_BOTTOM (toField f) + +{- | Inspect field interlacing. -} +fieldHasBoth :: Field -> Bool +fieldHasBoth f = unsafePerformIO $ toBool `fmap` c'V4L2_FIELD_HAS_BOTH (toField f) diff --git a/Graphics/V4L2/Format.hs b/Graphics/V4L2/Format.hs new file mode 100644 --- /dev/null +++ b/Graphics/V4L2/Format.hs @@ -0,0 +1,305 @@ +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} +{- | +Module : Graphics.V4L2.Format +Maintainer : claudiusmaximus@goto10.org +Stability : no +Portability : no +-} +module Graphics.V4L2.Format + ( BufferType(..) + , Direction(..) + , Format(..) + , FormatID() + , FormatDescription(..) + , FormatFlag(..) + , queryFormats + , FrameSize(..) + , FrameSizes(..) + , queryFrameSizes + , FrameIntervals(..) + , queryFrameIntervals + , ImageFormat(..) + ) where + +import Prelude hiding (catch) + +import Control.Exception (catch, throwIO) +import Control.Monad (when) +import Data.Data (Data) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.Set as S +import Data.Typeable (Typeable) +import Data.Word (Word32) +import GHC.IO.Exception (IOErrorType(InvalidArgument), ioe_type) + +import Bindings.Linux.VideoDev2 + +import Foreign.Extra.BitSet (fromBitSet) +import Foreign.Extra.CEnum (toCEnum) +import Foreign.Extra.String (fromString) +import Graphics.V4L2.Device (Device) +import Graphics.V4L2.IOCtl (ioctl, zero) +import Graphics.V4L2.Field (Field) +import Graphics.V4L2.Field.Internal (fromField, toField) +import Graphics.V4L2.PixelFormat (PixelFormat) +import Graphics.V4L2.PixelFormat.Internal (fromPixelFormat, toPixelFormat) +import Graphics.V4L2.ColorSpace (ColorSpace) +import Graphics.V4L2.ColorSpace.Internal (fromColorSpace, toColorSpace) +import Graphics.V4L2.Types (Fraction(..)) +import Graphics.V4L2.Types.Internal (fromFraction) + +-- FIXME { +{- +c'V4L2_BUF_TYPE_VIDEO_CAPTURE_MPLANE = 9 +c'V4L2_BUF_TYPE_VIDEO_OUTPUT_MPLANE = 10 +V4L2_BUF_TYPE_VIDEO_OVERLAY +V4L2_BUF_TYPE_VBI_CAPTURE +V4L2_BUF_TYPE_VBI_OUTPUT +V4L2_BUF_TYPE_SLICED_VBI_CAPTURE +V4L2_BUF_TYPE_SLICED_VBI_OUTPUT +V4L2_BUF_TYPE_VIDEO_OUTPUT_OVERLAY +V4L2_BUF_TYPE_PRIVATE +-} +-- FIXME } + +data BufferType = BufferVideoCapture | BufferVideoOutput | BufferUnknown Word32 + deriving (Eq, Ord, Read, Show, Data, Typeable) + +toBufferType :: BufferType -> C'v4l2_buf_type +toBufferType = toCEnum + [ ( BufferVideoCapture , c'V4L2_BUF_TYPE_VIDEO_CAPTURE ) + , ( BufferVideoOutput , c'V4L2_BUF_TYPE_VIDEO_OUTPUT ) + ] isU unU + where + isU (BufferUnknown _) = True + isU _ = False + unU (BufferUnknown b) = fromIntegral b + unU _ = error "err" + +data Direction = Capture | Output + deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Typeable) + +class Format f where + formatBufferType :: f -> Direction -> BufferType + getFormat :: Device -> Direction -> IO f + setFormat :: Device -> Direction -> f -> IO f + tryFormat :: Device -> Direction -> f -> IO f + +data ImageFormat = ImageFormat + { imageWidth, imageHeight :: Int + , imagePixelFormat :: PixelFormat + , imageField :: Field + , imageBytesPerLine :: Int + , imageSize :: Int + , imageColorSpace :: ColorSpace + } + deriving (Eq, Ord, Read, Show, Data, Typeable) + +instance Format ImageFormat where + formatBufferType _ = imageBufferType + getFormat d dir = + return . decodeImageFormat . c'v4l2_format_u'pix . c'v4l2_format'fmt =<< ioctl d C'VIDIOC_G_FMT . (\s->s{ c'v4l2_format'type = toBufferType $ imageBufferType dir }) =<< zero + setFormat d dir f = do + u <- (`u'v4l2_format_u'pix` encodeImageFormat f) =<< zero + return . decodeImageFormat . c'v4l2_format_u'pix . c'v4l2_format'fmt =<< ioctl d C'VIDIOC_S_FMT =<< (\s->s{ c'v4l2_format'type = toBufferType $ imageBufferType dir, c'v4l2_format'fmt = u }) `fmap` zero + tryFormat d dir f = do + u <- (`u'v4l2_format_u'pix` encodeImageFormat f) =<< zero + return . decodeImageFormat . c'v4l2_format_u'pix . c'v4l2_format'fmt =<< ioctl d C'VIDIOC_TRY_FMT =<< (\s->s{ c'v4l2_format'type = toBufferType $ imageBufferType dir, c'v4l2_format'fmt = u }) `fmap` zero + +encodeImageFormat :: ImageFormat -> C'v4l2_pix_format +encodeImageFormat f = C'v4l2_pix_format + { c'v4l2_pix_format'width = fromIntegral $ imageWidth f + , c'v4l2_pix_format'height = fromIntegral $ imageHeight f + , c'v4l2_pix_format'pixelformat = toPixelFormat $ imagePixelFormat f + , c'v4l2_pix_format'field = toField $ imageField f + , c'v4l2_pix_format'bytesperline = fromIntegral $ imageBytesPerLine f + , c'v4l2_pix_format'sizeimage = fromIntegral $ imageSize f + , c'v4l2_pix_format'colorspace = toColorSpace $ imageColorSpace f + , c'v4l2_pix_format'priv = 0 + } + +decodeImageFormat :: C'v4l2_pix_format -> ImageFormat +decodeImageFormat f = ImageFormat + { imageWidth = fromIntegral $ c'v4l2_pix_format'width f + , imageHeight = fromIntegral $ c'v4l2_pix_format'height f + , imagePixelFormat = fromPixelFormat $ c'v4l2_pix_format'pixelformat f + , imageField = fromField $ c'v4l2_pix_format'field f + , imageBytesPerLine = fromIntegral $ c'v4l2_pix_format'bytesperline f + , imageSize = fromIntegral $ c'v4l2_pix_format'sizeimage f + , imageColorSpace = fromColorSpace $ c'v4l2_pix_format'colorspace f + } + +imageBufferType :: Direction -> BufferType +imageBufferType Capture = BufferVideoCapture +imageBufferType Output = BufferVideoOutput + + +{- | Format flags. -} +data FormatFlag + = FormatCompressed + | FormatEmulated + | FormatUnknown Word32 + deriving (Eq, Ord, Read, Show, Data, Typeable) + +fromFormatFlag :: Word32 -> Set FormatFlag +fromFormatFlag = fromBitSet + [ ( FormatCompressed , c'V4L2_FMT_FLAG_COMPRESSED ) + , ( FormatEmulated , c'V4L2_FMT_FLAG_EMULATED ) + ] FormatUnknown + +{- | Video format ID. -} +newtype FormatID = FormatID Int + deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Typeable, Num, Integral, Real) + +{- | Video format description -} +data FormatDescription = FormatDescription + { formatDescription :: String + , formatPixelFormat :: PixelFormat + , formatFlags :: Set FormatFlag + } + deriving (Eq, Ord, Read, Show, Data, Typeable) + +enumfmt :: Device -> BufferType -> FormatID -> IO FormatDescription +enumfmt h t n = do + d <- ioctl h C'VIDIOC_ENUM_FMT . (\s->s{ c'v4l2_fmtdesc'index = fromIntegral n, c'v4l2_fmtdesc'type = toBufferType t }) =<< zero + return FormatDescription + { formatDescription = fromString $ c'v4l2_fmtdesc'description d + , formatPixelFormat = fromPixelFormat $ c'v4l2_fmtdesc'pixelformat d + , formatFlags = fromFormatFlag $ c'v4l2_fmtdesc'flags d + } + +{- | Enumerate supported buffer formats. + + Exceptions: + + * InvalidArgument - buffer type not supported or index out of range +-} +queryFormats :: Device -> BufferType -> IO (Map FormatID FormatDescription) +queryFormats = enumfmts' 0 + +enumfmts' :: FormatID -> Device -> BufferType -> IO (Map FormatID FormatDescription) +enumfmts' n h t = do + mi <- (Just `fmap` enumfmt h t n) `catch` (\e -> case ioe_type e of + InvalidArgument -> return Nothing + _ -> throwIO e) + case mi of + Just i -> M.insert n i `fmap` enumfmts' (n + 1) h t + Nothing -> return M.empty + +{- | Enumerate supported frame sizes. -} +queryFrameSizes :: Device -> PixelFormat -> IO FrameSizes +queryFrameSizes h p = do + fs <- enumframesizes0 h p `catch` (\e -> case ioe_type e of + InvalidArgument -> return (DiscreteSizes S.empty) + _ -> throwIO e) + case fs of + DiscreteSizes f | not $ S.null f -> do + fs' <- enumframesizesD 1 h p + return . DiscreteSizes $ f `S.union` fs' + _ -> return fs + +enumframesizes0 :: Device -> PixelFormat -> IO FrameSizes +enumframesizes0 h p = do + f <- ioctl h C'VIDIOC_ENUM_FRAMESIZES . (\s->s{ c'v4l2_frmsizeenum'index = 0, c'v4l2_frmsizeenum'pixel_format = toPixelFormat p }) =<< zero + case c'v4l2_frmsizeenum'type f of + x | x == c'V4L2_FRMSIZE_TYPE_DISCRETE -> return . DiscreteSizes . S.singleton . decodeFrameSize . c'v4l2_frmsizeenum_u'discrete . c'v4l2_frmsizeenum'u $ f + | x == c'V4L2_FRMSIZE_TYPE_STEPWISE || + x == c'V4L2_FRMSIZE_TYPE_CONTINUOUS -> do + let s = c'v4l2_frmsizeenum_u'stepwise . c'v4l2_frmsizeenum'u $ f + return StepwiseSizes + { stepwiseMinWidth = fromIntegral $ c'v4l2_frmsize_stepwise'min_width s + , stepwiseMaxWidth = fromIntegral $ c'v4l2_frmsize_stepwise'max_width s + , stepwiseStepWidth = fromIntegral $ c'v4l2_frmsize_stepwise'step_width s + , stepwiseMinHeight = fromIntegral $ c'v4l2_frmsize_stepwise'min_height s + , stepwiseMaxHeight = fromIntegral $ c'v4l2_frmsize_stepwise'max_height s + , stepwiseStepHeight = fromIntegral $ c'v4l2_frmsize_stepwise'step_height s + } + | otherwise -> error "err" + +enumframesizesD :: Word32 -> Device -> PixelFormat -> IO (Set FrameSize) +enumframesizesD n h p = do + f <- (do + f' <- ioctl h C'VIDIOC_ENUM_FRAMESIZES . (\s->s{ c'v4l2_frmsizeenum'index = n, c'v4l2_frmsizeenum'pixel_format = toPixelFormat p }) =<< zero + when (c'v4l2_frmsizeenum'type f' /= c'V4L2_FRMSIZE_TYPE_DISCRETE) $ error "err" + return (Just f')) `catch` (\e -> case ioe_type e of + InvalidArgument -> return Nothing + _ -> throwIO e) + case f of + Nothing -> return S.empty + Just fs -> S.insert (decodeFrameSize . c'v4l2_frmsizeenum_u'discrete . c'v4l2_frmsizeenum'u $ fs) `fmap` enumframesizesD (n + 1) h p + +{- | Single frame size. -} +data FrameSize = FrameSize + { frameWidth + , frameHeight :: Int + } + deriving (Eq, Ord, Read, Show, Data, Typeable) + +{- | Discrete and continuous frame sizes. -} +data FrameSizes + = DiscreteSizes + { discreteSizes :: Set FrameSize } + | StepwiseSizes + { stepwiseMinWidth + , stepwiseMaxWidth + , stepwiseStepWidth + , stepwiseMinHeight + , stepwiseMaxHeight + , stepwiseStepHeight :: Int + } + deriving (Eq, Ord, Read, Show, Data, Typeable) + +decodeFrameSize :: C'v4l2_frmsize_discrete -> FrameSize +decodeFrameSize d = FrameSize + { frameWidth = fromIntegral $ c'v4l2_frmsize_discrete'width d + , frameHeight = fromIntegral $ c'v4l2_frmsize_discrete'height d + } + +{- | Enumerate frame intervals. -} +queryFrameIntervals :: Device -> PixelFormat -> FrameSize -> IO FrameIntervals +queryFrameIntervals h p f = do + fi <- enumframeintervals0 h p f `catch` (\e -> case ioe_type e of + InvalidArgument -> return (DiscreteIntervals S.empty) + _ -> throwIO e) + case fi of + DiscreteIntervals i | not $ S.null i -> do + is <- enumframeintervalsD 1 h p f + return . DiscreteIntervals $ i `S.union` is + _ -> return fi + +enumframeintervals0 :: Device -> PixelFormat -> FrameSize -> IO FrameIntervals +enumframeintervals0 h p f = do + i <- ioctl h C'VIDIOC_ENUM_FRAMEINTERVALS . (\s->s{ c'v4l2_frmivalenum'index = 0, c'v4l2_frmivalenum'pixel_format = toPixelFormat p, c'v4l2_frmivalenum'width = fromIntegral (frameWidth f), c'v4l2_frmivalenum'height = fromIntegral (frameHeight f) }) =<< zero + case c'v4l2_frmivalenum'type i of + x | x == c'V4L2_FRMIVAL_TYPE_DISCRETE -> return . DiscreteIntervals . S.singleton . fromFraction . c'v4l2_frmivalenum_u'discrete . c'v4l2_frmivalenum'u $ i + | x == c'V4L2_FRMIVAL_TYPE_STEPWISE || + x == c'V4L2_FRMIVAL_TYPE_CONTINUOUS -> do + let s = c'v4l2_frmivalenum_u'stepwise . c'v4l2_frmivalenum'u $ i + return StepwiseIntervals + { stepwiseMin = fromFraction $ c'v4l2_frmival_stepwise'min s + , stepwiseMax = fromFraction $ c'v4l2_frmival_stepwise'max s + , stepwiseStep = fromFraction $ c'v4l2_frmival_stepwise'step s + } + | otherwise -> error "err" + +enumframeintervalsD :: Word32 -> Device -> PixelFormat -> FrameSize -> IO (Set Fraction) +enumframeintervalsD n h p f = do + i <- (do + f' <- ioctl h C'VIDIOC_ENUM_FRAMEINTERVALS . (\s->s{ c'v4l2_frmivalenum'index = n, c'v4l2_frmivalenum'pixel_format = toPixelFormat p, c'v4l2_frmivalenum'width = fromIntegral (frameWidth f), c'v4l2_frmivalenum'height = fromIntegral (frameHeight f) }) =<< zero + when (c'v4l2_frmivalenum'type f' /= c'V4L2_FRMIVAL_TYPE_DISCRETE) $ error "err" + return (Just f')) `catch` (\e -> case ioe_type e of + InvalidArgument -> return Nothing + _ -> throwIO e) + case i of + Nothing -> return S.empty + Just fs -> S.insert (fromFraction . c'v4l2_frmivalenum_u'discrete . c'v4l2_frmivalenum'u $ fs) `fmap` enumframeintervalsD (n + 1) h p f + +{- | Discrete and continuous frame intervals. -} +data FrameIntervals + = DiscreteIntervals + { discreteIntervals :: Set Fraction } + | StepwiseIntervals + { stepwiseMin, stepwiseMax, stepwiseStep :: Fraction } + deriving (Eq, Ord, Read, Show, Data, Typeable) diff --git a/Graphics/V4L2/IOCtl.hs b/Graphics/V4L2/IOCtl.hs new file mode 100644 --- /dev/null +++ b/Graphics/V4L2/IOCtl.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Graphics.V4L2.IOCtl + ( ioctl + , ioctl_ + , ioctl' + , zero + ) where + +import Foreign (Ptr, Storable, alloca, castPtr, peek, sizeOf, unsafePerformIO, with) +import Foreign.C (CInt, CSize, throwErrnoIfMinus1_) +import System.Posix.IOCtl (IOControl(ioctlReq)) + +import Bindings.LibV4L2 (c'v4l2_ioctl) + +import Graphics.V4L2.Device (Device) + +c_ioctl' :: IOControl req d => Device -> req -> Ptr d -> IO () +c_ioctl' f req p = + throwErrnoIfMinus1_ "ioctl" $ + c'v4l2_ioctl (fromIntegral f) (fromIntegral $ ioctlReq req) (castPtr p) + +-- | Calls a ioctl reading the structure after the call +ioctl :: IOControl req d + => Device -- ^ The file descriptor + -> req -- ^ The request + -> d -- ^ The data + -> IO d -- ^ The data after the call +ioctl f req d = with d $ \p -> c_ioctl' f req p >> peek p + +-- | Call a ioctl ignoring the result +ioctl_ :: IOControl req d + => Device -- ^ The file descriptor + -> req -- ^ The request + -> d -- ^ The data + -> IO () +ioctl_ f req d = with d $ \p -> c_ioctl' f req p + +-- | Call a ioctl with uninitialized data +ioctl' :: IOControl req d + => Device -- ^ The file descriptor + -> req -- ^ The request + -> IO d -- ^ The data +ioctl' f req = alloca $ \p -> c_ioctl' f req p >> peek p + + +zero :: Storable a => IO a +zero = alloca $ \p -> c'memset p 0 (fromIntegral $ sizeOf (undefined `asTypeOf` unsafePerformIO (peek p))) >> peek p + +foreign import ccall "string.h memset" c'memset :: Ptr a -> CInt -> CSize -> IO (Ptr a) diff --git a/Graphics/V4L2/PixelFormat.hs b/Graphics/V4L2/PixelFormat.hs new file mode 100644 --- /dev/null +++ b/Graphics/V4L2/PixelFormat.hs @@ -0,0 +1,11 @@ +{- | +Module : Graphics.V4L2.PixelFormat +Maintainer : claudiusmaximus@goto10.org +Stability : no +Portability : no +-} +module Graphics.V4L2.PixelFormat + ( module Graphics.V4L2.PixelFormat.Internal + ) where + +import Graphics.V4L2.PixelFormat.Internal hiding (fromPixelFormat, toPixelFormat) diff --git a/Graphics/V4L2/PixelFormat/Internal.hs b/Graphics/V4L2/PixelFormat/Internal.hs new file mode 100644 --- /dev/null +++ b/Graphics/V4L2/PixelFormat/Internal.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{- | +Module : Graphics.V4L2.PixelFormat.Internal +Maintainer : claudiusmaximus@goto10.org +Stability : no +Portability : no +-} +module Graphics.V4L2.PixelFormat.Internal + ( PixelFormat(..) + , fromPixelFormat + , toPixelFormat + ) where + +import Data.Data (Data) +import Data.Typeable (Typeable) +import Data.Word (Word32) + +import Bindings.Linux.VideoDev2 + +import Foreign.Extra.CEnum (toCEnum, fromCEnum) + +{- | Pixel formats. -} +data PixelFormat + -- grep PIX /usr/include/linux/videodev2.h | sed "s|^#define \(V4L2_PIX_FMT_\([^ \t]*\)\)[ \t].*$| \| Pixel\2|" + = PixelRGB332 + | PixelRGB444 + | PixelRGB555 + | PixelRGB565 + | PixelRGB555X + | PixelRGB565X + | PixelBGR24 + | PixelRGB24 + | PixelBGR32 + | PixelRGB32 + | PixelGREY + | PixelY16 + | PixelPAL8 + | PixelYVU410 + | PixelYVU420 + | PixelYUYV + | PixelYYUV + | PixelYVYU + | PixelUYVY + | PixelVYUY + | PixelYUV422P + | PixelYUV411P + | PixelY41P + | PixelYUV444 + | PixelYUV555 + | PixelYUV565 + | PixelYUV32 + | PixelYUV410 + | PixelYUV420 + | PixelHI240 + | PixelHM12 + | PixelNV12 + | PixelNV21 + | PixelNV16 + | PixelNV61 + | PixelSBGGR8 + | PixelSGBRG8 + | PixelSGRBG8 + | PixelSGRBG10 + | PixelSGRBG10DPCM8 + | PixelSBGGR16 + | PixelMJPEG + | PixelJPEG + | PixelDV + | PixelMPEG + | PixelWNVA + | PixelSN9C10X + | PixelSN9C20X_I420 + | PixelPWC1 + | PixelPWC2 + | PixelET61X251 + | PixelSPCA501 + | PixelSPCA505 + | PixelSPCA508 + | PixelSPCA561 + | PixelPAC207 + | PixelMR97310A + | PixelSQ905C + | PixelPJPG + | PixelOV511 + | PixelOV518 + | PixelUnknown Word32 + deriving (Eq, Ord, Read, Show, Data, Typeable) + +{- | internal -} +fromPixelFormat :: Word32 -> PixelFormat +{- | internal -} +toPixelFormat :: PixelFormat -> Word32 + +(fromPixelFormat, toPixelFormat) = (fromCEnum spec PixelUnknown, toCEnum spec isUnknown unUnknown) where + -- grep PIX /usr/include/linux/videodev2.h | sed "s|^#define \(V4L2_PIX_FMT_\([^ \t]*\)\)[ \t].*$| , ( Pixel\2 , c'\1 )|" + spec = + [ ( PixelRGB332 , c'V4L2_PIX_FMT_RGB332 ) + , ( PixelRGB444 , c'V4L2_PIX_FMT_RGB444 ) + , ( PixelRGB555 , c'V4L2_PIX_FMT_RGB555 ) + , ( PixelRGB565 , c'V4L2_PIX_FMT_RGB565 ) + , ( PixelRGB555X , c'V4L2_PIX_FMT_RGB555X ) + , ( PixelRGB565X , c'V4L2_PIX_FMT_RGB565X ) + , ( PixelBGR24 , c'V4L2_PIX_FMT_BGR24 ) + , ( PixelRGB24 , c'V4L2_PIX_FMT_RGB24 ) + , ( PixelBGR32 , c'V4L2_PIX_FMT_BGR32 ) + , ( PixelRGB32 , c'V4L2_PIX_FMT_RGB32 ) + , ( PixelGREY , c'V4L2_PIX_FMT_GREY ) + , ( PixelY16 , c'V4L2_PIX_FMT_Y16 ) + , ( PixelPAL8 , c'V4L2_PIX_FMT_PAL8 ) + , ( PixelYVU410 , c'V4L2_PIX_FMT_YVU410 ) + , ( PixelYVU420 , c'V4L2_PIX_FMT_YVU420 ) + , ( PixelYUYV , c'V4L2_PIX_FMT_YUYV ) + , ( PixelYYUV , c'V4L2_PIX_FMT_YYUV ) + , ( PixelYVYU , c'V4L2_PIX_FMT_YVYU ) + , ( PixelUYVY , c'V4L2_PIX_FMT_UYVY ) + , ( PixelVYUY , c'V4L2_PIX_FMT_VYUY ) + , ( PixelYUV422P , c'V4L2_PIX_FMT_YUV422P ) + , ( PixelYUV411P , c'V4L2_PIX_FMT_YUV411P ) + , ( PixelY41P , c'V4L2_PIX_FMT_Y41P ) + , ( PixelYUV444 , c'V4L2_PIX_FMT_YUV444 ) + , ( PixelYUV555 , c'V4L2_PIX_FMT_YUV555 ) + , ( PixelYUV565 , c'V4L2_PIX_FMT_YUV565 ) + , ( PixelYUV32 , c'V4L2_PIX_FMT_YUV32 ) + , ( PixelYUV410 , c'V4L2_PIX_FMT_YUV410 ) + , ( PixelYUV420 , c'V4L2_PIX_FMT_YUV420 ) + , ( PixelHI240 , c'V4L2_PIX_FMT_HI240 ) + , ( PixelHM12 , c'V4L2_PIX_FMT_HM12 ) + , ( PixelNV12 , c'V4L2_PIX_FMT_NV12 ) + , ( PixelNV21 , c'V4L2_PIX_FMT_NV21 ) + , ( PixelNV16 , c'V4L2_PIX_FMT_NV16 ) + , ( PixelNV61 , c'V4L2_PIX_FMT_NV61 ) + , ( PixelSBGGR8 , c'V4L2_PIX_FMT_SBGGR8 ) + , ( PixelSGBRG8 , c'V4L2_PIX_FMT_SGBRG8 ) + , ( PixelSGRBG8 , c'V4L2_PIX_FMT_SGRBG8 ) + , ( PixelSGRBG10 , c'V4L2_PIX_FMT_SGRBG10 ) + , ( PixelSGRBG10DPCM8 , c'V4L2_PIX_FMT_SGRBG10DPCM8 ) + , ( PixelSBGGR16 , c'V4L2_PIX_FMT_SBGGR16 ) + , ( PixelMJPEG , c'V4L2_PIX_FMT_MJPEG ) + , ( PixelJPEG , c'V4L2_PIX_FMT_JPEG ) + , ( PixelDV , c'V4L2_PIX_FMT_DV ) + , ( PixelMPEG , c'V4L2_PIX_FMT_MPEG ) + , ( PixelWNVA , c'V4L2_PIX_FMT_WNVA ) + , ( PixelSN9C10X , c'V4L2_PIX_FMT_SN9C10X ) + , ( PixelSN9C20X_I420 , c'V4L2_PIX_FMT_SN9C20X_I420 ) + , ( PixelPWC1 , c'V4L2_PIX_FMT_PWC1 ) + , ( PixelPWC2 , c'V4L2_PIX_FMT_PWC2 ) + , ( PixelET61X251 , c'V4L2_PIX_FMT_ET61X251 ) + , ( PixelSPCA501 , c'V4L2_PIX_FMT_SPCA501 ) + , ( PixelSPCA505 , c'V4L2_PIX_FMT_SPCA505 ) + , ( PixelSPCA508 , c'V4L2_PIX_FMT_SPCA508 ) + , ( PixelSPCA561 , c'V4L2_PIX_FMT_SPCA561 ) + , ( PixelPAC207 , c'V4L2_PIX_FMT_PAC207 ) + , ( PixelMR97310A , c'V4L2_PIX_FMT_MR97310A ) + , ( PixelSQ905C , c'V4L2_PIX_FMT_SQ905C ) + , ( PixelPJPG , c'V4L2_PIX_FMT_PJPG ) + , ( PixelOV511 , c'V4L2_PIX_FMT_OV511 ) + , ( PixelOV518 , c'V4L2_PIX_FMT_OV518 ) + ] + isUnknown (PixelUnknown _) = True + isUnknown _ = False + unUnknown (PixelUnknown f) = f + unUnknown _ = error "Graphice.V4L2.PixelFormat.Internal.toPixelFormat" diff --git a/Graphics/V4L2/Priority.hs b/Graphics/V4L2/Priority.hs new file mode 100644 --- /dev/null +++ b/Graphics/V4L2/Priority.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{- | +Module : Graphics.V4L2.Priority +Maintainer : claudiusmaximus@goto10.org +Stability : no +Portability : no +-} +module Graphics.V4L2.Priority + ( Priority(..) + , getPriority + , setPriority + ) where + +import Data.Data (Data) +import Data.Typeable (Typeable) +import Data.Word (Word32) + +import Bindings.Linux.VideoDev2 + +import Foreign.Extra.CEnum (fromCEnum, toCEnum) +import Graphics.V4L2.Device (Device) +import Graphics.V4L2.IOCtl (ioctl', ioctl_) + +{- | Priorities. -} +data Priority + = PriorityUnset + | PriorityBackground + | PriorityInteractive + | PriorityDefault + | PriorityRecord + | PriorityUnknown Word32 + deriving (Eq, Ord, Read, Show, Data, Typeable) + +fromPriority :: C'v4l2_priority -> Priority +toPriority :: Priority -> C'v4l2_priority +(fromPriority, toPriority) = (fromCEnum spec (PriorityUnknown . fromIntegral), toCEnum spec isUnknown unUnknown) where + spec = + [ ( PriorityUnset , c'V4L2_PRIORITY_UNSET ) + , ( PriorityBackground , c'V4L2_PRIORITY_BACKGROUND ) + , ( PriorityInteractive , c'V4L2_PRIORITY_INTERACTIVE ) + , ( PriorityDefault , c'V4L2_PRIORITY_DEFAULT ) + , ( PriorityRecord , c'V4L2_PRIORITY_RECORD ) + ] + isUnknown (PriorityUnknown _) = True + isUnknown _ = False + unUnknown (PriorityUnknown x) = fromIntegral x + unUnknown _ = error "Graphics.V4L2.Priority.toPriority.unUnknown" + +{- | Get priority. -} +getPriority :: Device -> IO Priority +getPriority d = fromPriority `fmap` ioctl' d C'VIDIOC_G_PRIORITY + +{- | Set priority. -} +setPriority :: Device -> Priority -> IO () +setPriority d p = ioctl_ d C'VIDIOC_S_PRIORITY (toPriority p) diff --git a/Graphics/V4L2/Types.hs b/Graphics/V4L2/Types.hs new file mode 100644 --- /dev/null +++ b/Graphics/V4L2/Types.hs @@ -0,0 +1,7 @@ +module Graphics.V4L2.Types + ( module Graphics.V4L2.Types.Internal + ) where + +import Graphics.V4L2.Types.Internal + ( Fraction(..) + ) diff --git a/Graphics/V4L2/Types/Internal.hs b/Graphics/V4L2/Types/Internal.hs new file mode 100644 --- /dev/null +++ b/Graphics/V4L2/Types/Internal.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module Graphics.V4L2.Types.Internal + ( Fraction(..) + , fromFraction + ) where + +import Data.Data (Data) +import Data.Word (Word32) +import Data.Typeable (Typeable) + +import Bindings.Linux.VideoDev2 + +data Fraction = Fraction{ fractionNumerator, fractionDenominator:: Word32 } + deriving (Eq, Ord, Read, Show, Data, Typeable) + +fromFraction :: C'v4l2_fract -> Fraction +fromFraction f = Fraction + { fractionNumerator = c'v4l2_fract'numerator f + , fractionDenominator = c'v4l2_fract'denominator f + } diff --git a/Graphics/V4L2/VideoCapture.hs b/Graphics/V4L2/VideoCapture.hs new file mode 100644 --- /dev/null +++ b/Graphics/V4L2/VideoCapture.hs @@ -0,0 +1,11 @@ +{- | +Module : Graphics.V4L2.VideoCapture +Maintainer : claudiusmaximus@goto10.org +Stability : no +Portability : no +-} +module Graphics.V4L2.VideoCapture + ( module Graphics.V4L2.VideoCapture.Read + ) where + +import Graphics.V4L2.VideoCapture.Read diff --git a/Graphics/V4L2/VideoCapture/Read.hs b/Graphics/V4L2/VideoCapture/Read.hs new file mode 100644 --- /dev/null +++ b/Graphics/V4L2/VideoCapture/Read.hs @@ -0,0 +1,17 @@ +module Graphics.V4L2.VideoCapture.Read + ( withFrame + ) where + +import Foreign (Ptr, allocaBytes) +import Foreign.C (throwErrnoIfMinus1) +import Bindings.LibV4L2 (c'v4l2_read) + +import Graphics.V4L2.Device (Device) +import Graphics.V4L2.Format (ImageFormat, imageSize) + +withFrame :: Device -> ImageFormat -> (Ptr a -> Int -> IO b) -> IO b +withFrame d f a = do + allocaBytes (imageSize f) $ \p -> do + n <- throwErrnoIfMinus1 "Graphics.V4L2.VideoCapture.Read.withFrame" $ + c'v4l2_read (fromIntegral d) p (fromIntegral $ imageSize f) + a p (fromIntegral n) diff --git a/Graphics/V4L2/VideoInput.hs b/Graphics/V4L2/VideoInput.hs new file mode 100644 --- /dev/null +++ b/Graphics/V4L2/VideoInput.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} +{- | +Module : Graphics.V4L2.VideoInput +Maintainer : claudiusmaximus@goto10.org +Stability : no +Portability : no +-} +module Graphics.V4L2.VideoInput + ( VideoInputID() + , VideoInputInfo(..) + , VideoInputType(..) + , VideoInputStatus(..) + , VideoInputCapability(..) + , videoInputs + , getVideoInput + , setVideoInput + ) where + +import Prelude hiding (catch) + +import Control.Exception (catch, throwIO) +import Data.Bits (testBit) +import Data.Data (Data) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.Set as S +import Data.Typeable (Typeable) +import Data.Word (Word32) +import GHC.IO.Exception (IOErrorType(InvalidArgument), ioe_type) + +import Bindings.Linux.VideoDev2 + +import Foreign.Extra.CEnum (fromCEnum) +import Foreign.Extra.BitSet (fromBitSet) +import Foreign.Extra.String (fromString) +import Graphics.V4L2.Device (Device) +import Graphics.V4L2.IOCtl (ioctl, ioctl_, ioctl', zero) +import Graphics.V4L2.VideoStandard (VideoStandard) +import Graphics.V4L2.VideoStandard.Internal (fromVideoStandard) + + +c'V4L2_IN_CAP_PRESETS :: Word32 +c'V4L2_IN_CAP_PRESETS = 1 +c'V4L2_IN_CAP_CUSTOM_TIMINGS :: Word32 +c'V4L2_IN_CAP_CUSTOM_TIMINGS = 2 +c'V4L2_IN_CAP_STD :: Word32 +c'V4L2_IN_CAP_STD = 4 +newtype AudioInputID = AudioInputID Int + deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Typeable, Num, Integral, Real) +newtype TunerID = TunerID Int + deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Typeable, Num, Integral, Real) + +{- | Video input index. -} +newtype VideoInputID = VideoInputID Int + deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Typeable, Num, Integral, Real) + +{- | Video input info. -} +data VideoInputInfo = VideoInputInfo + { videoInputName :: String + , videoInputType :: VideoInputType + , videoInputAudio :: Set AudioInputID + , videoInputTuner :: Set TunerID + , videoInputStandard :: VideoStandard + , videoInputStatus :: Set VideoInputStatus + , videoInputCapability :: Set VideoInputCapability + } + deriving (Eq, Ord, Read, Show, Typeable) + +{- | Video input type. -} +data VideoInputType + = TunerInput + | CameraInput + | UnknownInput Word32 + deriving (Eq, Ord, Read, Show, Data, Typeable) + +fromVideoInputType :: Word32 -> VideoInputType +fromVideoInputType = fromCEnum + [ ( TunerInput , c'V4L2_INPUT_TYPE_TUNER ) + , ( CameraInput , c'V4L2_INPUT_TYPE_CAMERA ) + ] UnknownInput + +{- | Video input status. -} +data VideoInputStatus + = NoPower + | NoSignal + | NoColor + | HFlip + | VFlip + | NoHLock + | ColorKill + | NoSync + | NoEqu + | NoCarrier + | Macrovision + | NoAccess + | Vtr + | UnknownStatus Word32 + deriving (Eq, Ord, Read, Show, Data, Typeable) + +fromVideoInputStatus :: Word32 -> Set VideoInputStatus +fromVideoInputStatus = fromBitSet + [ ( NoPower , c'V4L2_IN_ST_NO_POWER ) + , ( NoSignal , c'V4L2_IN_ST_NO_SIGNAL ) + , ( NoColor , c'V4L2_IN_ST_NO_COLOR ) + , ( HFlip , c'V4L2_IN_ST_HFLIP ) + , ( VFlip , c'V4L2_IN_ST_VFLIP ) + , ( NoHLock , c'V4L2_IN_ST_NO_H_LOCK ) + , ( ColorKill , c'V4L2_IN_ST_COLOR_KILL ) + , ( NoSync , c'V4L2_IN_ST_NO_SYNC ) + , ( NoEqu , c'V4L2_IN_ST_NO_EQU ) + , ( NoCarrier , c'V4L2_IN_ST_NO_CARRIER ) + , ( Macrovision , c'V4L2_IN_ST_MACROVISION ) + , ( NoAccess , c'V4L2_IN_ST_NO_ACCESS ) + , ( Vtr , c'V4L2_IN_ST_VTR ) + ] UnknownStatus + +{- | Video input capabilitites. -} +data VideoInputCapability + = Presets + | CustomTimings + | InputStd + | UnknownCapability Word32 + deriving (Eq, Ord, Read, Show, Data, Typeable) + +fromVideoInputCapability :: Word32 -> Set VideoInputCapability +fromVideoInputCapability = fromBitSet + [ ( Presets , c'V4L2_IN_CAP_PRESETS ) + , ( CustomTimings , c'V4L2_IN_CAP_CUSTOM_TIMINGS ) + , ( InputStd , c'V4L2_IN_CAP_STD ) + ] UnknownCapability + +{- | Enumerate video inputs. -} +videoInputs :: Device -> IO (Map VideoInputID VideoInputInfo) +videoInputs = enuminputs' 0 + +enuminputs' :: VideoInputID -> Device -> IO (Map VideoInputID VideoInputInfo) +enuminputs' n h = do + mi <- (Just `fmap` enuminput h n) `catch` (\e -> case ioe_type e of + InvalidArgument -> return Nothing + _ -> throwIO e) + case mi of + Just i -> M.insert n i `fmap` enuminputs' (n + 1) h + Nothing -> return M.empty + +enuminput :: Device -> VideoInputID -> IO VideoInputInfo +enuminput h n = do + i' <- ioctl h C'VIDIOC_ENUMINPUT =<< return . (\s->s{ c'v4l2_input'index = fromIntegral n }) =<< zero + return (decodeInput i') + +decodeInput :: C'v4l2_input -> VideoInputInfo +decodeInput i = VideoInputInfo + { videoInputName = fromString $ c'v4l2_input'name i + , videoInputType = fromVideoInputType $ c'v4l2_input'type i + , videoInputAudio = S.fromList [ fromIntegral ai | ai <- [0..31], c'v4l2_input'audioset i `testBit` ai ] + , videoInputTuner = S.fromList [ fromIntegral ti | ti <- [0..31], c'v4l2_input'tuner i `testBit` ti ] + , videoInputStandard = fromVideoStandard $ c'v4l2_input'std i + , videoInputStatus = fromVideoInputStatus $ c'v4l2_input'status i + , videoInputCapability = fromVideoInputCapability $ c'v4l2_input'reserved i !! 0 + } + +{- | Query the current video input. + + Exceptions: + + * InvalidArgument - this device has no video inputs +-} +getVideoInput :: Device -> IO VideoInputID +getVideoInput h = fromIntegral `fmap` ioctl' h C'VIDIOC_G_INPUT + +{- | Select the current video input. + + Exceptions: + + * InvalidArgument - no video input with this index + + * ResourceBusy - the video input cannot be switched now +-} +setVideoInput :: Device -> VideoInputID -> IO () +setVideoInput h i = ioctl_ h C'VIDIOC_S_INPUT (fromIntegral i) diff --git a/Graphics/V4L2/VideoStandard.hs b/Graphics/V4L2/VideoStandard.hs new file mode 100644 --- /dev/null +++ b/Graphics/V4L2/VideoStandard.hs @@ -0,0 +1,11 @@ +{- | +Module : Graphics.V4L2.VideoStandard +Maintainer : claudiusmaximus@goto10.org +Stability : no +Portability : no +-} +module Graphics.V4L2.VideoStandard + ( module Graphics.V4L2.VideoStandard.Internal + ) where + +import Graphics.V4L2.VideoStandard.Internal hiding (fromVideoStandard) diff --git a/Graphics/V4L2/VideoStandard/Internal.hs b/Graphics/V4L2/VideoStandard/Internal.hs new file mode 100644 --- /dev/null +++ b/Graphics/V4L2/VideoStandard/Internal.hs @@ -0,0 +1,303 @@ +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} +{- | +Module : Graphics.V4L2.VideoStandard.Internal +Maintainer : claudiusmaximus@goto10.org +Stability : no +Portability : no +-} +module Graphics.V4L2.VideoStandard.Internal + ( VideoStandardID() + , VideoStandardInfo(..) + , videoStandards + , getVideoStandard + , setVideoStandard + , detectVideoStandard + -- predefined standards + , VideoStandard + , VideoStandardType(..) + , videoStandardPalB + , videoStandardPalB1 + , videoStandardPalG + , videoStandardPalH + , videoStandardPalI + , videoStandardPalD + , videoStandardPalD1 + , videoStandardPalK + , videoStandardPalM + , videoStandardPalN + , videoStandardPalNc + , videoStandardPal60 + , videoStandardNtscM + , videoStandardNtscM_JP + , videoStandardNtsc443 + , videoStandardNtscM_KR + , videoStandardSecamB + , videoStandardSecamD + , videoStandardSecamG + , videoStandardSecamH + , videoStandardSecamK + , videoStandardSecamK1 + , videoStandardSecamL + , videoStandardSecamLC + , videoStandardAtsc8Vsb + , videoStandardAtsc16Vsb + , videoStandardMn + , videoStandardB + , videoStandardGh + , videoStandardDk + , videoStandardPalBg + , videoStandardPalDk + , videoStandardPal + , videoStandardNtsc + , videoStandardSecamDk + , videoStandardSecam + , videoStandard525_60 + , videoStandard625_50 + , videoStandardAtsc + , videoStandardUnknown + , videoStandardAll + -- + , fromVideoStandard + ) where + +import Prelude hiding (catch) + +import Control.Exception (catch, throwIO) +import Data.Data (Data) +import Data.Set (Set) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Typeable (Typeable) +import Data.Word (Word64) +import GHC.IO.Exception (IOErrorType(InvalidArgument), ioe_type) + +import Bindings.Linux.VideoDev2 + +import Foreign.Extra.BitSet (fromBitSet, toBitSet) +import Foreign.Extra.String (fromString) +import Graphics.V4L2.Device (Device) +import Graphics.V4L2.IOCtl (ioctl, ioctl_, ioctl', zero) +import Graphics.V4L2.Types (Fraction) +import Graphics.V4L2.Types.Internal (fromFraction) + +type VideoStandard = Set VideoStandardType + +{- | Elementary video standard flags. -} +data VideoStandardType + = StdPalB + | StdPalB1 + | StdPalG + | StdPalH + | StdPalI + | StdPalD + | StdPalD1 + | StdPalK + | StdPalM + | StdPalN + | StdPalNc + | StdPal60 + | StdNtscM + | StdNtscMJp + | StdNtsc443 + | StdNtscMKr + | StdSecamB + | StdSecamD + | StdSecamG + | StdSecamH + | StdSecamK + | StdSecamK1 + | StdSecamL + | StdSecamLC + | StdAtsc8Vsb + | StdAtsc16Vsb + | StdUnknown Word64 + deriving (Eq, Ord, Read, Show, Data, Typeable) + +{- | internal -} +fromVideoStandard :: Word64 -> VideoStandard +toVideoStandard :: VideoStandard -> Word64 +(fromVideoStandard, toVideoStandard) = (fromBitSet spec StdUnknown, toBitSet spec isStdUnknown unStdUnknown) where + spec = + [ ( StdPalB , c'V4L2_STD_PAL_B ) + , ( StdPalB1 , c'V4L2_STD_PAL_B1 ) + , ( StdPalG , c'V4L2_STD_PAL_G ) + , ( StdPalH , c'V4L2_STD_PAL_H ) + , ( StdPalI , c'V4L2_STD_PAL_I ) + , ( StdPalD , c'V4L2_STD_PAL_D ) + , ( StdPalD1 , c'V4L2_STD_PAL_D1 ) + , ( StdPalK , c'V4L2_STD_PAL_K ) + , ( StdPalM , c'V4L2_STD_PAL_M ) + , ( StdPalN , c'V4L2_STD_PAL_N ) + , ( StdPalNc , c'V4L2_STD_PAL_Nc ) + , ( StdPal60 , c'V4L2_STD_PAL_60 ) + , ( StdNtscM , c'V4L2_STD_NTSC_M ) + , ( StdNtscMJp , c'V4L2_STD_NTSC_M_JP ) + , ( StdNtsc443 , c'V4L2_STD_NTSC_443 ) + , ( StdNtscMKr , c'V4L2_STD_NTSC_M_KR ) + , ( StdSecamB , c'V4L2_STD_SECAM_B ) + , ( StdSecamD , c'V4L2_STD_SECAM_D ) + , ( StdSecamG , c'V4L2_STD_SECAM_G ) + , ( StdSecamH , c'V4L2_STD_SECAM_H ) + , ( StdSecamK , c'V4L2_STD_SECAM_K ) + , ( StdSecamK1 , c'V4L2_STD_SECAM_K1 ) + , ( StdSecamL , c'V4L2_STD_SECAM_L ) + , ( StdSecamLC , c'V4L2_STD_SECAM_LC ) + , ( StdAtsc8Vsb , c'V4L2_STD_ATSC_8_VSB ) + , ( StdAtsc16Vsb , c'V4L2_STD_ATSC_16_VSB ) + ] + isStdUnknown (StdUnknown _) = True + isStdUnknown _ = False + unStdUnknown (StdUnknown x) = x + unStdUnknown _ = error "Graphics.V4L2.Video.Standard.Internal.toVideoStandard.unUnknown" + +videoStandardPalB :: VideoStandard +videoStandardPalB1 :: VideoStandard +videoStandardPalG :: VideoStandard +videoStandardPalH :: VideoStandard +videoStandardPalI :: VideoStandard +videoStandardPalD :: VideoStandard +videoStandardPalD1 :: VideoStandard +videoStandardPalK :: VideoStandard +videoStandardPalM :: VideoStandard +videoStandardPalN :: VideoStandard +videoStandardPalNc :: VideoStandard +videoStandardPal60 :: VideoStandard + +videoStandardNtscM :: VideoStandard +videoStandardNtscM_JP :: VideoStandard +videoStandardNtsc443 :: VideoStandard +videoStandardNtscM_KR :: VideoStandard + +videoStandardSecamB :: VideoStandard +videoStandardSecamD :: VideoStandard +videoStandardSecamG :: VideoStandard +videoStandardSecamH :: VideoStandard +videoStandardSecamK :: VideoStandard +videoStandardSecamK1 :: VideoStandard +videoStandardSecamL :: VideoStandard +videoStandardSecamLC :: VideoStandard + +videoStandardAtsc8Vsb :: VideoStandard +videoStandardAtsc16Vsb :: VideoStandard + +videoStandardMn :: VideoStandard +videoStandardB :: VideoStandard +videoStandardGh :: VideoStandard +videoStandardDk :: VideoStandard +videoStandardPalBg :: VideoStandard +videoStandardPalDk :: VideoStandard +videoStandardPal :: VideoStandard +videoStandardNtsc :: VideoStandard +videoStandardSecamDk :: VideoStandard +videoStandardSecam :: VideoStandard +videoStandard525_60 :: VideoStandard +videoStandard625_50 :: VideoStandard +videoStandardAtsc :: VideoStandard +videoStandardUnknown :: VideoStandard +videoStandardAll :: VideoStandard + +videoStandardPalB = fromVideoStandard c'V4L2_STD_PAL_B +videoStandardPalB1 = fromVideoStandard c'V4L2_STD_PAL_B1 +videoStandardPalG = fromVideoStandard c'V4L2_STD_PAL_G +videoStandardPalH = fromVideoStandard c'V4L2_STD_PAL_H +videoStandardPalI = fromVideoStandard c'V4L2_STD_PAL_I +videoStandardPalD = fromVideoStandard c'V4L2_STD_PAL_D +videoStandardPalD1 = fromVideoStandard c'V4L2_STD_PAL_D1 +videoStandardPalK = fromVideoStandard c'V4L2_STD_PAL_K +videoStandardPalM = fromVideoStandard c'V4L2_STD_PAL_M +videoStandardPalN = fromVideoStandard c'V4L2_STD_PAL_N +videoStandardPalNc = fromVideoStandard c'V4L2_STD_PAL_Nc +videoStandardPal60 = fromVideoStandard c'V4L2_STD_PAL_60 + +videoStandardNtscM = fromVideoStandard c'V4L2_STD_NTSC_M +videoStandardNtscM_JP = fromVideoStandard c'V4L2_STD_NTSC_M_JP +videoStandardNtsc443 = fromVideoStandard c'V4L2_STD_NTSC_443 +videoStandardNtscM_KR = fromVideoStandard c'V4L2_STD_NTSC_M_KR + +videoStandardSecamB = fromVideoStandard c'V4L2_STD_SECAM_B +videoStandardSecamD = fromVideoStandard c'V4L2_STD_SECAM_D +videoStandardSecamG = fromVideoStandard c'V4L2_STD_SECAM_G +videoStandardSecamH = fromVideoStandard c'V4L2_STD_SECAM_H +videoStandardSecamK = fromVideoStandard c'V4L2_STD_SECAM_K +videoStandardSecamK1 = fromVideoStandard c'V4L2_STD_SECAM_K1 +videoStandardSecamL = fromVideoStandard c'V4L2_STD_SECAM_L +videoStandardSecamLC = fromVideoStandard c'V4L2_STD_SECAM_LC + +videoStandardAtsc8Vsb = fromVideoStandard c'V4L2_STD_ATSC_8_VSB +videoStandardAtsc16Vsb = fromVideoStandard c'V4L2_STD_ATSC_16_VSB + +-- derived standards +videoStandardMn = fromVideoStandard c'V4L2_STD_MN +videoStandardB = fromVideoStandard c'V4L2_STD_B +videoStandardGh = fromVideoStandard c'V4L2_STD_GH +videoStandardDk = fromVideoStandard c'V4L2_STD_DK +videoStandardPalBg = fromVideoStandard c'V4L2_STD_PAL_BG +videoStandardPalDk = fromVideoStandard c'V4L2_STD_PAL_DK +videoStandardPal = fromVideoStandard c'V4L2_STD_PAL +videoStandardNtsc = fromVideoStandard c'V4L2_STD_NTSC +videoStandardSecamDk = fromVideoStandard c'V4L2_STD_SECAM_DK +videoStandardSecam = fromVideoStandard c'V4L2_STD_SECAM +videoStandard525_60 = fromVideoStandard c'V4L2_STD_525_60 +videoStandard625_50 = fromVideoStandard c'V4L2_STD_625_50 +videoStandardAtsc = fromVideoStandard c'V4L2_STD_ATSC +videoStandardUnknown = fromVideoStandard c'V4L2_STD_UNKNOWN +videoStandardAll = fromVideoStandard c'V4L2_STD_ALL + + +newtype VideoStandardID = VideoStandardID Int + deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Typeable, Num, Integral, Real) + +data VideoStandardInfo = VideoStandardInfo + { videoStandardStandard :: VideoStandard + , videoStandardName :: String + , videoStandardFramePeriod :: Fraction + , videoStandardFrameLines :: Int + } + deriving (Eq, Ord, Read, Show, Data, Typeable) + +{- | Enumerate video standards. + + Drivers may enumerate a different set of standards after + switching the video input or output. +-} +videoStandards :: Device -> IO (Map VideoStandardID VideoStandardInfo) +videoStandards = enumstds' 0 + +enumstds' :: VideoStandardID -> Device -> IO (Map VideoStandardID VideoStandardInfo) +enumstds' n h = do + mi <- (Just `fmap` enumstd h n) `catch` (\e -> case ioe_type e of + InvalidArgument -> return Nothing + _ -> throwIO e) + case mi of + Just i -> M.insert n i `fmap` enumstds' (n + 1) h + Nothing -> return M.empty + +enumstd :: Device -> VideoStandardID -> IO VideoStandardInfo +enumstd h n = do + i' <- ioctl h C'VIDIOC_ENUMSTD =<< return . (\s->s{ c'v4l2_standard'index = fromIntegral n }) =<< zero + return (decodeStandard i') + +decodeStandard :: C'v4l2_standard -> VideoStandardInfo +decodeStandard i = VideoStandardInfo + { videoStandardStandard = fromVideoStandard $ c'v4l2_standard'id i + , videoStandardName = fromString $ c'v4l2_standard'name i + , videoStandardFramePeriod = fromFraction $ c'v4l2_standard'frameperiod i + , videoStandardFrameLines = fromIntegral $ c'v4l2_standard'framelines i + } + +{- | Get the current video standard. -} +getVideoStandard :: Device -> IO VideoStandard +getVideoStandard d = do + s <- ioctl' d C'VIDIOC_G_STD + return (fromVideoStandard s) + +{- | Set the current video standard. -} +setVideoStandard :: Device -> VideoStandard -> IO () +setVideoStandard d s = do + ioctl_ d C'VIDIOC_S_STD (toVideoStandard s) + +{- | Detect the current video standard. -} +detectVideoStandard :: Device -> IO VideoStandard +detectVideoStandard d = do + s <- ioctl' d C'VIDIOC_QUERYSTD + return (fromVideoStandard s) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2011, Claude Heiland-Allen + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Claude Heiland-Allen nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/TODO b/TODO new file mode 100644 --- /dev/null +++ b/TODO @@ -0,0 +1,66 @@ +Device V4L2 close() — Close a V4L2 device +(IOCtl) V4L2 ioctl() — Program a V4L2 device + ioctl VIDIOC_CROPCAP — Information about the video cropping and scaling abilities + ioctl VIDIOC_DBG_G_CHIP_IDENT — Identify the chips on a TV card + ioctl VIDIOC_DBG_G_REGISTER, VIDIOC_DBG_S_REGISTER — Read or write hardware registers + ioctl VIDIOC_DQEVENT — Dequeue event + ioctl VIDIOC_ENCODER_CMD, VIDIOC_TRY_ENCODER_CMD — Execute an encoder command + ioctl VIDIOC_ENUMAUDIO — Enumerate audio inputs + ioctl VIDIOC_ENUMAUDOUT — Enumerate audio outputs + ioctl VIDIOC_ENUM_DV_PRESETS — Enumerate supported Digital Video presets +Format ioctl VIDIOC_ENUM_FMT — Enumerate image formats +Format ioctl VIDIOC_ENUM_FRAMESIZES — Enumerate frame sizes +Format ioctl VIDIOC_ENUM_FRAMEINTERVALS — Enumerate frame intervals +VideoInput ioctl VIDIOC_ENUMINPUT — Enumerate video inputs + ioctl VIDIOC_ENUMOUTPUT — Enumerate video outputs +VideoStandard ioctl VIDIOC_ENUMSTD — Enumerate supported video standards + ioctl VIDIOC_G_AUDIO, VIDIOC_S_AUDIO — Query or select the current audio input and its attributes + ioctl VIDIOC_G_AUDOUT, VIDIOC_S_AUDOUT — Query or select the current audio output + ioctl VIDIOC_G_CROP, VIDIOC_S_CROP — Get or set the current cropping rectangle +Control ioctl VIDIOC_G_CTRL, VIDIOC_S_CTRL — Get or set the value of a control + ioctl VIDIOC_G_DV_PRESET, VIDIOC_S_DV_PRESET — Query or select the DV preset of the current input or output + ioctl VIDIOC_G_DV_TIMINGS, VIDIOC_S_DV_TIMINGS — Get or set custom DV timings for input or output + ioctl VIDIOC_G_ENC_INDEX — Get meta data about a compressed video stream + ioctl VIDIOC_G_EXT_CTRLS, VIDIOC_S_EXT_CTRLS, VIDIOC_TRY_EXT_CTRLS — Get or set the value of several controls, try control values + ioctl VIDIOC_G_FBUF, VIDIOC_S_FBUF — Get or set frame buffer overlay parameters +Format pix ioctl VIDIOC_G_FMT, VIDIOC_S_FMT, VIDIOC_TRY_FMT — Get or set the data format, try a format + pixmp ioctl VIDIOC_G_FMT, VIDIOC_S_FMT, VIDIOC_TRY_FMT — Get or set the data format, try a format + win ioctl VIDIOC_G_FMT, VIDIOC_S_FMT, VIDIOC_TRY_FMT — Get or set the data format, try a format + vbi ioctl VIDIOC_G_FMT, VIDIOC_S_FMT, VIDIOC_TRY_FMT — Get or set the data format, try a format + svbi ioctl VIDIOC_G_FMT, VIDIOC_S_FMT, VIDIOC_TRY_FMT — Get or set the data format, try a format + raw ioctl VIDIOC_G_FMT, VIDIOC_S_FMT, VIDIOC_TRY_FMT — Get or set the data format, try a format + ioctl VIDIOC_G_FREQUENCY, VIDIOC_S_FREQUENCY — Get or set tuner or modulator radio frequency +VideoInput ioctl VIDIOC_G_INPUT, VIDIOC_S_INPUT — Query or select the current video input + ioctl VIDIOC_G_JPEGCOMP, VIDIOC_S_JPEGCOMP + ioctl VIDIOC_G_MODULATOR, VIDIOC_S_MODULATOR — Get or set modulator attributes + ioctl VIDIOC_G_OUTPUT, VIDIOC_S_OUTPUT — Query or select the current video output + ioctl VIDIOC_G_PARM, VIDIOC_S_PARM — Get or set streaming parameters +Priority ioctl VIDIOC_G_PRIORITY, VIDIOC_S_PRIORITY — Query or request the access priority associated with a file descriptor + ioctl VIDIOC_G_SLICED_VBI_CAP — Query sliced VBI capabilities +VideoStandard ioctl VIDIOC_G_STD, VIDIOC_S_STD — Query or select the video standard of the current input + ioctl VIDIOC_G_TUNER, VIDIOC_S_TUNER — Get or set tuner attributes + ioctl VIDIOC_LOG_STATUS — Log driver status information + ioctl VIDIOC_OVERLAY — Start or stop video overlay + ioctl VIDIOC_QBUF, VIDIOC_DQBUF — Exchange a buffer with the driver + ioctl VIDIOC_QUERYBUF — Query the status of a buffer +Capability ioctl VIDIOC_QUERYCAP — Query device capabilities +Control ioctl VIDIOC_QUERYCTRL, VIDIOC_QUERYMENU — Enumerate controls and menu control items + ioctl VIDIOC_QUERY_DV_PRESET — Sense the DV preset received by the current input +VideoStandard ioctl VIDIOC_QUERYSTD — Sense the video standard received by the current input + ioctl VIDIOC_REQBUFS — Initiate Memory Mapping or User Pointer I/O + ioctl VIDIOC_S_HW_FREQ_SEEK — Perform a hardware frequency seek + ioctl VIDIOC_STREAMON, VIDIOC_STREAMOFF — Start or stop streaming I/O + ioctl VIDIOC_SUBDEV_ENUM_FRAME_INTERVAL — Enumerate frame intervals + ioctl VIDIOC_SUBDEV_ENUM_FRAME_SIZE — Enumerate media bus frame sizes + ioctl VIDIOC_SUBDEV_ENUM_MBUS_CODE — Enumerate media bus formats + ioctl VIDIOC_SUBDEV_G_CROP, VIDIOC_SUBDEV_S_CROP — Get or set the crop rectangle on a subdev pad + ioctl VIDIOC_SUBDEV_G_FMT, VIDIOC_SUBDEV_S_FMT — Get or set the data format on a subdev pad + ioctl VIDIOC_SUBDEV_G_FRAME_INTERVAL, VIDIOC_SUBDEV_S_FRAME_INTERVAL — Get or set the frame interval on a subdev pad + ioctl VIDIOC_SUBSCRIBE_EVENT, VIDIOC_UNSUBSCRIBE_EVENT — Subscribe or unsubscribe event + V4L2 mmap() — Map device memory into application address space + V4L2 munmap() — Unmap device memory +Device V4L2 open() — Open a V4L2 device + V4L2 poll() — Wait for some event on a file descriptor +VideoCapture.Read V4L2 read() — Read from a V4L2 device + V4L2 select() — Synchronous I/O multiplexing + V4L2 write() — Write to a V4L2 device diff --git a/v4l2.cabal b/v4l2.cabal new file mode 100644 --- /dev/null +++ b/v4l2.cabal @@ -0,0 +1,64 @@ +Name: v4l2 +Version: 0.1 +Synopsis: interface to Video For Linux Two (V4L2) +Description: + Higher-level interface to V4L2. + +Homepage: https://gitorious.org/hsv4l2 + +License: BSD3 +License-file: LICENSE +Author: Claude Heiland-Allen +Maintainer: claudiusmaximus@goto10.org +Category: Graphics + +Build-type: Simple +Cabal-version: >=1.6 + +Extra-source-files: TODO + +Library + Exposed-modules: + Graphics.V4L2, + Graphics.V4L2.Device, + Graphics.V4L2.Capability, + Graphics.V4L2.Priority, + Graphics.V4L2.Control, + Graphics.V4L2.Field, + Graphics.V4L2.PixelFormat, + Graphics.V4L2.ColorSpace, + Graphics.V4L2.Format, + Graphics.V4L2.VideoInput, + Graphics.V4L2.VideoStandard, + Graphics.V4L2.VideoCapture, + Graphics.V4L2.VideoCapture.Read, + Graphics.V4L2.Types + Other-modules: + Foreign.Extra.BitSet, + Foreign.Extra.CEnum, + Foreign.Extra.String, + Graphics.V4L2.IOCtl, + Graphics.V4L2.Field.Internal, + Graphics.V4L2.PixelFormat.Internal, + Graphics.V4L2.ColorSpace.Internal, + Graphics.V4L2.VideoStandard.Internal, + Graphics.V4L2.Types.Internal + Build-depends: + base >= 3 && < 5, + containers >= 0.3 && < 0.5, + bindings-DSL >= 1.0.7 && < 1.1, + bindings-libv4l2 >= 0.1 && < 0.2, + bindings-linux-videodev2 >= 0.1 && < 0.2, + bindings-posix >= 1.2.3 && < 1.3, + ioctl >= 0.0 && < 0.1 + ghc-options: -Wall + build-tools: hsc2hs + +source-repository head + type: git + location: git://gitorious.org/hsv4l2/v4l2.git + +source-repository this + type: git + location: git://gitorious.org/hsv4l2/v4l2.git + tag: v0.1