xfconf-4.8.0.0: Tests/TestGlib.hs

module Main where

import Test.QuickCheck
import Test.QuickCheck.Monadic              as QCM
import Test.Framework                       (defaultMain, testGroup)
import Test.Framework.Providers.QuickCheck2

import Control.Concurrent.MVar
import Control.Concurrent                   (forkIO, threadDelay)
import Control.Exception                    (bracket_)

import System.XFCE.Xfconf
import System.Glib.MainLoop
import System.Glib.Signals                  (signalDisconnect)

sleep :: Int -> IO ()
sleep = threadDelay . (1000000*)

msleep :: Int -> IO ()
msleep = threadDelay . (1000*)

-- | garbage string, just be careful to avoid C-String delimiter ('\0')
genUTFString :: Gen String
genUTFString = suchThat arbitrary (notElem '\0')

-- | same as above but without empty strings
genUTFString1 :: Gen String
genUTFString1 = suchThat genUTFString (not . null)

testSignal :: Property
testSignal = monadicIO $ do
        value  <- pick genUTFString1
        value' <- QCM.run $ setAndRetrieveWithGlib value
        QCM.assert (value == value')

debugInOut n = bracket_ (putStrLn i) (putStrLn o)
  where i = "inside " ++ n
        o = "outside " ++ n

setAndRetrieveWithGlib :: String -> IO String
setAndRetrieveWithGlib value = do
        if null value
           then error "rondedjiu, beware the deadlocks \
                      \with your empty strings!"
           else return ()

        let chanName = "QuickCheck"
            propName = "/SignalCheck"

        chan   <- channelGet chanName
        result <- newEmptyMVar

        -- Init property to a dummy value, since xfconfd will only
        -- trigger the callback if our future new value is different
        -- from the present one
        debugInOut "setDummyString" $ channelSetString chan propName "init"

        -- we sleep, otherwise our previous "set" action might get
        -- caught by the following signal handler
        debugInOut "sleep(1)" $ msleep 40

        -- We set our signal handler. Note that the glib loop has been
        -- forked away from this process so the following operation will
        -- be processed apart.
        sigid <- onPropertyChanged chan $ \_ maybeValue -> debugInOut "onPropertyChanged" $ do
            cond <- isEmptyMVar result
            if cond
               then case maybeValue of
                 Just (XfconfString s) -> putMVar result s
                 Nothing               -> putMVar result ""
                 _                     -> putMVar result "UNKNWOW value"
               else do putStrLn "DANGER, WILL ROBINSON !"
                       error "you are going to fast !"


        debugInOut "sleep(2)" $ msleep 40

        -- We resume our main thread here, by trigerring the previous
        -- signal (that what we were testing, remember ?)
        debugInOut "setNewString" $ channelSetString chan propName value

        -- ... and wait for the answer from the glib loop
        maybeValue' <- tryTakeMVar result

        -- pseudo process cleaning
        signalDisconnect sigid

        maybe (return "N/A") return maybeValue'
        --return value' -- return value' to QuickCheck.Monadic

main =  do
    loop <- mainLoopNew Nothing True
    debugInOut "fork" $ forkIO $ mainLoopRun loop
    msleep 100 >> setAndRetrieveWithGlib "foo" >>= putStr
    msleep 500 >> mainLoopQuit loop

main :: IO ()
main' = do
    loop <- mainLoopNew Nothing True
    forkIO $ mainLoopRun loop
    defaultMain testSuite >> mainLoopQuit loop

  where testSuite = [ testGroup "GLib loop"
                        [testProperty "onPropertyChanged" testSignal]
                    ]