Added MacOS support sources
authorJoachim Breitner <mail@joachim-breitner.de>
Mon, 4 Apr 2016 11:56:42 +0000 (11:56 +0000)
committerJoachim Breitner <mail@joachim-breitner.de>
Mon, 4 Apr 2016 11:56:42 +0000 (11:56 +0000)
accidentially forgotten in the previous patch.

src/Capture/OSX.hs [new file with mode: 0644]
src/Graphics/OSX/Window.hs [new file with mode: 0644]

diff --git a/src/Capture/OSX.hs b/src/Capture/OSX.hs
new file mode 100644 (file)
index 0000000..ba5e2a7
--- /dev/null
@@ -0,0 +1,25 @@
+module Capture.OSX where
+
+import Data
+import qualified Data.MyText as T
+import Control.Monad
+import Control.Applicative
+
+import Graphics.OSX.Window
+
+setupCapture :: IO ()
+setupCapture = do
+        return ()
+
+captureData :: IO CaptureData
+captureData = do
+        titles <- fetchWindowTitles
+        foreground <- getForegroundWindow
+
+        let winData = map (
+                \(h,t,p) -> (h == foreground, T.pack t, T.pack p)
+                ) titles
+
+        it <- fromIntegral `fmap` getIdleTime
+
+        return $ CaptureData winData it (T.pack "")
diff --git a/src/Graphics/OSX/Window.hs b/src/Graphics/OSX/Window.hs
new file mode 100644 (file)
index 0000000..d890d38
--- /dev/null
@@ -0,0 +1,366 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+--------------------------------------------------------------------
+-- |
+-- Module    : Graphics.OSX.Window
+-- Copyright : (c) Vincent Rasneur
+-- License   : GPL2
+--
+-- Maintainer: Vincent Rasneur <vrasneur@free.fr>
+-- Stability : provisional
+-- Portability: unportable
+--
+--------------------------------------------------------------------
+--
+-- Interface to the windows and idle time functions in Mac OS X
+--
+
+module Graphics.OSX.Window
+       ( fetchWindowTitles
+       , getForegroundWindow
+       , getIdleTime
+       ) where
+
+import Control.Monad
+
+import Data.Maybe (fromJust, fromMaybe, isNothing, isJust, catMaybes)
+import Data.Bits (shiftL, (.|.))
+
+import Foreign.C
+import Foreign.Ptr (Ptr, nullPtr, castPtr)
+import Foreign.Marshal.Alloc (alloca, mallocBytes, free)
+import Foreign.Storable (peek)
+
+import System.IO (hPutStrLn, stderr)
+
+-- Core Foundation basic types
+
+type Boolean = CUChar
+bTRUE = 1 :: Boolean
+bFALSE = 0 :: Boolean
+
+type CFTypeID = CULong
+
+type CFIndex = CLong
+
+type CFStringEncoding = CUInt
+
+-- Core Foundation pointer types
+
+data CFType = CFType
+type CFTypeRef = Ptr CFType
+
+data CFNumber = CFNumber
+type CFNumberRef = Ptr CFNumber
+
+data CFString = CFString
+type CFStringRef = Ptr CFString
+
+data CFArray = CFArray
+type CFArrayRef = Ptr CFArray
+
+data CFDictionary = CFDictionary
+type CFDictionaryRef = Ptr CFDictionary
+type CFMutableDictionaryRef = Ptr CFDictionary
+
+data CFAllocator = CFAllocator
+type CFAllocatorRef = Ptr CFAllocator
+
+-- IOKit types
+
+type Ckern_return_t = CInt
+iKERN_SUCCESS = 0 :: Ckern_return_t
+
+type Cmach_port_t = CUInt
+type Cio_object_t = Cmach_port_t
+type Cio_iterator_t = Cio_object_t
+type Cio_registry_entry_t = Cio_object_t
+type CIOOptionBits = CUInt
+
+-- type getter functions
+
+foreign import ccall "CFGetTypeID" c_CFGetTypeID :: CFTypeRef -> IO CFTypeID
+
+foreign import ccall "CFNumberGetTypeID" c_CFNumberGetTypeID :: IO CFTypeID
+foreign import ccall "CFStringGetTypeID" c_CFStringGetTypeID :: IO CFTypeID
+foreign import ccall "CFArrayGetTypeID" c_CFArrayGetTypeID :: IO CFTypeID
+foreign import ccall "CFDictionaryGetTypeID" c_CFDictionaryGetTypeID :: IO CFTypeID
+
+-- memory management functions
+
+foreign import ccall "CFRetain" c_CFRetain :: CFTypeRef -> IO ()
+foreign import ccall "CFRelease" c_CFRelease :: CFTypeRef -> IO ()
+
+-- allocator variables
+
+foreign import ccall "&kCFAllocatorDefault" c_kCFAllocatorDefaultPtr :: Ptr CFAllocatorRef
+foreign import ccall "&kCFAllocatorNull" c_kCFAllocatorNullPtr :: Ptr CFAllocatorRef
+
+c_kCFAllocatorDefault :: IO CFAllocatorRef
+c_kCFAllocatorDefault = peek c_kCFAllocatorDefaultPtr
+
+c_kCFAllocatorNull :: IO CFAllocatorRef
+c_kCFAllocatorNull = peek c_kCFAllocatorNullPtr
+
+-- number functions
+
+kCFNumberSInt64Type = 4 :: CInt
+
+foreign import ccall unsafe "CFNumberGetValue" c_CFNumberGetValue :: CFNumberRef -> CInt -> Ptr a -> IO Boolean
+
+-- string functions
+
+kCFStringEncodingUTF8 = 0x08000100 :: CFStringEncoding
+
+foreign import ccall unsafe "CFStringGetLength" c_CFStringGetLength :: CFStringRef -> IO CFIndex
+foreign import ccall unsafe "CFStringGetMaximumSizeForEncoding" c_CFStringGetMaximumSizeForEncoding :: CFIndex -> CFStringEncoding -> IO CFIndex
+foreign import ccall unsafe "CFStringGetCStringPtr" c_CFStringGetCStringPtr :: CFStringRef -> CFStringEncoding -> IO CString
+foreign import ccall unsafe "CFStringGetCString" c_CFStringGetCString :: CFStringRef -> CString -> CFIndex -> CFStringEncoding -> IO Boolean
+foreign import ccall unsafe "CFStringCreateWithCStringNoCopy" c_CFStringCreateWithCStringNoCopy :: CFAllocatorRef -> CString -> CFStringEncoding -> CFAllocatorRef -> IO CFStringRef
+
+-- array functions
+
+foreign import ccall unsafe "CFArrayGetCount" c_CFArrayGetCount :: CFArrayRef -> IO CLong
+foreign import ccall unsafe "CFArrayGetValueAtIndex" c_CFArrayGetValueAtIndex :: CFArrayRef -> CFIndex -> IO CFTypeRef
+
+-- dictionary functions
+
+foreign import ccall unsafe "CFDictionaryGetValue" c_CFDictionaryGetValue :: CFDictionaryRef -> Ptr a -> IO (Ptr b)
+
+-- window functions
+
+type CGWindowListOption = CUInt
+kCGWindowListOptionOnScreenOnly = (1 `shiftL` 0) :: CGWindowListOption
+kCGWindowListExcludeDesktopElements = (1 `shiftL` 4) :: CGWindowListOption
+
+type CGWindowID = CUInt
+kCGNullWindowID = 0 :: CGWindowID
+
+foreign import ccall unsafe "CGWindowListCopyWindowInfo" c_CGWindowListCopyWindowInfo :: CGWindowListOption -> CGWindowID -> IO CFArrayRef
+
+-- IOKit functions
+
+cMACH_PORT_NULL = 0 :: Cmach_port_t
+
+foreign import ccall unsafe "IOObjectRelease" c_IOObjectRelease :: Cio_object_t -> IO Ckern_return_t
+foreign import ccall unsafe "IOMasterPort" c_IOMasterPort :: Cmach_port_t -> Ptr Cmach_port_t -> IO Ckern_return_t
+foreign import ccall unsafe "IOServiceGetMatchingServices" c_IOServiceGetMatchingServices :: Cmach_port_t -> CFDictionaryRef -> Ptr Cio_iterator_t -> IO Ckern_return_t
+foreign import ccall unsafe "IOServiceMatching" c_IOServiceMatching :: CString -> IO CFMutableDictionaryRef 
+foreign import ccall unsafe "IOIteratorNext" c_IOIteratorNext :: Cio_iterator_t -> IO Cio_object_t
+foreign import ccall unsafe "IORegistryEntryCreateCFProperty" c_IORegistryEntryCreateCFProperty :: Cio_registry_entry_t -> CFStringRef -> CFAllocatorRef -> CIOOptionBits -> IO CFTypeRef
+
+-- misc utilities
+
+cond :: Monad m => Bool -> a -> m a -> m a
+cond True  val  _ = return val
+cond False _    a = a
+
+condM :: Monad m => Bool -> m a -> m a -> m a
+condM True  val _ = val
+condM False _   a = a
+
+condMsg :: Bool -> String -> a -> IO a -> IO a
+condMsg True  msg val _ = hPutStrLn stderr msg >> return val
+condMsg False _   _   a = a
+
+-- type utilities
+
+isTypeRef :: IO CULong -> CFTypeRef -> IO Bool
+isTypeRef typeFun ref = do
+         cond (ref == nullPtr) False $ do
+           typ <- c_CFGetTypeID ref
+           funTyp <- typeFun
+           return (typ == funTyp)
+
+isStringRef :: CFTypeRef -> IO Bool
+isStringRef = isTypeRef c_CFStringGetTypeID
+
+isNumberRef :: CFTypeRef -> IO Bool
+isNumberRef = isTypeRef c_CFNumberGetTypeID
+
+isArrayRef :: CFTypeRef -> IO Bool
+isArrayRef = isTypeRef c_CFArrayGetTypeID
+
+isDictionaryRef :: CFTypeRef -> IO Bool
+isDictionaryRef = isTypeRef c_CFDictionaryGetTypeID
+
+-- string utilities
+
+getConstUTF8String :: CFStringRef -> IO CString
+getConstUTF8String strRef = c_CFStringGetCStringPtr strRef kCFStringEncodingUTF8
+
+createUTF8StringRefNoCopy :: CString -> IO CFStringRef
+createUTF8StringRefNoCopy str = do
+                allocDefault <- c_kCFAllocatorDefault
+                allocNull <- c_kCFAllocatorNull
+                c_CFStringCreateWithCStringNoCopy allocDefault str kCFStringEncodingUTF8 allocNull
+
+-- returns malloc'ed memory (or a NULL pointer)
+getUTF8String :: CFStringRef -> IO CString
+getUTF8String strRef = do
+              length <- c_CFStringGetLength strRef
+              maxSize <- c_CFStringGetMaximumSizeForEncoding length kCFStringEncodingUTF8
+              buffer <- mallocBytes $ (fromIntegral maxSize) + 1
+              res <- c_CFStringGetCString strRef buffer maxSize kCFStringEncodingUTF8
+              cond (res == bTRUE) buffer $ do
+                free buffer
+                return nullPtr
+
+convertString :: CString -> IO (Maybe String)
+convertString str = do
+         cond (str == nullPtr)  Nothing $ do
+           peekCString str >>= return . Just
+
+-- Core Foundation objects conversion
+
+getString :: CFTypeRef -> IO (Maybe String)
+getString ref = isStringRef ref >>= onlyStringRef
+              where
+              onlyStringRef False = return Nothing
+              onlyStringRef True = do
+                let strRef = castPtr ref
+                cstr <- getConstUTF8String strRef
+                condM (cstr /= nullPtr) (convertString cstr) $ do
+                   cstr <- getUTF8String strRef
+                   cond (cstr == nullPtr) Nothing $ do
+                     hstr <- convertString cstr
+                     free cstr
+                     return hstr
+
+getInt :: CFTypeRef -> IO (Maybe Int)
+getInt ref = isNumberRef ref >>= onlyNumberRef
+           where
+           onlyNumberRef False = return Nothing
+           onlyNumberRef True = do
+             let numRef = castPtr ref
+             alloca $ \ptr -> do
+               res <- c_CFNumberGetValue numRef kCFNumberSInt64Type (ptr :: Ptr CLong)
+               condMsg (res == bFALSE)
+                 "Cannot convert Core Foundation number to signed 64-bit integer." Nothing $ do
+                 num <- peek ptr
+                 return $ Just $ fromIntegral num
+
+-- dictionary utilities
+
+getDictFromArray :: CFArrayRef -> CFIndex -> IO (Maybe CFDictionaryRef)
+getDictFromArray arrayRef idx = do
+             ref <- c_CFArrayGetValueAtIndex arrayRef idx
+             isDictionaryRef ref >>= return . onlyDictRef ref
+             where
+             onlyDictRef ref True = Just $ castPtr ref
+             onlyDictRef ref False = Nothing
+
+getDictValue :: CFDictionaryRef -> String -> IO CFTypeRef
+getDictValue dictRef str = do
+              strRef <- createUTF8StringRefNoCopy =<< newCString str
+              condMsg (strRef == nullPtr)
+                ("Cannot convert string '" ++ str ++"' to Core Foundation string.") nullPtr $ do
+                obj <- c_CFDictionaryGetValue dictRef strRef
+                c_CFRelease $ castPtr strRef
+                return obj
+
+-- IOKit utilities
+
+getHIDSystemIterator :: IO Cio_iterator_t
+getHIDSystemIterator = do
+           masterPort <- alloca $ \ptr -> do
+             res <- c_IOMasterPort cMACH_PORT_NULL ptr
+             condMsg (res /= iKERN_SUCCESS)
+               ("Cannot create master port: error " ++ show res ++ ".") 0 $
+               peek ptr
+           condMsg (masterPort == 0)
+             "Got empty master port." 0 $
+             alloca $ \ptr -> do
+               dictRef <- c_IOServiceMatching =<< newCString "IOHIDSystem"
+               condMsg (dictRef == nullPtr)
+                 "Cannot create the IOHIDSystem matching dictionary." 0 $ do
+                 res <- c_IOServiceGetMatchingServices masterPort dictRef ptr
+                 condMsg (res /= iKERN_SUCCESS)
+                   ("Cannot get the iterator handle: error " ++ show res ++ ".") 0 $
+                   peek ptr
+
+getHIDSystemIdleTime :: Cio_registry_entry_t -> IO CFTypeRef
+getHIDSystemIdleTime entry = do
+             cond (entry == 0) nullPtr $ do
+               strRef <- createUTF8StringRefNoCopy =<< newCString "HIDIdleTime"
+               condMsg (strRef == nullPtr)
+                 "Cannot create HIDIdleTime Core Foundation string." nullPtr $ do
+                 allocDefault <- c_kCFAllocatorDefault
+                 ref <- c_IORegistryEntryCreateCFProperty entry strRef allocDefault 0
+                 c_CFRelease $ castPtr strRef
+                 condMsg (ref == nullPtr)
+                   "Cannot create the HIDIdleTime property string." nullPtr $
+                   return ref
+
+withIOObject :: Cio_object_t -> IO Int -> IO Int
+withIOObject obj comp = do
+             condMsg (obj == 0)
+               "Got empty IO object." (-1) $ do
+               res <- comp
+               c_IOObjectRelease obj
+               return res
+
+-- in nanoseconds
+getIdleTimeNs :: IO Int
+getIdleTimeNs = do
+            iter <- getHIDSystemIterator
+            withIOObject iter $ do
+              curObj <- c_IOIteratorNext iter
+              withIOObject curObj $ do
+                idleRef <- getHIDSystemIdleTime curObj
+                getInt idleRef >>= return . fromMaybe (-1)
+
+-- window properties
+
+getWindowInfo :: IO CFArrayRef
+getWindowInfo = do
+              let opts = kCGWindowListExcludeDesktopElements .|. kCGWindowListOptionOnScreenOnly
+              c_CGWindowListCopyWindowInfo opts kCGNullWindowID
+              
+getWindowTitle :: CFArrayRef -> CLong -> IO (Maybe (Int, String, String))
+getWindowTitle info idx = do
+             dict <- getDictFromArray info idx >>= return . fromMaybe nullPtr
+             condMsg (dict == nullPtr)
+               ("Cannot retrieve the properties dictionary for window " ++ show idx ++ ".") Nothing $ do
+               layer <- getDictValue dict "kCGWindowLayer" >>= getInt
+               cond (isNothing layer || fromJust layer /= 0) Nothing $ do
+                 window <- getDictValue dict "kCGWindowName" >>= getString
+                 owner <- getDictValue dict "kCGWindowOwnerName" >>= getString
+                 cond (isNothing window || isNothing owner) Nothing $ do
+                   return $ Just (fromIntegral idx, fromJust window, fromJust owner)
+
+fetchWindowTitles :: IO [(Int, String, String)]
+fetchWindowTitles = do
+                  windowInfo <- getWindowInfo
+                  condMsg (windowInfo == nullPtr)
+                    "Cannot get the windows information array." [] $ do
+                    count <- c_CFArrayGetCount windowInfo
+                    titles <- (forM [0..count - 1] $ getWindowTitle windowInfo) >>= return . catMaybes
+                    c_CFRelease $ castPtr windowInfo
+                    return titles
+
+getWindowIdx :: Maybe (Int, String, String) -> Maybe Int
+getWindowIdx Nothing = Nothing
+getWindowIdx (Just (idleTime, _, _)) = Just idleTime
+
+getForegroundWindowIdx :: CFArrayRef -> CLong -> CLong -> IO (Maybe Int)
+getForegroundWindowIdx info idx count = do
+                  cond (count == 0) Nothing $ do
+                    title <- getWindowTitle info idx
+                    cond (isJust title) (getWindowIdx title) $
+                      getForegroundWindowIdx info (idx + 1) (count - 1)
+
+getForegroundWindow :: IO Int
+getForegroundWindow = do
+                    windowInfo <- getWindowInfo
+                    condMsg (windowInfo == nullPtr)
+                      "Cannot get the windows information array." (-1) $ do
+                      count <- c_CFArrayGetCount windowInfo
+                      idx <- getForegroundWindowIdx windowInfo 0 count
+                      c_CFRelease $ castPtr windowInfo
+                      return $ fromMaybe (-1) idx
+
+-- idle time
+
+-- in milliseconds
+getIdleTime :: IO Integer
+getIdleTime = getIdleTimeNs >>= return . \idleTime -> quot (fromIntegral idleTime) 1000000