v4l2-examples-0.1.0.2: v4l2-capture/v4l2-capture.hs

module Main (main) where

import Control.Monad (forM_, when)
import Foreign (Ptr)
import System.Environment (getArgs)
import System.Exit (exitFailure)
import System.IO (hPutBuf, hPutStr, hPutStrLn, stdout, stderr)
import System.IO.Error (tryIOError)
import GHC.IO.Exception (IOErrorType(Interrupted), ioe_type)

import Graphics.V4L2

main :: IO ()
main = do
  (devname, verbose) <- checkArgs =<< getArgs
  e <- tryIOError $ withDevice devname $ \d -> do
    f <- setFormat d Capture . (\f->f{ imagePixelFormat = PixelRGB24 }) =<< getFormat d Capture
    checkFormat f
    info $ "frame size: " ++ show (imageWidth f) ++ "x" ++ show (imageHeight f) ++ " pixels (" ++ show (imageSize f) ++ " bytes)"
    forM_ [(0 :: Int) ..] $ \i -> do
      withFrame d f $ \p n -> do
        if n == imageSize f
          then do
            when verbose $ do
              info $ "Frame number " ++ show i
            writePPM (imageWidth f) (imageHeight f) p
          else warn $ "incomplete frame (" ++ show n ++ " bytes, expected " ++ show (imageSize f) ++ " bytes)"
  case e of
    Left f | ioe_type f == Interrupted -> return ()
           | otherwise -> ioError f
    Right () -> return ()

writePPM :: Int -> Int -> Ptr a -> IO ()
writePPM w h p = do
  hPutStr stdout $ "P6\n" ++ show w ++ " " ++ show h ++ " 255\n"
  hPutBuf stdout p (w * h * 3)

checkFormat :: ImageFormat -> IO ()
checkFormat f = do
  when (imagePixelFormat f /= PixelRGB24) $ err "could not set RGB24 pixel format"
  when (imageBytesPerLine f /= imageWidth f * 3) $ err "cannot handle extra padding"
  when (imageSize f /= imageBytesPerLine f * imageHeight f) $ err "cannot handle image size"

-- TODO verbosity flag
checkArgs :: [String] -> IO (String, Bool)
checkArgs [devname] = return (devname, False)
checkArgs _ = err $ "bad arguments; usage: v4l2-capture /dev/video0"

err :: String -> IO a
err msg = (hPutStrLn stderr $ "**ERROR: [v4l2-capture] " ++ msg) >> exitFailure

warn :: String -> IO ()
warn msg = hPutStrLn stderr $ "++ WARN: [v4l2-capture] " ++ msg

info :: String -> IO ()
info msg = hPutStrLn stderr $ "   INFO: [v4l2-capture] " ++ msg