diff --git a/arbtt.cabal b/arbtt.cabal --- a/arbtt.cabal +++ b/arbtt.cabal @@ -1,5 +1,5 @@ name: arbtt -version: 0.9.0.8 +version: 0.9.0.9 license: GPL license-file: LICENSE category: Desktop @@ -40,11 +40,11 @@ main-is: capture-main.hs hs-source-dirs: src build-depends: - base == 4.7.* || == 4.8.*, - filepath, directory, transformers, utf8-string, - aeson >= 0.6 && < 0.12, - binary >= 0.5, - bytestring, deepseq + base >= 4.7 && < 4.10, + filepath, directory, transformers, utf8-string, + aeson >= 0.6 && < 0.12, + binary >= 0.5, + bytestring, deepseq if flag(old-locale) build-depends: time == 1.4.*, old-locale @@ -77,20 +77,28 @@ build-depends: Win32 else - extra-libraries: Xss - other-modules: - Capture.X11 - Graphics.X11.XScreenSaver - System.Locale.SetLocale - build-depends: - X11 > 1.4.4 + if os(darwin) + cpp-options: -DDARWIN + frameworks: Foundation Carbon IOKit + other-modules: + Capture.OSX + Graphics.OSX.Window + System.Locale.SetLocale + else + extra-libraries: Xss + other-modules: + Capture.X11 + Graphics.X11.XScreenSaver + System.Locale.SetLocale + build-depends: + X11 > 1.4.4 default-language: Haskell98 executable arbtt-stats main-is: stats-main.hs hs-source-dirs: src build-depends: - base == 4.7.* || == 4.8.*, + base >= 4.7 && < 4.10, parsec == 3.*, containers == 0.5.*, pcre-light, @@ -134,7 +142,7 @@ main-is: dump-main.hs hs-source-dirs: src build-depends: - base == 4.7.* || == 4.8.*, + base >= 4.7 && < 4.10, parsec == 3.*, containers == 0.5.*, aeson >= 0.6 && < 0.12, @@ -171,7 +179,7 @@ main-is: import-main.hs hs-source-dirs: src build-depends: - base == 4.7.* || == 4.8.*, + base >= 4.7 && < 4.10, parsec == 3.*, containers == 0.5.*, binary >= 0.5, @@ -204,7 +212,7 @@ main-is: recover-main.hs hs-source-dirs: src build-depends: - base == 4.7.* || == 4.8.*, + base >= 4.7 && < 4.10, containers == 0.5.*, binary >= 0.5, deepseq, bytestring, utf8-string, @@ -241,11 +249,11 @@ Main-is: test.hs Build-depends: - base == 4.7.* || == 4.8.* + base >= 4.7 && < 4.10 , tasty >= 0.7 && < 0.12 , tasty-golden >= 2.2.0.2 && <= 2.4 , tasty-hunit >= 0.2 && < 0.11 - , process-extras == 0.2.* || == 0.3.* + , process-extras == 0.2.* || == 0.3.* || == 0.4.* , deepseq , binary >= 0.5 , bytestring diff --git a/src/Capture.hs b/src/Capture.hs --- a/src/Capture.hs +++ b/src/Capture.hs @@ -1,15 +1,19 @@ {-# LANGUAGE CPP #-} module Capture ( -#ifdef WIN32 +#if defined(WIN32) module Capture.Win32 +#elif defined(DARWIN) + module Capture.OSX #else module Capture.X11 #endif ) where -#ifdef WIN32 +#if defined(WIN32) import Capture.Win32 +#elif defined(DARWIN) +import Capture.OSX #else import Capture.X11 #endif diff --git a/src/Capture/OSX.hs b/src/Capture/OSX.hs new file mode 100644 --- /dev/null +++ b/src/Capture/OSX.hs @@ -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 --- /dev/null +++ b/src/Graphics/OSX/Window.hs @@ -0,0 +1,366 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +-------------------------------------------------------------------- +-- | +-- Module : Graphics.OSX.Window +-- Copyright : (c) Vincent Rasneur +-- License : GPL2 +-- +-- Maintainer: Vincent Rasneur +-- 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