documentation
[hsv4l2:phischus-v4l2.git] / Graphics / V4L2.hs
1 {-# LANGUAGE DeriveDataTypeable, ForeignFunctionInterface, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TemplateHaskell, TypeSynonymInstances #-}
2 {- |
3 Module      : Graphics.V4L2
4 Maintainer  : claudiusmaximus@goto10.org
5 Stability   : no
6 Portability : no
7 -}
8 module Graphics.V4L2 (
9   -- * Device access.
10     V4L2()
11   , open
12   , close
13   -- * Device capabilities.
14   , isV4L2
15   , Version
16   , DeviceInfo(..)
17   , Capability(..)
18   , querycap
19   -- * Video inputs.
20   , Input(..)
21   , InputType(..)
22   , InputStatus(..)
23   , InputCapability(..)
24   , enuminput
25   , enuminputs
26   -- ** Video input selection.
27   , InputIndex
28   , ginput
29   , sinput
30   -- * Video standards.
31   , VideoStandard(..)
32   -- * Audio inputs.
33   , AudioIndex
34   -- * Tuners.
35   , TunerIndex
36   -- * Exceptions
37   , V4L2Bug(..)
38   ) where
39 import Prelude hiding (catch)
40 import Foreign
41 import Foreign.C
42 import Foreign.Helper
43 import Control.Exception
44 import GHC.IO.Exception (IOErrorType(InvalidArgument, ResourceBusy), ioe_type)
45 import System.Posix.Types (Fd(Fd), CMode)
46 import System.Posix.IOCtl
47 import Data.Set (Set, empty, fromList)
48 import Data.Word (Word8, Word32, Word64)
49 import Data.Bits (shiftR, (.&.), testBit)
50 import Data.Maybe (fromMaybe)
51 import Bindings.Linux.VideoDev2
52 import Bindings.LibV4L2
53
54 foreign import ccall "string.h memset" c'memset :: Ptr a -> CInt -> CSize -> IO (Ptr a)
55
56 {- | Device capabilities flags. -}
57 enum "Capability" "Word32" "c'V4L2_CAP_" "" $ words "VIDEO_CAPTURE VIDEO_OUTPUT VIDEO_OVERLAY VBI_CAPTURE VBI_OUTPUT SLICED_VBI_CAPTURE SLICED_VBI_OUTPUT RDS_CAPTURE VIDEO_OUTPUT_OVERLAY HW_FREQ_SEEK RDS_OUTPUT TUNER AUDIO RADIO MODULATOR READWRITE ASYNCIO STREAMING TIMEPERFRAME"
58 instance FBits Capability Word32 where
59
60 {- | Input type identifiers. -}
61 enum "InputType" "Word32" "c'V4L2_INPUT_TYPE_" "Input" $ words "TUNER CAMERA"
62
63 {- | Input status flags. -}
64 enum "InputStatus" "Word32" "c'V4L2_IN_ST_" "" $ words "NO_POWER NO_SIGNAL NO_COLOR HFLIP VFLIP NO_H_LOCK COLOR_KILL NO_SYNC NO_EQU NO_CARRIER MACROVISION NO_ACCESS VTR"
65 instance FBits InputStatus Word32 where
66
67 c'V4L2_IN_CAP_PRESETS = 1
68 c'V4L2_IN_CAP_CUSTOM_TIMINGS = 2
69 c'V4L2_IN_CAP_STD = 4
70
71 {- | Input capability flags. -}
72 enum "InputCapability" "Word32" "c'V4L2_IN_CAP_" "" $ words "PRESETS CUSTOM_TIMINGS STD"
73 instance FBits InputCapability Word32
74
75 {- | Video standard flags. -}
76 enum "VideoStandard" "Word64" "c'V4L2_STD_" "" $ words "PAL_B PAL_B1 PAL_G PAL_H PAL_I PAL_D PAL_D1 PAL_K PAL_M PAL_N PAL_Nc PAL_60 NTSC_M NTSC_M_JP NTSC_443 NTSC_M_KR SECAM_B SECAM_D SECAM_G SECAM_H SECAM_K SECAM_K1 SECAM_L SECAM_LC ATSC_8_VSB ATSC_16_VSB"
77 instance FBits VideoStandard Word64
78
79 c'O_RDRW = 3
80
81 {- | Opaque device handle. -}
82 newtype V4L2 = V4L2 Fd
83
84 {- | Open a device. -}
85 open :: FilePath -> IO V4L2
86 open f = withCString f $ \s -> do
87   h <- throwErrnoIfMinus1 "Graphics.V4L2.open" (c'v4l2_open s c'O_RDRW 0)
88   return (V4L2 (Fd h))
89
90 {- | Close a device. -}
91 close :: V4L2 -> IO ()
92 close (V4L2 (Fd h)) = throwErrnoIfMinus1_ "Graphics.V4L2.close" (c'v4l2_close h)
93
94 {- | Check that the opened device really is a V4L2 device. -}
95 isV4L2 :: V4L2 -> IO Bool
96 isV4L2 h = (querycap h >> return True) `catch` (\e -> case ioe_type e of
97   InvalidArgument -> return False
98   _ -> throwIO e)
99
100 {- | Query device capabilities.
101
102      Exceptions:
103        * InvalidArgument - not a V4L2 device
104 -}
105 querycap :: V4L2 -> IO (DeviceInfo, Set Capability)
106 querycap (V4L2 h) = do
107   c <- ioctl' h C'VIDIOC_QUERYCAP
108   return
109     ( DeviceInfo
110         { driver = decodeString $ c'v4l2_capability'driver c
111         , card = decodeString $ c'v4l2_capability'card c
112         , bus = decodeString $ c'v4l2_capability'bus_info c
113         , version = decodeVersion $ c'v4l2_capability'version c
114         }
115     , decodeCapabilities $ c'v4l2_capability'capabilities c
116     )
117
118 decodeString :: [Word8] -> String
119 decodeString = map (toEnum . fromEnum) . takeWhile (/= 0) -- FIXME
120
121 decodeVersion :: Word32 -> Version
122 decodeVersion v = (fromIntegral $ (v `shiftR` 16) .&. 0xFF, fromIntegral $ (v `shiftR` 8) .&. 0xFF, fromIntegral $ v .&. 0xFF)
123
124 decodeCapabilities :: Word32 -> Set Capability
125 decodeCapabilities = maybe empty id . fromFBits
126
127 {- | API version identifier. -}
128 type Version = (Int, Int, Int)
129
130 {- | Video device information. -}
131 data DeviceInfo = DeviceInfo{ driver, card, bus :: String, version :: Version }
132   deriving Show
133
134 {- | Video input index. -}
135 newtype InputIndex = InputIndex Int
136   deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Typeable, Num, Integral, Real)
137
138 {- | Audio input index. -}
139 newtype AudioIndex = AudioIndex Int
140   deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Typeable, Num, Integral, Real)
141
142 {- | Tuner index. -}
143 newtype TunerIndex = TunerIndex Int
144   deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Typeable, Num, Integral, Real)
145
146 {- | Enumerate video inputs.
147
148      Exceptions:
149        * InvalidArgument - input index out of range
150 -}
151 enuminput :: V4L2 -> InputIndex -> IO Input
152 enuminput (V4L2 h) n = do
153   i' <- ioctl h C'VIDIOC_ENUMINPUT =<< return . (\s->s{ c'v4l2_input'index = fromIntegral n }) =<< zero
154   case decodeInput i' of
155     Just i -> return i
156     Nothing -> throwIO (V4L2BugUnparseableInput i')
157
158 {- | Enumerate video inputs. -}
159 enuminputs :: V4L2 -> IO [Input]
160 enuminputs = enuminputs' 0
161 enuminputs' :: InputIndex -> V4L2 -> IO [Input]
162 enuminputs' n h = do
163   mi <- (Just `fmap` enuminput h n) `catch` (\e -> case ioe_type e of
164     InvalidArgument -> return Nothing
165     _ -> throwIO e)
166   case mi of
167     Just i -> (i:) `fmap` enuminputs' (n + 1) h
168     Nothing -> return []
169
170 {- | Video input. -}
171 data Input = Input
172   { index :: InputIndex
173   , name :: String
174   , itype :: InputType
175   , audioset :: Set AudioIndex
176   , tuner :: Set TunerIndex
177   , std :: Set VideoStandard
178   , status :: Set InputStatus
179   , capabilities :: Set InputCapability
180   }
181   deriving Show
182
183 decodeInput :: C'v4l2_input -> Maybe Input
184 decodeInput i = do
185   itype' <- fromFEnum $ c'v4l2_input'type i
186   std' <- fromFBits $ c'v4l2_input'std i
187   status' <- fromFBits $ c'v4l2_input'status i
188   capabilities' <- fromFBits $ c'v4l2_input'reserved i !! 0
189   return Input
190     { index = fromIntegral $ c'v4l2_input'index i
191     , name = decodeString $ c'v4l2_input'name i
192     , itype = itype'
193     , audioset = fromList [ AudioIndex ai | ai <- [0..31], c'v4l2_input'audioset i `testBit` ai ]
194     , tuner = fromList [ TunerIndex ti | ti <- [0..31], c'v4l2_input'tuner i `testBit` ti ]
195     , std = std'
196     , status = status'
197     , capabilities = capabilities'
198     }
199
200 zero :: Storable a => IO a
201 zero = alloca $ \p -> c'memset p 0 (fromIntegral $ sizeOf (undefined `asTypeOf` unsafePerformIO (peek p))) >> peek p
202
203 {- | Query the current video input.
204
205     Exceptions:
206       * InvalidArgument - this device has no video inputs
207 -}
208 ginput :: V4L2 -> IO InputIndex
209 ginput (V4L2 h) = fromIntegral `fmap` ioctl' h C'VIDIOC_G_INPUT
210
211 {- | Select the current video input.
212
213      Exceptions:
214        * InvalidArgument - no video input with this index
215        * ResourceBusy - the video input cannot be switched now
216 -}
217 sinput :: V4L2 -> InputIndex -> IO ()
218 sinput (V4L2 h) i = ioctl_ h C'VIDIOC_S_INPUT (fromIntegral i)
219
220 {- | Internal errors.  Please report these as bugs. -}
221 data V4L2Bug = V4L2BugUnparseableInput C'v4l2_input
222   deriving (Show, Typeable)
223 instance Exception V4L2Bug