diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -104,35 +104,56 @@ curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' fi + # Use the more reliable S3 mirror of Hackage + mkdir -p $HOME/.cabal + echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config + echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config + + if [ "$CABALVER" != "1.16" ] + then + echo 'jobs: $ncpus' >> $HOME/.cabal/config + fi + +# Get the list of packages from the stack.yaml file +- PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') + install: - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" - if [ -f configure.ac ]; then autoreconf -i; fi - | + set -ex case "$BUILD" in stack) - stack --no-terminal --install-ghc $ARGS test --only-dependencies + stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies ;; cabal) cabal --version travis_retry cabal update - cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS + cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES ;; esac + set +ex script: - | + set -ex case "$BUILD" in stack) - stack --no-terminal $ARGS test --haddock --no-haddock-deps + stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps ;; cabal) - cabal configure --enable-tests --enable-benchmarks -v2 --ghc-options="-O0 -Werror" - cabal build - cabal check || [ "$CABALVER" == "1.16" ] - cabal test - cabal sdist - cabal copy - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && \ - (cd dist && cabal install --force-reinstalls "$SRC_TGZ") + cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES + + ORIGDIR=$(pwd) + for dir in $PACKAGES + do + cd $dir + cabal check || [ "$CABALVER" == "1.16" ] + cabal sdist + SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && \ + (cd dist && cabal install --force-reinstalls "$SRC_TGZ") + cd $ORIGDIR + done ;; esac + set +ex diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,8 @@ +## 0.8.0.1 (2016-05-30) + +Fixes: + - Fix sdist problem with test files (#47) + +## 0.8.0.0 (2016-05-27) + +Initial release. diff --git a/default.nix b/default.nix --- a/default.nix +++ b/default.nix @@ -5,7 +5,7 @@ }: mkDerivation { pname = "hpio"; - version = "0.8.0.0"; + version = "0.8.0.1"; src = ./.; isLibrary = true; isExecutable = true; diff --git a/hpio.cabal b/hpio.cabal --- a/hpio.cabal +++ b/hpio.cabal @@ -1,5 +1,5 @@ Name: hpio -Version: 0.8.0.0 +Version: 0.8.0.1 Cabal-Version: >= 1.10 Build-Type: Simple Author: Drew Hess @@ -29,6 +29,7 @@ Extra-Doc-Files: README.md Extra-Source-Files: .travis.yml , Hlint.hs + , changelog.md , default.nix , shell.nix , stack.yaml @@ -239,6 +240,12 @@ , System.GPIO.Monad , System.GPIO.Tutorial , System.GPIO.Types + , Spec + , System.GPIO.TypesSpec + , System.GPIO.Linux.Sysfs.LinuxBboneSpec + , System.GPIO.Linux.Sysfs.MockInternalSpec + , System.GPIO.Linux.Sysfs.MockSpec + , System.GPIO.Linux.Sysfs.SysfsGpioMockSpec C-Sources: src/System/GPIO/Linux/Sysfs/pollSysfs.c If flag(linux-bbone-tests) cpp-options: -DRUN_LINUX_BBONE_TESTS=1 @@ -250,4 +257,4 @@ Source-Repository this Type: git Location: git://github.com/dhess/hpio.git - Tag: v0.8.0.0 + Tag: v0.8.0.1 diff --git a/shell.nix b/shell.nix --- a/shell.nix +++ b/shell.nix @@ -11,7 +11,7 @@ }: mkDerivation { pname = "hpio"; - version = "0.8.0.0"; + version = "0.8.0.1"; src = ./.; isLibrary = true; isExecutable = true; diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-} diff --git a/test/System/GPIO/Linux/Sysfs/LinuxBboneSpec.hs b/test/System/GPIO/Linux/Sysfs/LinuxBboneSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/GPIO/Linux/Sysfs/LinuxBboneSpec.hs @@ -0,0 +1,1144 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} + +module System.GPIO.Linux.Sysfs.LinuxBboneSpec (spec) where + +import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) +import Control.Monad (void) +import Control.Monad.Catch (throwM) +import Control.Monad.IO.Class (MonadIO, liftIO) +import System.Directory (doesDirectoryExist) +import System.GPIO.Linux.Sysfs (SysfsException(..), runSysfsGpioIO) +import System.GPIO.Monad (MonadGpio(..), withPin) +import System.GPIO.Types + (Pin(..), PinInputMode(..), PinOutputMode(..), PinActiveLevel(..), + PinDirection(..), PinInterruptMode(..), PinValue(..)) +import Test.Hspec + +isInvalidPinError :: SysfsException -> Bool +isInvalidPinError (InvalidPin _) = True +isInvalidPinError _ = False + +isNotExportedError :: SysfsException -> Bool +isNotExportedError (NotExported _) = True +isNotExportedError _ = False + +isUnsupportedInputMode :: SysfsException -> Bool +isUnsupportedInputMode (UnsupportedInputMode _ _) = True +isUnsupportedInputMode _ = False + +isUnsupportedOutputMode :: SysfsException -> Bool +isUnsupportedOutputMode (UnsupportedOutputMode _ _) = True +isUnsupportedOutputMode _ = False + +isPermissionDeniedError :: SysfsException -> Bool +isPermissionDeniedError (PermissionDenied _) = True +isPermissionDeniedError _ = False + +isInvalidOperationError :: SysfsException -> Bool +isInvalidOperationError (InvalidOperation _) = True +isInvalidOperationError _ = False + +-- Note: it's not practical to test all exceptional cases, but we do +-- our best. + +-- Note: make sure the tests are always compiled, but only actually +-- run on the proper platform. +spec :: Spec +spec = +#ifdef RUN_LINUX_BBONE_TESTS + runTests +#else + describe "Linux BeagleBone tests disabled on this platform" $ return () +#endif + +-- NOTE: In order to run these tests properly, the following must be true: +-- +-- * They must be run on BeagleBone Black hardware running Linux. +-- * You must have permission to export and unexport pins via the +-- sysfs GPIO filesystem. +-- * You must have permission to write pin attributes via the sysfs +-- GPIO filesystem. +-- * GPIO pins P9-15 (sysfs GPIO pin number 48) and P8-15 (sysfs GPIO +-- pin number 47) must be jumpered together. + +testPin1 :: Pin +testPin1 = Pin 48 + +testPin2 :: Pin +testPin2 = Pin 47 + +invalidPin :: Pin +invalidPin = Pin 9000 + +-- Note: tests which modify pin state have a slight delay between +-- opening the pin and modifying any state. This is so that, if the +-- user running the tests is not root and is using a udev action to +-- change pin ownership (which is the only way at the time of writing +-- to do that), the script has time to run. + +udevScriptWait :: MonadIO m => m () +udevScriptWait = liftIO $ threadDelay 500000 + +runTests :: Spec +runTests = + do + describe "runSysfsGpioIO" $ + do context "pins" $ + it "returns the full list of pins on the system" $ + runSysfsGpioIO pins `shouldReturn` (map Pin [0..127]) + context "openPin/closePin" $ + do it "exports/unexports the pin" $ + runSysfsGpioIO + (do h <- openPin testPin1 + exported <- liftIO $ doesDirectoryExist "/sys/class/gpio/gpio48" + closePin h + stillExported <- liftIO $ doesDirectoryExist "/sys/class/gpio/gpio48" + return (exported, stillExported)) + `shouldReturn` (True, False) + it "openPin doesn't complain if the pin is already exported" $ + runSysfsGpioIO + (withPin testPin1 $ \_ -> + do h <- openPin testPin1 + void $ getPinDirection h + return True) + `shouldReturn` True + it "openPin fails if the pin is invalid" $ + runSysfsGpioIO + (do h <- openPin invalidPin + dir <- getPinDirection h + return dir) + `shouldThrow` isInvalidPinError + it "closePin doesn't complain the pin is already unexported" $ + runSysfsGpioIO + (withPin testPin1 $ \_ -> + do h <- openPin testPin1 + closePin h + closePin h) + `shouldReturn` () + context "withPin" $ + do it "exports/unexports the pin" $ + do runSysfsGpioIO + (withPin testPin1 $ const $ + liftIO $ doesDirectoryExist "/sys/class/gpio/gpio48") + `shouldReturn` True + doesDirectoryExist "/sys/class/gpio/gpio48" `shouldReturn` False + it "unexports the pin upon exception" $ + do runSysfsGpioIO + (withPin testPin1 $ const $ + throwM $ userError "Foo") + `shouldThrow` anyIOException + doesDirectoryExist "/sys/class/gpio/gpio48" `shouldReturn` False + it "handles double-open and double-close gracefully" $ + do runSysfsGpioIO + (withPin testPin1 $ const $ + withPin testPin1 $ const $ + liftIO $ doesDirectoryExist "/sys/class/gpio/gpio48") + `shouldReturn` True + doesDirectoryExist "/sys/class/gpio/gpio48" `shouldReturn` False + it "fails if the pin is invalid" $ + do runSysfsGpioIO + (withPin invalidPin $ const $ + liftIO $ doesDirectoryExist "/sys/class/gpio/gpio9000") + `shouldThrow` isInvalidPinError + context "getPinDirection" $ + do it "gets the pin's direction" $ + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + dir1 <- getPinDirection h + setPinOutputMode h OutputDefault Low + dir2 <- getPinDirection h + setPinInputMode h InputDefault + dir3 <- getPinDirection h + return (dir1, dir2, dir3)) + `shouldReturn` (In, Out, In) + context "getPinInputMode" $ + do it "gets the pin's input mode" $ + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + getPinInputMode h) + `shouldReturn` InputDefault + it "fails when the pin is in output mode" $ + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinOutputMode h OutputDefault Low + getPinInputMode h) + `shouldThrow` isInvalidOperationError + context "setPinInputMode" $ + do it "sets the pin's input mode and direction" $ + do runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + m <- getPinInputMode h + d <- getPinDirection h + return (m,d)) + `shouldReturn` (InputDefault,In) + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinOutputMode h OutputDefault Low + setPinInputMode h InputDefault + m <- getPinInputMode h + d <- getPinDirection h + return (m,d)) + `shouldReturn` (InputDefault,In) + it "fails when the input mode is unsupported" $ + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputPullDown + getPinInputMode h) + `shouldThrow` isUnsupportedInputMode + context "getPinOutputMode" $ + do it "gets the pin's input mode" $ + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinOutputMode h OutputDefault Low + getPinOutputMode h) + `shouldReturn` OutputDefault + it "fails when the pin is in input mode" $ + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + getPinOutputMode h) + `shouldThrow` isInvalidOperationError + context "setPinOutputMode" $ + do it "sets the pin's output mode, direction, and value" $ + do runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinActiveLevel h ActiveHigh + setPinOutputMode h OutputDefault Low + v <- readPin h + m <- getPinOutputMode h + d <- getPinDirection h + return (v,m,d)) + `shouldReturn` (Low,OutputDefault,Out) + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinActiveLevel h ActiveHigh + setPinOutputMode h OutputDefault High + v <- readPin h + m <- getPinOutputMode h + d <- getPinDirection h + return (v,m,d)) + `shouldReturn` (High,OutputDefault,Out) + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveHigh + setPinInputMode h InputDefault + setPinOutputMode h OutputDefault High + v <- readPin h + m <- getPinOutputMode h + d <- getPinDirection h + return (v,m,d)) + `shouldReturn` (High,OutputDefault,Out) + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveHigh + setPinInputMode h InputDefault + setPinOutputMode h OutputDefault Low + v <- readPin h + m <- getPinOutputMode h + d <- getPinDirection h + return (v,m,d)) + `shouldReturn` (Low,OutputDefault,Out) + it "respects the pin's active level" $ + do runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinActiveLevel h ActiveLow + setPinOutputMode h OutputDefault Low + setPinActiveLevel h ActiveHigh + v <- readPin h + m <- getPinOutputMode h + d <- getPinDirection h + return (v,m,d)) + `shouldReturn` (High,OutputDefault,Out) + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinActiveLevel h ActiveLow + setPinOutputMode h OutputDefault High + setPinActiveLevel h ActiveHigh + v <- readPin h + m <- getPinOutputMode h + d <- getPinDirection h + return (v,m,d)) + `shouldReturn` (Low,OutputDefault,Out) + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveLow + setPinInputMode h InputDefault + setPinOutputMode h OutputDefault High + setPinActiveLevel h ActiveHigh + v <- readPin h + m <- getPinOutputMode h + d <- getPinDirection h + return (v,m,d)) + `shouldReturn` (Low,OutputDefault,Out) + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveLow + setPinInputMode h InputDefault + setPinOutputMode h OutputDefault Low + setPinActiveLevel h ActiveHigh + v <- readPin h + m <- getPinOutputMode h + d <- getPinDirection h + return (v,m,d)) + `shouldReturn` (High,OutputDefault,Out) + it "can set the pin's direction to 'Out' when it's configured for edge-triggered reads" $ + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinInterruptMode h RisingEdge + setPinOutputMode h OutputDefault Low + setPinInputMode h InputDefault + setPinInterruptMode h FallingEdge + setPinOutputMode h OutputDefault High + setPinInputMode h InputDefault + setPinInterruptMode h Level + setPinOutputMode h OutputDefault Low + return True) + `shouldReturn` True + it "fails when the output mode is unsupported" $ + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinOutputMode h OutputOpenSourcePullDown Low + getPinInputMode h) + `shouldThrow` isUnsupportedOutputMode + context "getPinActiveLevel/setPinActiveLevel" $ + it "gets and sets the pin's active level" $ + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveLow + level1 <- getPinActiveLevel h + setPinActiveLevel h ActiveHigh + level2 <- getPinActiveLevel h + setPinActiveLevel h ActiveLow + level3 <- getPinActiveLevel h + return (level1, level2, level3)) + `shouldReturn` (ActiveLow, ActiveHigh, ActiveLow) + context "togglePinActiveLevel" $ + it "toggles the pin's active level" $ + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveHigh + level1 <- togglePinActiveLevel h + level2 <- togglePinActiveLevel h + level3 <- togglePinActiveLevel h + return (level1, level2, level3)) + `shouldReturn` (ActiveLow, ActiveHigh, ActiveLow) + context "readPin/writePin" $ + -- Note: if these tests fail, you might not have hooked pin + -- P9-15 up to pin P8-15! + do it "reads and writes the pin's value" $ + runSysfsGpioIO + (withPin testPin1 $ \h1 -> + withPin testPin2 $ \h2 -> + do udevScriptWait + setPinInputMode h1 InputDefault + setPinActiveLevel h1 ActiveHigh + setPinActiveLevel h2 ActiveHigh + setPinOutputMode h2 OutputDefault High + -- give the pin time to settle + liftIO $ threadDelay 250000 + val1 <- readPin h1 + writePin h2 Low + liftIO $ threadDelay 250000 + val2 <- readPin h1 + writePin h2 High + liftIO $ threadDelay 250000 + val3 <- readPin h1 + return (val1, val2, val3)) + `shouldReturn` (High, Low, High) + it "readPin obeys the pin's active level" $ + runSysfsGpioIO + (withPin testPin1 $ \h1 -> + withPin testPin2 $ \h2 -> + do udevScriptWait + setPinInputMode h1 InputDefault + setPinActiveLevel h1 ActiveLow + setPinActiveLevel h2 ActiveHigh + setPinOutputMode h2 OutputDefault High + -- give the pin time to settle + liftIO $ threadDelay 250000 + val1 <- readPin h1 + writePin h2 Low + liftIO $ threadDelay 250000 + val2 <- readPin h1 + writePin h2 High + liftIO $ threadDelay 250000 + val3 <- readPin h1 + return (val1, val2, val3)) + `shouldReturn` (Low, High, Low) + it "readPin works on output pins" $ + runSysfsGpioIO + (withPin testPin2 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveHigh + setPinOutputMode h OutputDefault High + liftIO $ threadDelay 250000 + val1 <- readPin h + writePin h Low + liftIO $ threadDelay 250000 + val2 <- readPin h + writePin h High + liftIO $ threadDelay 250000 + val3 <- readPin h + return (val1, val2, val3)) + `shouldReturn` (High, Low, High) + it "readPin works on output pins (active-low)" $ + runSysfsGpioIO + (withPin testPin2 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveLow + setPinOutputMode h OutputDefault High + liftIO $ threadDelay 250000 + val1 <- readPin h + writePin h Low + liftIO $ threadDelay 250000 + val2 <- readPin h + writePin h High + liftIO $ threadDelay 250000 + val3 <- readPin h + return (val1, val2, val3)) + `shouldReturn` (High, Low, High) + it "writePin obeys the pin's active level" $ + runSysfsGpioIO + (withPin testPin1 $ \h1 -> + withPin testPin2 $ \h2 -> + do udevScriptWait + setPinInputMode h1 InputDefault + setPinActiveLevel h1 ActiveHigh + setPinActiveLevel h2 ActiveLow + setPinOutputMode h2 OutputDefault High + -- give the pin time to settle + liftIO $ threadDelay 250000 + val1 <- readPin h1 + writePin h2 Low + liftIO $ threadDelay 250000 + val2 <- readPin h1 + writePin h2 High + liftIO $ threadDelay 250000 + val3 <- readPin h1 + return (val1, val2, val3)) + `shouldReturn` (Low, High, Low) + it "fails if the pin is configured for input" $ + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + writePin h High) + `shouldThrow` isPermissionDeniedError + context "togglePin" $ + -- Note: if these tests fail, you might not have hooked pin + -- P9-15 up to pin P8-15! + do it "toggles the pin's value and returns the previous value" $ + runSysfsGpioIO + (withPin testPin1 $ \h1 -> + withPin testPin2 $ \h2 -> + do udevScriptWait + setPinInputMode h1 InputDefault + setPinActiveLevel h1 ActiveHigh + setPinActiveLevel h2 ActiveHigh + setPinOutputMode h2 OutputDefault Low + h2_val1 <- togglePin h2 + -- give the pin time to settle + liftIO $ threadDelay 250000 + h1_val1 <- readPin h1 + h2_val2 <- togglePin h2 + liftIO $ threadDelay 250000 + h1_val2 <- readPin h1 + h2_val3 <- togglePin h2 + liftIO $ threadDelay 250000 + h1_val3 <- readPin h1 + return (h2_val1, h1_val1, h2_val2, h1_val2, h2_val3, h1_val3)) + `shouldReturn` (High, High, Low, Low, High, High) + it "togglePin obeys the pin's active level" $ + runSysfsGpioIO + (withPin testPin1 $ \h1 -> + withPin testPin2 $ \h2 -> + do udevScriptWait + setPinInputMode h1 InputDefault + setPinActiveLevel h1 ActiveHigh + setPinActiveLevel h2 ActiveLow + setPinOutputMode h2 OutputDefault Low + h2_val1 <- togglePin h2 + -- give the pin time to settle + liftIO $ threadDelay 250000 + h1_val1 <- readPin h1 + h2_val2 <- togglePin h2 + liftIO $ threadDelay 250000 + h1_val2 <- readPin h1 + h2_val3 <- togglePin h2 + liftIO $ threadDelay 250000 + h1_val3 <- readPin h1 + return (h2_val1, h1_val1, h2_val2, h1_val2, h2_val3, h1_val3)) + `shouldReturn` (High, Low, Low, High, High, Low) + it "fails if the pin is configured for input" $ + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + void $ togglePin h) + `shouldThrow` isPermissionDeniedError + context "getPinInterruptMode/setPinInterruptMode" $ + do it "gets and sets the pin's interrupt mode" $ + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinInterruptMode h RisingEdge + trigger1 <- getPinInterruptMode h + setPinInterruptMode h FallingEdge + trigger2 <- getPinInterruptMode h + setPinInterruptMode h Level + trigger3 <- getPinInterruptMode h + setPinInterruptMode h Disabled + trigger4 <- getPinInterruptMode h + return (trigger1, trigger2, trigger3, trigger4)) + `shouldReturn` (RisingEdge, FallingEdge, Level, Disabled) + it "setPinInterruptMode should fail on an output pin" $ + runSysfsGpioIO + (withPin testPin2 $ \h -> + do udevScriptWait + setPinOutputMode h OutputDefault Low + setPinInterruptMode h Level) + `shouldThrow` isInvalidOperationError + context "pollPin" $ + -- Note: if these tests fail, you might not have hooked pin + -- P9-15 up to pin P8-15! + do it "pollPin waits for rising edge" $ + do mvar <- liftIO $ newEmptyMVar + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + withPin testPin2 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveHigh + setPinOutputMode h OutputDefault High + liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin h + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + putMVar mvar () -- synchronize finish + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinActiveLevel h ActiveHigh + setPinInterruptMode h RisingEdge + liftIO $ putMVar mvar () + val1 <- pollPin h + val2 <- pollPin h + liftIO $ void $ takeMVar mvar -- synchronize finish + return (val1, val2)) + `shouldReturn` (High, High) + it "pollPin waits for falling edge" $ + do mvar <- liftIO $ newEmptyMVar + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + withPin testPin2 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveHigh + setPinOutputMode h OutputDefault Low + liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin h + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + putMVar mvar () -- synchronize finish + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinActiveLevel h ActiveHigh + setPinInterruptMode h FallingEdge + liftIO $ putMVar mvar () + val1 <- pollPin h + val2 <- pollPin h + liftIO $ void $ takeMVar mvar -- synchronize finish + return (val1, val2)) + `shouldReturn` (Low, Low) + it "pollPin waits for level changes" $ + do mvar <- liftIO $ newEmptyMVar + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + withPin testPin2 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveHigh + setPinOutputMode h OutputDefault High + liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + putMVar mvar () -- synchronize finish + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinActiveLevel h ActiveHigh + setPinInterruptMode h Level + liftIO $ putMVar mvar () + val1 <- pollPin h + val2 <- pollPin h + val3 <- pollPin h + val4 <- pollPin h + liftIO $ void $ takeMVar mvar -- synchronize finish + return (val1, val2, val3, val4)) + `shouldReturn` (Low, High, Low, High) + it "pollPin can be disabled" $ + do mvar <- liftIO $ newEmptyMVar + runSysfsGpioIO + (withPin testPin1 $ \inPin -> + withPin testPin2 $ \outPin -> + do udevScriptWait + setPinInputMode inPin InputDefault + setPinActiveLevel inPin ActiveHigh + setPinInterruptMode inPin Disabled + setPinActiveLevel outPin ActiveHigh + setPinOutputMode outPin OutputDefault Low + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + do liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin outPin -- ignored + liftIO $ threadDelay 500000 + setPinInterruptMode inPin Level + void $ togglePin outPin -- trigger + putMVar mvar () -- synchronize finish + liftIO $ putMVar mvar () + val <- pollPin inPin + liftIO $ void $ takeMVar mvar -- synchronize finish + return val) + `shouldReturn` Low + context "pollPin with active-low logic" $ + -- Note: if these tests fail, you might not have hooked pin + -- P9-15 up to pin P8-15! + do it "pollPin waits for (active-low) rising edge" $ + do mvar <- liftIO $ newEmptyMVar + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + withPin testPin2 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveHigh + setPinOutputMode h OutputDefault Low + liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin h + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + putMVar mvar () -- synchronize finish + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinActiveLevel h ActiveLow + setPinInterruptMode h RisingEdge + liftIO $ putMVar mvar () + val1 <- pollPin h + val2 <- pollPin h + liftIO $ void $ takeMVar mvar -- synchronize finish + return (val1, val2)) + `shouldReturn` (High, High) + it "pollPin waits for (active-low) falling edge" $ + do mvar <- liftIO $ newEmptyMVar + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + withPin testPin2 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveHigh + setPinOutputMode h OutputDefault High + liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin h + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + putMVar mvar () -- synchronize finish + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinActiveLevel h ActiveLow + setPinInterruptMode h FallingEdge + liftIO $ putMVar mvar () + val1 <- pollPin h + val2 <- pollPin h + liftIO $ void $ takeMVar mvar -- synchronize finish + return (val1, val2)) + `shouldReturn` (Low, Low) + it "pollPin waits for level changes" $ + do mvar <- liftIO $ newEmptyMVar + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + withPin testPin2 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveHigh + setPinOutputMode h OutputDefault Low + liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + putMVar mvar () -- synchronize finish + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinActiveLevel h ActiveLow + setPinInterruptMode h Level + liftIO $ putMVar mvar () + val1 <- pollPin h + val2 <- pollPin h + val3 <- pollPin h + val4 <- pollPin h + liftIO $ void $ takeMVar mvar -- synchronize finish + return (val1, val2, val3, val4)) + `shouldReturn` (Low, High, Low, High) + it "pollPin can be disabled" $ + do mvar <- liftIO $ newEmptyMVar + runSysfsGpioIO + (withPin testPin1 $ \inPin -> + withPin testPin2 $ \outPin -> + do udevScriptWait + setPinInputMode inPin InputDefault + setPinActiveLevel inPin ActiveLow + setPinInterruptMode inPin Disabled + setPinActiveLevel outPin ActiveHigh + setPinOutputMode outPin OutputDefault Low + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + do liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin outPin -- ignored + liftIO $ threadDelay 500000 + setPinInterruptMode inPin Level + void $ togglePin outPin -- trigger + putMVar mvar () -- synchronize finish + liftIO $ putMVar mvar () + val <- pollPin inPin + liftIO $ void $ takeMVar mvar -- synchronize finish + return val) + `shouldReturn` High + context "pollPinTimeout" $ + -- Note: if these tests fail, you might not have hooked pin + -- P9-15 up to pin P8-15! + do it "pollPinTimeout waits for rising edge" $ + do mvar <- liftIO $ newEmptyMVar + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + withPin testPin2 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveHigh + setPinOutputMode h OutputDefault High + liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin h + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + putMVar mvar () -- synchronize finish + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinActiveLevel h ActiveHigh + setPinInterruptMode h RisingEdge + liftIO $ putMVar mvar () + val1 <- pollPinTimeout h 10000000 + val2 <- pollPinTimeout h 10000000 + liftIO $ void $ takeMVar mvar -- synchronize finish + return (val1, val2)) + `shouldReturn` (Just High, Just High) + it "pollPinTimeout waits for falling edge" $ + do mvar <- liftIO $ newEmptyMVar + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + withPin testPin2 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveHigh + setPinOutputMode h OutputDefault Low + liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin h + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + putMVar mvar () -- synchronize finish + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinActiveLevel h ActiveHigh + setPinInterruptMode h FallingEdge + liftIO $ putMVar mvar () + val1 <- pollPinTimeout h 10000000 + val2 <- pollPinTimeout h 10000000 + liftIO $ void $ takeMVar mvar -- synchronize finish + return (val1, val2)) + `shouldReturn` (Just Low, Just Low) + it "pollPinTimeout waits for level changes" $ + do mvar <- liftIO $ newEmptyMVar + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + withPin testPin2 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveHigh + setPinOutputMode h OutputDefault High + liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + putMVar mvar () -- synchronize finish + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinActiveLevel h ActiveHigh + setPinInterruptMode h Level + liftIO $ putMVar mvar () + val1 <- pollPinTimeout h 10000000 + val2 <- pollPinTimeout h 10000000 + val3 <- pollPinTimeout h 10000000 + val4 <- pollPinTimeout h 10000000 + liftIO $ void $ takeMVar mvar -- synchronize finish + return (val1, val2, val3, val4)) + `shouldReturn` (Just Low, Just High, Just Low, Just High) + it "pollPinTimeout can be disabled" $ + do mvar <- liftIO $ newEmptyMVar + runSysfsGpioIO + (withPin testPin1 $ \inPin -> + withPin testPin2 $ \outPin -> + do udevScriptWait + setPinInputMode inPin InputDefault + setPinActiveLevel inPin ActiveHigh + setPinInterruptMode inPin Disabled + setPinActiveLevel outPin ActiveHigh + setPinOutputMode outPin OutputDefault Low + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + do liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin outPin -- ignored + liftIO $ threadDelay 500000 + setPinInterruptMode inPin Level + void $ togglePin outPin -- trigger + putMVar mvar () -- synchronize finish + liftIO $ putMVar mvar () + val <- pollPinTimeout inPin 10000000 + liftIO $ void $ takeMVar mvar -- synchronize finish + return val) + `shouldReturn` Just Low + it "pollPinTimeout actually times out" $ + do mvar <- liftIO $ newEmptyMVar + runSysfsGpioIO + (withPin testPin1 $ \inPin -> + withPin testPin2 $ \outPin -> + do udevScriptWait + setPinInputMode inPin InputDefault + setPinActiveLevel inPin ActiveHigh + setPinInterruptMode inPin Disabled + setPinActiveLevel outPin ActiveHigh + setPinOutputMode outPin OutputDefault Low + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + do liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin outPin -- ignored + liftIO $ threadDelay 500000 + void $ togglePin outPin -- ignored + putMVar mvar () -- synchronize finish + liftIO $ putMVar mvar () + val <- pollPinTimeout inPin 1000000 + liftIO $ void $ takeMVar mvar -- synchronize finish + return val) + `shouldReturn` Nothing + it "pollPinTimeout times out on output pins" $ + do runSysfsGpioIO + (withPin testPin2 $ \outPin -> + do udevScriptWait + setPinActiveLevel outPin ActiveHigh + setPinOutputMode outPin OutputDefault Low + val <- pollPinTimeout outPin 1000000 + return val) + `shouldReturn` Nothing + context "pollPinTimeout with active-low logic" $ + -- Note: if these tests fail, you might not have hooked pin + -- P9-15 up to pin P8-15! + do it "pollPinTimeout waits for (active-low) rising edge" $ + do mvar <- liftIO $ newEmptyMVar + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + withPin testPin2 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveHigh + setPinOutputMode h OutputDefault Low + liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin h + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + putMVar mvar () -- synchronize finish + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinActiveLevel h ActiveLow + setPinInterruptMode h RisingEdge + liftIO $ putMVar mvar () + val1 <- pollPinTimeout h 10000000 + val2 <- pollPinTimeout h 10000000 + liftIO $ void $ takeMVar mvar -- synchronize finish + return (val1, val2)) + `shouldReturn` (Just High, Just High) + it "pollPinTimeout waits for (active-low) falling edge" $ + do mvar <- liftIO $ newEmptyMVar + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + withPin testPin2 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveHigh + setPinOutputMode h OutputDefault High + liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin h + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + putMVar mvar () -- synchronize finish + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinActiveLevel h ActiveLow + setPinInterruptMode h FallingEdge + liftIO $ putMVar mvar () + val1 <- pollPinTimeout h 10000000 + val2 <- pollPinTimeout h 10000000 + liftIO $ void $ takeMVar mvar -- synchronize finish + return (val1, val2)) + `shouldReturn` (Just Low, Just Low) + it "pollPinTimeout waits for level changes" $ + do mvar <- liftIO $ newEmptyMVar + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + withPin testPin2 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveHigh + setPinOutputMode h OutputDefault Low + liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + putMVar mvar () -- synchronize finish + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinActiveLevel h ActiveLow + setPinInterruptMode h Level + liftIO $ putMVar mvar () + val1 <- pollPinTimeout h 10000000 + val2 <- pollPinTimeout h 10000000 + val3 <- pollPinTimeout h 10000000 + val4 <- pollPinTimeout h 10000000 + liftIO $ void $ takeMVar mvar -- synchronize finish + return (val1, val2, val3, val4)) + `shouldReturn` (Just Low, Just High, Just Low, Just High) + it "pollPinTimeout can be disabled" $ + do mvar <- liftIO $ newEmptyMVar + runSysfsGpioIO + (withPin testPin1 $ \inPin -> + withPin testPin2 $ \outPin -> + do udevScriptWait + setPinInputMode inPin InputDefault + setPinActiveLevel inPin ActiveLow + setPinInterruptMode inPin Disabled + setPinActiveLevel outPin ActiveHigh + setPinOutputMode outPin OutputDefault Low + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + do liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin outPin -- ignored + liftIO $ threadDelay 500000 + setPinInterruptMode inPin Level + void $ togglePin outPin -- trigger + putMVar mvar () -- synchronize finish + liftIO $ putMVar mvar () + val <- pollPinTimeout inPin 10000000 + liftIO $ void $ takeMVar mvar -- synchronize finish + return val) + `shouldReturn` Just High + context "Various NotExported exceptions" $ + do it "getPinDirection" $ + runSysfsGpioIO + (do h <- openPin testPin1 + closePin h + v <- getPinDirection h + return v) + `shouldThrow` isNotExportedError + it "getPinInputMode" $ + runSysfsGpioIO + (do h <- openPin testPin1 + closePin h + getPinInputMode h) + `shouldThrow` isNotExportedError + it "setPinInputMode" $ + runSysfsGpioIO + (do h <- openPin testPin1 + closePin h + setPinInputMode h InputDefault) + `shouldThrow` isNotExportedError + it "getPinOutputMode" $ + runSysfsGpioIO + (do h <- openPin testPin1 + closePin h + getPinOutputMode h) + `shouldThrow` isNotExportedError + it "setPinOutputMode" $ + runSysfsGpioIO + (do h <- openPin testPin1 + closePin h + setPinOutputMode h OutputDefault Low) + `shouldThrow` isNotExportedError + it "getPinInterruptMode" $ + runSysfsGpioIO + (do h <- openPin testPin1 + closePin h + v <- getPinInterruptMode h + return v) + `shouldThrow` isNotExportedError + it "setPinInterruptMode" $ + runSysfsGpioIO + (do h <- openPin testPin1 + closePin h + setPinInterruptMode h RisingEdge) + `shouldThrow` isNotExportedError + it "getPinActiveLevel" $ + runSysfsGpioIO + (do h <- openPin testPin1 + closePin h + v <- getPinActiveLevel h + return v) + `shouldThrow` isNotExportedError + it "setPinActiveLevel" $ + runSysfsGpioIO + (do h <- openPin testPin1 + closePin h + setPinActiveLevel h ActiveHigh) + `shouldThrow` isNotExportedError + it "toggleActiveLevel" $ + runSysfsGpioIO + (do h <- openPin testPin1 + closePin h + v <- togglePinActiveLevel h + return v) + `shouldThrow` isNotExportedError + it "readPin" $ + runSysfsGpioIO + (do h <- openPin testPin1 + closePin h + v <- readPin h + return v) + `shouldThrow` isNotExportedError + it "pollPin" $ + runSysfsGpioIO + (do h <- openPin testPin1 + closePin h + v <- pollPin h + return v) + `shouldThrow` isNotExportedError + it "pollPinTimeout" $ + runSysfsGpioIO + (do h <- openPin testPin1 + closePin h + v <- pollPinTimeout h 100000 + return v) + `shouldThrow` isNotExportedError + it "writePin" $ + runSysfsGpioIO + (do h <- openPin testPin1 + closePin h + writePin h High) + `shouldThrow` isNotExportedError + it "togglePin" $ + runSysfsGpioIO + (do h <- openPin testPin1 + closePin h + v <- togglePin h + return v) + `shouldThrow` isNotExportedError diff --git a/test/System/GPIO/Linux/Sysfs/MockInternalSpec.hs b/test/System/GPIO/Linux/Sysfs/MockInternalSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/GPIO/Linux/Sysfs/MockInternalSpec.hs @@ -0,0 +1,328 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-incomplete-uni-patterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module System.GPIO.Linux.Sysfs.MockInternalSpec (spec) where + +import GHC.IO.Exception (IOErrorType(..)) +import System.GPIO.Linux.Sysfs.Mock.Internal +import System.IO.Error (ioeGetErrorType, isAlreadyExistsError, isDoesNotExistError) +import Test.Hspec + +isInvalidArgumentErrorType :: IOErrorType -> Bool +isInvalidArgumentErrorType InvalidArgument = True +isInvalidArgumentErrorType _ = False + +isInvalidArgumentError :: IOError -> Bool +isInvalidArgumentError = isInvalidArgumentErrorType . ioeGetErrorType + +isInappropriateTypeErrorType :: IOErrorType -> Bool +isInappropriateTypeErrorType InappropriateType = True +isInappropriateTypeErrorType _ = False + +isInappropriateTypeError :: IOError -> Bool +isInappropriateTypeError = isInappropriateTypeErrorType . ioeGetErrorType + +sysfsRoot :: Directory +sysfsRoot = + directory "/" + [] + [directory "sys" + [] + [directory "class" + [] + [directory "gpio" + [File "export" Export + ,File "unexport" Unexport] + []]]] + +parentName :: MockFSCrumb -> Name +parentName = _dirNodeName . _node + +spec :: Spec +spec = + let sysfsRootZ = MockFSZipper sysfsRoot [] + in + do describe "cd" $ do + + context "relative paths" $ do + + it "can traverse downwards one directory at a time" $ + do let Right z1@(MockFSZipper dir1 (crumb1:_)) = cd "sys" sysfsRootZ + dirName dir1 `shouldBe` "sys" + parentName crumb1 `shouldBe` "/" + let Right z2@(MockFSZipper dir2 (crumb2:_)) = cd "class" z1 + dirName dir2 `shouldBe` "class" + parentName crumb2 `shouldBe` "sys" + let Right (MockFSZipper dir3 (crumb3:_)) = cd "gpio" z2 + dirName dir3 `shouldBe` "gpio" + parentName crumb3 `shouldBe` "class" + + it "can traverse downwards multiple directories at a time" $ + do let Right (MockFSZipper dir1 (crumb1:_)) = cd "sys/class/gpio" sysfsRootZ + dirName dir1 `shouldBe` "gpio" + parentName crumb1 `shouldBe` "class" + + it "fails when changing to a non-existent child" $ + do let Left result1 = cd "foobar" sysfsRootZ + isDoesNotExistError result1 `shouldBe` True + let Left result2 = (cd "sys/class" sysfsRootZ >>= cd "baz" ) + isDoesNotExistError result2 `shouldBe` True + + it "fails when changing to a non-existent grandchild" $ + do let Left result = cd "sys/class/foobar" sysfsRootZ + isDoesNotExistError result `shouldBe` True + + it "fails when changing to a file name rather than a directory name" $ + do let Left result1 = (cd "sys/class/gpio" sysfsRootZ >>= cd "export") + isInappropriateTypeError result1 `shouldBe` True + let Left result2 = (cd "sys/class/gpio" sysfsRootZ >>= cd "export/foobar") + isInappropriateTypeError result2 `shouldBe` True + let Left result3 = cd "sys/class/gpio/unexport" sysfsRootZ + isInappropriateTypeError result3 `shouldBe` True + let Left result4 = cd "sys/class/gpio/unexport/baz" sysfsRootZ + isInappropriateTypeError result4 `shouldBe` True + + it "'.' in paths" $ + do cd "sys/." sysfsRootZ `shouldBe` cd "sys" sysfsRootZ + cd "sys/./class" sysfsRootZ `shouldBe` cd "sys/class" sysfsRootZ + + it "'..' in paths" $ + do cd "sys/.." sysfsRootZ `shouldBe` Right sysfsRootZ + cd "sys/class/../class" sysfsRootZ `shouldBe` cd "sys/class" sysfsRootZ + cd "sys/class/gpio/../../class" sysfsRootZ `shouldBe` cd "sys/../sys/class/../class/gpio/.." sysfsRootZ + cd "sys/class/gpio/../../.." sysfsRootZ `shouldBe` Right sysfsRootZ + + it "'..' beyond root clamps to root" $ + do cd "sys/class/../../../.." sysfsRootZ `shouldBe` Right sysfsRootZ + cd "../.." sysfsRootZ `shouldBe` Right sysfsRootZ + + context "absolute paths" $ do + it "can traverse downwards one directory at a time" $ + do let Right z1@(MockFSZipper dir1 (crumb1:_)) = cd "/sys" sysfsRootZ + dirName dir1 `shouldBe` "sys" + parentName crumb1 `shouldBe` "/" + let Right z2@(MockFSZipper dir2 (crumb2:_)) = cd "class" z1 + dirName dir2 `shouldBe` "class" + parentName crumb2 `shouldBe` "sys" + let Right (MockFSZipper dir3 (crumb3:_)) = cd "gpio" z2 + dirName dir3 `shouldBe` "gpio" + parentName crumb3 `shouldBe` "class" + it "can traverse downwards multiple directories at a time" $ + do let Right (MockFSZipper dir1 (crumb1:_)) = cd "/sys/class/gpio" sysfsRootZ + dirName dir1 `shouldBe` "gpio" + parentName crumb1 `shouldBe` "class" + it "fails when changing to a non-existent child" $ + do let Left result = cd "/foobar" sysfsRootZ + isDoesNotExistError result `shouldBe` True + it "fails when changing to a non-existent grandchild" $ + do let Left result = cd "/sys/class/foobar" sysfsRootZ + isDoesNotExistError result `shouldBe` True + it "fails when changing to a file name rather than a directory name" $ + do let Left result1 = cd "/sys/class/gpio/export" sysfsRootZ + isInappropriateTypeError result1 `shouldBe` True + let Left result2 = cd "/sys/class/gpio/unexport/baz" sysfsRootZ + isInappropriateTypeError result2 `shouldBe` True + + it "cd / is root" $ + cd "/" sysfsRootZ `shouldBe` Right sysfsRootZ + + it "cd / from deeper starts at root" $ do + (cd "/sys/class/gpio" sysfsRootZ >>= cd "/") `shouldBe` Right sysfsRootZ + (cd "/sys/class/gpio" sysfsRootZ >>= cd "/sys/class") `shouldBe` cd "/sys/class" sysfsRootZ + + it "'.' in paths" $ + do cd "/sys/." sysfsRootZ `shouldBe` cd "/sys" sysfsRootZ + cd "/sys/./class" sysfsRootZ `shouldBe` cd "/sys/class" sysfsRootZ + it "'..' in paths" $ + do cd "/sys/.." sysfsRootZ `shouldBe` Right sysfsRootZ + cd "/sys/class/../class" sysfsRootZ `shouldBe` cd "/sys/class" sysfsRootZ + cd "/sys/class/gpio/../../class" sysfsRootZ `shouldBe` cd "/sys/../sys/class/../class/gpio/.." sysfsRootZ + cd "/sys/class/gpio/../../.." sysfsRootZ `shouldBe` Right sysfsRootZ + it "'..' beyond root clamps to root" $ + do cd "/sys/class/../../../.." sysfsRootZ `shouldBe` Right sysfsRootZ + cd "/../.." sysfsRootZ `shouldBe` Right sysfsRootZ + + context "absolute and relative paths" $ do + it "produce the same result when they lead to the same directory" $ + do cd "sys/class/gpio" sysfsRootZ `shouldBe` cd "/sys/class/gpio" sysfsRootZ + cd "sys/class/gpio/.." sysfsRootZ `shouldBe` cd "/sys/class/gpio/.." sysfsRootZ + cd "sys/class/gpio/../../." sysfsRootZ `shouldBe` cd "/sys/class/gpio/../../." sysfsRootZ + cd "sys/class/.././class/../../sys" sysfsRootZ `shouldBe` cd "/sys/../sys/class/./gpio/../.." sysfsRootZ + + describe "mkdir" $ + do it "creates a subdirectory in the current directory" $ + do let Right z1@(MockFSZipper dir1 crumb1) = mkdir "xyzzy" sysfsRootZ + dirName dir1 `shouldBe` "/" + crumb1 `shouldBe` [] + let Right (MockFSZipper dir2 (crumb2:_)) = cd "xyzzy" z1 + dirName dir2 `shouldBe` "xyzzy" + parentName crumb2 `shouldBe` "/" + + it "can create multiple subdirectories in the same directory" $ + do let Right z1@(MockFSZipper dir1 crumb1) = mkdir "xyzzy" sysfsRootZ + dirName dir1 `shouldBe` "/" + crumb1 `shouldBe` [] + let Right z2@(MockFSZipper dir2 crumb2) = mkdir "plugh" z1 + dirName dir2 `shouldBe` "/" + crumb2 `shouldBe` [] + let Right z3@(MockFSZipper dir3 (crumb3:_)) = cd "xyzzy" z2 + dirName dir3 `shouldBe` "xyzzy" + parentName crumb3 `shouldBe` "/" + let Right (MockFSZipper dir4 (crumb4:_)) = cd "../plugh" z3 + dirName dir4 `shouldBe` "plugh" + parentName crumb4 `shouldBe` "/" + + it "works when nested" $ + do let Right (MockFSZipper dir (crumb:_)) = mkdir "abc" sysfsRootZ >>= cd "/abc" >>= mkdir "def" >>= cd "/abc/def" + dirName dir `shouldBe` "def" + parentName crumb `shouldBe` "abc" + + it "fails when a subdir with the same name already exists" $ + do let Left result = mkdir "sys" sysfsRootZ + isAlreadyExistsError result `shouldBe` True + + it "fails when a file with the same name already exists" $ + do let Left result = (cd "/sys/class/gpio" sysfsRootZ >>= mkdir "export") + isAlreadyExistsError result `shouldBe` True + + it "fails with an invalid name" $ + do let Left result = mkdir "" sysfsRootZ + isInvalidArgumentError result `shouldBe` True + + it "fails when the name contains a '/'" $ + do let Left result1 = mkdir "/abc" sysfsRootZ + isInvalidArgumentError result1 `shouldBe` True + let Left result2 = mkdir "sys/foobar" sysfsRootZ + isInvalidArgumentError result2 `shouldBe` True + + describe "mkfile" $ + do it "creates a file in the current directory when clobber is False" $ + do let Right z1 = cd "/sys/class/gpio" sysfsRootZ + let Right (MockFSZipper dir2 (crumb2:_)) = mkfile "gpio1" (Const ["Hey!", "This is gpio1"]) False z1 + dirName dir2 `shouldBe` "gpio" + parentName crumb2 `shouldBe` "class" + let file:rest = files dir2 + _fileName file `shouldBe` "gpio1" + _fileType file `shouldBe` (Const ["Hey!", "This is gpio1"]) + rest `shouldBe` [File {_fileName = "export", _fileType = Export},File {_fileName = "unexport", _fileType = Unexport}] + + it "creates a file in the current directory when clobber is True" $ + do let Right z1 = cd "/sys/class/gpio" sysfsRootZ + let Right (MockFSZipper dir2 (crumb2:_)) = mkfile "gpio1" (Const ["Hey!", "This is gpio1"]) True z1 + dirName dir2 `shouldBe` "gpio" + parentName crumb2 `shouldBe` "class" + let file:rest = files dir2 + _fileName file `shouldBe` "gpio1" + _fileType file `shouldBe` (Const ["Hey!", "This is gpio1"]) + rest `shouldBe` [File {_fileName = "export", _fileType = Export},File {_fileName = "unexport", _fileType = Unexport}] + + it "fails when a subdir with the same name already exists" $ do + let Left result1 = mkfile "sys" (Const []) True sysfsRootZ + isAlreadyExistsError result1 `shouldBe` True + let Left result2 = mkfile "sys" (Const []) False sysfsRootZ + isAlreadyExistsError result2 `shouldBe` True + + it "fails when a file with the same name already exists and clobber is False" $ + do let Left result = (cd "/sys/class/gpio" sysfsRootZ >>= mkfile "export" (Const []) False) + isAlreadyExistsError result `shouldBe` True + + it "overwrites an existing file's contents when a file with the same name already exists and clobber is True" $ + do let Right z1 = cd "/sys/class/gpio" sysfsRootZ + let Right z2 = mkfile "gpio1" (Const ["Hey!", "This is gpio1"]) False z1 + let Right (MockFSZipper dir3 (crumb3:_)) = mkfile "gpio1" (Const ["Hey!", "Now I'm gpio1"]) True z2 + dirName dir3 `shouldBe` "gpio" + parentName crumb3 `shouldBe` "class" + let file:rest = files dir3 + _fileName file `shouldBe` "gpio1" + _fileType file `shouldBe` (Const ["Hey!", "Now I'm gpio1"]) + rest `shouldBe` [File {_fileName = "export", _fileType = Export},File {_fileName = "unexport", _fileType = Unexport}] + + it "fails with an invalid name" $ do + let Left result1 = mkfile "" (Const []) False sysfsRootZ + isInvalidArgumentError result1 `shouldBe` True + let Left result2 = mkfile "" (Const []) True sysfsRootZ + isInvalidArgumentError result2 `shouldBe` True + + it "fails when the name contains a '/'" $ + do let Left result1 = mkfile "/abc" (Const []) False sysfsRootZ + isInvalidArgumentError result1 `shouldBe` True + let Left result2 = mkfile "/abc" (Const []) True sysfsRootZ + isInvalidArgumentError result2 `shouldBe` True + let Left result3 = mkfile "sys/foobar" (Const []) False sysfsRootZ + isInvalidArgumentError result3 `shouldBe` True + let Left result4 = mkfile "sys/foobar" (Const []) True sysfsRootZ + isInvalidArgumentError result4 `shouldBe` True + + describe "findFile" $ + do it "finds files in the current directory" $ + do let Right z1@(MockFSZipper dir1 _) = cd "/sys/class/gpio" sysfsRootZ + findFile "export" dir1 `shouldBe` (Just Export) + findFile "unexport" dir1 `shouldBe` (Just Unexport) + let Right (MockFSZipper dir2 _) = mkfile "gpio1" (Const ["Hey!", "This is gpio1"]) False z1 + findFile "gpio1" dir2 `shouldBe` (Just ((Const ["Hey!", "This is gpio1"]))) + it "doesn't find subdirectories in the current directory" $ + do let Right (MockFSZipper dir1 _) = cd "/sys/class" sysfsRootZ + findFile "gpio" dir1 `shouldBe` Nothing + it "returns failure on non-existent files" $ + do let Right (MockFSZipper dir1 _) = cd "/sys/class" sysfsRootZ + findFile "foobar" dir1 `shouldBe` Nothing + findFile "export" dir1 `shouldBe` Nothing + it "doesn't find files in subdirectories of the current directory" $ + do let Right (MockFSZipper dir1 _) = cd "/sys/class" sysfsRootZ + findFile "gpio/export" dir1 `shouldBe` Nothing + + describe "rmdir" $ + do it "removes a subdirectory of the current directory" $ + do let Right z1 = cd "/sys" sysfsRootZ >>= mkdir "xyzzy" >>= mkdir "plugh" + let Right z2@(MockFSZipper dir2 (crumb2:_)) = rmdir "xyzzy" z1 + dirName dir2 `shouldBe` "sys" + parentName crumb2 `shouldBe` "/" + let Right (MockFSZipper dir3 (crumb3:_)) = rmdir "plugh" z2 + dirName dir3 `shouldBe` "sys" + parentName crumb3 `shouldBe` "/" + + it "fails when no subdir with the name exists" $ + do let Left result = rmdir "foo" sysfsRootZ + isDoesNotExistError result `shouldBe` True + + it "fails when a file is named" $ + do let Left result = (cd "/sys/class/gpio" sysfsRootZ >>= rmdir "export") + isInappropriateTypeError result `shouldBe` True + + it "fails when the name contains a '/'" $ + do let Left result1 = rmdir "/sys" sysfsRootZ + isDoesNotExistError result1 `shouldBe` True + let Left result2 = rmdir "sys/class" sysfsRootZ + isDoesNotExistError result2 `shouldBe` True + + describe "rmfile" $ + do it "removes a file in the current directory" $ + do let Right z1 = cd "/sys" sysfsRootZ >>= mkfile "abc" (Const []) False >>= mkfile "def" (Const []) False + let Right z2@(MockFSZipper dir2 (crumb2:_)) = rmfile "abc" z1 + dirName dir2 `shouldBe` "sys" + parentName crumb2 `shouldBe` "/" + files dir2 `shouldBe` [File {_fileName = "def", _fileType = (Const [])}] + let Right (MockFSZipper dir3 (crumb3:_)) = rmfile "def" z2 + dirName dir3 `shouldBe` "sys" + parentName crumb3 `shouldBe` "/" + files dir3 `shouldBe` [] + + it "fails when no file with the name exists" $ + do let Left result = rmfile "foo" sysfsRootZ + isDoesNotExistError result `shouldBe` True + + it "fails when a directory is named" $ + do let Left result = (cd "/sys/class" sysfsRootZ >>= rmfile "gpio") + isInappropriateTypeError result `shouldBe` True + + it "fails when the name contains a '/'" $ + do let Left result = rmfile "/sys/class/gpio/export" sysfsRootZ + isDoesNotExistError result `shouldBe` True + + describe "pathFromRoot" $ + do it "returns the path from the current directory to the root directory" $ + do pathFromRoot sysfsRootZ `shouldBe` "/" + let Right z1 = cd "/sys/class/gpio" sysfsRootZ + pathFromRoot z1 `shouldBe` "/sys/class/gpio" + let Right z2 = cd "/sys/class/gpio/../../class" sysfsRootZ + pathFromRoot z2 `shouldBe` "/sys/class" diff --git a/test/System/GPIO/Linux/Sysfs/MockSpec.hs b/test/System/GPIO/Linux/Sysfs/MockSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/GPIO/Linux/Sysfs/MockSpec.hs @@ -0,0 +1,138 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-incomplete-uni-patterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module System.GPIO.Linux.Sysfs.MockSpec (spec) where + +import Prelude hiding (readFile, writeFile) +import Control.Exception (fromException) +import Data.List (sort) +import GHC.IO.Exception (IOErrorType(..)) +import System.GPIO.Linux.Sysfs.Mock +import System.GPIO.Types (Pin(..), PinValue(..)) +import System.IO.Error (ioeGetErrorType, isDoesNotExistError, isPermissionError) +import Test.Hspec + +isInappropriateTypeErrorType :: IOErrorType -> Bool +isInappropriateTypeErrorType InappropriateType = True +isInappropriateTypeErrorType _ = False + +isInappropriateTypeError :: IOError -> Bool +isInappropriateTypeError = isInappropriateTypeErrorType . ioeGetErrorType + +evalSysfsMock' :: SysfsMock a -> MockWorld -> [MockGpioChip] -> Either (Maybe IOError) a +evalSysfsMock' a w c = either (Left . fromException) Right $ evalSysfsMock a w c + +evalSysfsMockME :: SysfsMock a -> MockWorld -> [MockGpioChip] -> Either (Maybe MockFSException) a +evalSysfsMockME a w c = either (Left . fromException) Right $ evalSysfsMock a w c + +execSysfsMock' :: SysfsMock a -> MockWorld -> [MockGpioChip] -> Either (Maybe IOError) MockWorld +execSysfsMock' a w c = either (Left . fromException) Right $ execSysfsMock a w c + +spec :: Spec +spec = + do + describe "MockPinState" $ do + it "logicalValue returns the correct pin value" $ + let pinState = defaultMockPinState {_value = Low, _activeLow = False} + in do + logicalValue pinState `shouldBe` Low + logicalValue (pinState {_value = High}) `shouldBe` High + logicalValue (pinState {_activeLow = True}) `shouldBe` High + logicalValue (pinState {_value = High, _activeLow = True}) `shouldBe` Low + it "setLogicalValue sets the correct pin value" $ + let pinState = defaultMockPinState {_value = Low, _activeLow = False} + activeLowPinState = defaultMockPinState {_value = Low, _activeLow = True} + in do + setLogicalValue Low pinState `shouldBe` pinState + setLogicalValue High pinState `shouldBe` pinState {_value = High} + setLogicalValue Low activeLowPinState `shouldBe` activeLowPinState {_value = High} + setLogicalValue High activeLowPinState `shouldBe` activeLowPinState {_value = Low} + + describe "SysfsMockT" $ do + + context "doesDirectoryExist" $ do + it "relative paths are relative to the initial zipper's working directory" $ do + evalSysfsMock' (doesDirectoryExist "sys/class/gpio") initialMockWorld [] `shouldBe` Right True + it "absolute paths work regardless of the initial zipper's working directory" $ do + evalSysfsMock' (doesDirectoryExist "/sys/class/gpio") initialMockWorld [] `shouldBe` Right True + it "doesn't change the initial zipper's state" $ do + execSysfsMock' (doesDirectoryExist "/sys/class/gpio") initialMockWorld [] `shouldBe` Right initialMockWorld + it "returns False on files" $ do + evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/export") initialMockWorld [] `shouldBe` Right False + it "returns False on non-existent names" $ do + evalSysfsMock' (doesDirectoryExist "/sys/class/foobar") initialMockWorld [] `shouldBe` Right False + + context "doesFileExist" $ do + it "relative paths are relative to the initial zipper's working directory" $ do + evalSysfsMock' (doesFileExist "sys/class/gpio/export") initialMockWorld [] `shouldBe` Right True + it "absolute paths work regardless of the initial zipper's working directory" $ do + evalSysfsMock' (doesFileExist "/sys/class/gpio/export") initialMockWorld [] `shouldBe` Right True + it "doesn't change the initial zipper's state" $ do + execSysfsMock' (doesFileExist "/sys/class/gpio/export") initialMockWorld [] `shouldBe` Right initialMockWorld + it "returns False on directories" $ do + evalSysfsMock' (doesFileExist "/sys/class/gpio") initialMockWorld [] `shouldBe` Right False + it "returns False on non-existent names" $ do + evalSysfsMock' (doesFileExist "/sys/class/foobar") initialMockWorld [] `shouldBe` Right False + + context "getDirectoryContents" $ do + it "relative paths are relative to the initial zipper's working directory" $ do + fmap sort (evalSysfsMock' (getDirectoryContents "sys/class") initialMockWorld []) `shouldBe` Right ["gpio"] + fmap sort (evalSysfsMock' (getDirectoryContents "sys/class/gpio") initialMockWorld []) `shouldBe` (Right $ sort ["export", "unexport"]) + it "absolute paths work regardless of the initial zipper's working directory" $ do + fmap sort (evalSysfsMock' (getDirectoryContents "/sys/class") initialMockWorld []) `shouldBe` Right ["gpio"] + fmap sort (evalSysfsMock' (getDirectoryContents "/sys/class/gpio") initialMockWorld []) `shouldBe` (Right $ sort ["export", "unexport"]) + it "doesn't change the initial zipper's state" $ do + execSysfsMock' (getDirectoryContents "/sys/class/gpio") initialMockWorld [] `shouldBe` Right initialMockWorld + it "returns failure on files" $ do + do let Left (Just result) = evalSysfsMock' (getDirectoryContents "/sys/class/gpio/export") initialMockWorld [] + isInappropriateTypeError result `shouldBe` True + it "returns failure on non-existent names" $ do + do let Left (Just result) = evalSysfsMock' (getDirectoryContents "/sys/class/foobar") initialMockWorld [] + isDoesNotExistError result `shouldBe` True + + context "readFile" $ do + -- Note: most interesting cases are already checked by the + -- tests in 'SysfsGpioMockSpec.hs' and it would be a bit silly + -- to try to test them here due to the amount of setup + -- required to get the filesystem into the necessary state. + -- (We would basically end up rewriting large chunks of the + -- mock GPIO code.) + it "works with 'constant' files" $ + let chip0 = MockGpioChip "chip0" 0 (replicate 16 defaultMockPinState) + in evalSysfsMock' (readFile "/sys/class/gpio/gpiochip0/base") initialMockWorld [chip0] `shouldBe` Right "0\n" + it "fails on /sys/class/gpio/export" $ + do let Left (Just result) = evalSysfsMock' (readFile "/sys/class/gpio/export") initialMockWorld [] + isPermissionError result `shouldBe` True + it "fails on /sys/class/gpio/unexport" $ + do let Left (Just result) = evalSysfsMock' (readFile "/sys/class/gpio/unexport") initialMockWorld [] + isPermissionError result `shouldBe` True + it "fails on non-existent file" $ + do let Left (Just result) = evalSysfsMock' (readFile "/sys/class/gpio/foo") initialMockWorld [] + isDoesNotExistError result `shouldBe` True + it "fails on a directory" $ + do let Left (Just result) = evalSysfsMock' (readFile "/sys/class/gpio") initialMockWorld [] + isInappropriateTypeError result `shouldBe` True + + context "writeFile" $ + it "does the right thing" $ + pendingWith "Not implemented" -- See notes for 'readFile' + -- above. + + context "runSysfsMockT" $ do + let chip0 = MockGpioChip "chip0" 0 (replicate 16 defaultMockPinState) + chip16 = MockGpioChip "xyz" 16 (replicate 32 defaultMockPinState) + chip64 = MockGpioChip "abc" 64 (replicate 16 defaultMockPinState) + invalidChip32 = MockGpioChip "invalid" 32 (replicate 16 defaultMockPinState) + it "creates the specified gpiochip directories" $ do + fmap sort (evalSysfsMock' (getDirectoryContents "/sys/class/gpio") initialMockWorld [chip0, chip16, chip64]) `shouldBe` Right ["export", "gpiochip0", "gpiochip16", "gpiochip64", "unexport"] + evalSysfsMock' (readFile "/sys/class/gpio/gpiochip0/base") initialMockWorld [chip0, chip16, chip64] `shouldBe` Right "0\n" + evalSysfsMock' (readFile "/sys/class/gpio/gpiochip0/ngpio") initialMockWorld [chip0, chip16, chip64] `shouldBe` Right "16\n" + evalSysfsMock' (readFile "/sys/class/gpio/gpiochip0/label") initialMockWorld [chip0, chip16, chip64] `shouldBe` Right "chip0\n" + evalSysfsMock' (readFile "/sys/class/gpio/gpiochip16/base") initialMockWorld [chip0, chip16, chip64] `shouldBe` Right "16\n" + evalSysfsMock' (readFile "/sys/class/gpio/gpiochip16/ngpio") initialMockWorld [chip0, chip16, chip64] `shouldBe` Right "32\n" + evalSysfsMock' (readFile "/sys/class/gpio/gpiochip16/label") initialMockWorld [chip0, chip16, chip64] `shouldBe` Right "xyz\n" + evalSysfsMock' (readFile "/sys/class/gpio/gpiochip64/base") initialMockWorld [chip0, chip16, chip64] `shouldBe` Right "64\n" + evalSysfsMock' (readFile "/sys/class/gpio/gpiochip64/ngpio") initialMockWorld [chip0, chip16, chip64] `shouldBe` Right "16\n" + evalSysfsMock' (readFile "/sys/class/gpio/gpiochip64/label") initialMockWorld [chip0, chip16, chip64] `shouldBe` Right "abc\n" + it "fails when MockGpioChips overlap" $ do + evalSysfsMockME (readFile "/sys/class/gpio/gpiochip16/ngpio") initialMockWorld [chip0, chip16, invalidChip32] `shouldBe` Left (Just $ GpioChipOverlap $ Pin 47) diff --git a/test/System/GPIO/Linux/Sysfs/SysfsGpioMockSpec.hs b/test/System/GPIO/Linux/Sysfs/SysfsGpioMockSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/GPIO/Linux/Sysfs/SysfsGpioMockSpec.hs @@ -0,0 +1,879 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-incomplete-uni-patterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module System.GPIO.Linux.Sysfs.SysfsGpioMockSpec (spec) where + +import Control.Exception (fromException) +import Control.Monad (void) +import Control.Monad.Catch (MonadCatch, MonadMask, handle) +import qualified Data.Map.Strict as Map (lookup) +import qualified Data.Set as Set (empty, fromList) + +import System.GPIO.Linux.Sysfs.Mock +import System.GPIO.Linux.Sysfs.Types (SysfsEdge(..), SysfsException(..)) +import System.GPIO.Monad + +import Test.Hspec + +-- To some extent, these tests only test the implementation of the +-- Mock interpreter, which isn't particularly valuable on its own. +-- However, it does allow us to test that we're able to express the +-- kinds of GpioT programs we want, in a pure environment (and when +-- the platform we're developing on doesn't actually have GPIO +-- functionality). + +testOpenClose :: (MonadGpio h m) => m () +testOpenClose = + do h <- openPin (Pin 1) + closePin h + +testSetInterruptMode :: (MonadGpio h m) => m (PinInterruptMode, PinInterruptMode, PinInterruptMode, PinInterruptMode) +testSetInterruptMode = + do d <- openPin (Pin 1) + setPinInputMode d InputDefault + setPinInterruptMode d Disabled + t1 <- getPinInterruptMode d + setPinInterruptMode d RisingEdge + t2 <- getPinInterruptMode d + setPinInterruptMode d FallingEdge + t3 <- getPinInterruptMode d + setPinInterruptMode d Level + t4 <- getPinInterruptMode d + closePin d + return (t1, t2, t3, t4) + +testSetInterruptModeIdempotent :: (MonadGpio h m) => m (PinInterruptMode, PinInterruptMode) +testSetInterruptModeIdempotent = + do d <- openPin (Pin 1) + setPinInputMode d InputDefault + setPinInterruptMode d FallingEdge + t1 <- getPinInterruptMode d + setPinInterruptMode d FallingEdge + t2 <- getPinInterruptMode d + closePin d + return (t1, t2) + +testReadWritePin :: (MonadGpio h m) => h -> m (PinValue, PinValue, PinValue) +testReadWritePin d = + do val1 <- readPin d + case val1 of + Low -> + do writePin d High + val2 <- readPin d + writePin d Low + val3 <- readPin d + return (val1,val2,val3) + High -> + do writePin d Low + val2 <- readPin d + writePin d High + val3 <- readPin d + return (val1,val2,val3) + +testReadWritePinIdempotent :: (MonadGpio h m) => m (PinValue, PinValue) +testReadWritePinIdempotent = + do d <- openPin (Pin 1) + setPinOutputMode d OutputDefault Low + val1 <- readPin d + case val1 of + Low -> + do writePin d Low + val2 <- readPin d + closePin d + return (val1,val2) + High -> + do writePin d High + val2 <- readPin d + closePin d + return (val1,val2) + +testWritePinFailsOnInputPin :: (MonadGpio h m) => m () +testWritePinFailsOnInputPin = + do d <- openPin (Pin 1) + setPinInputMode d InputDefault + writePin d High + closePin d + +testTogglePinValue :: (MonadGpio h m) => m (PinValue, PinValue, PinValue, PinValue, PinValue) +testTogglePinValue = + do d <- openPin (Pin 1) + setPinOutputMode d OutputDefault Low + val1 <- readPin d + val2 <- togglePin d + val3 <- readPin d + val4 <- togglePin d + val5 <- readPin d + closePin d + return (val1, val2, val3, val4, val5) + +testTogglePinActiveLevel :: (MonadGpio h m) => h -> m (PinActiveLevel, PinActiveLevel, PinActiveLevel, PinActiveLevel, PinActiveLevel) +testTogglePinActiveLevel h = + do val1 <- getPinActiveLevel h + val2 <- togglePinActiveLevel h + val3 <- getPinActiveLevel h + val4 <- togglePinActiveLevel h + val5 <- getPinActiveLevel h + return (val1, val2, val3, val4, val5) + +invalidHandle :: (MonadGpio h m) => (h -> m a) -> m a +invalidHandle action = + do d <- openPin (Pin 1) + closePin d + action d + +testWithPin :: (MonadGpio h m, MonadMask m) => m PinValue +testWithPin = withPin (Pin 1) $ \h -> + do setPinOutputMode h OutputDefault Low + writePin h High + val <- readPin h + return val + +testNestedWithPin :: (MonadGpio h m, MonadMask m) => Pin -> Pin -> m (PinValue, PinValue) +testNestedWithPin p1 p2 = + withPin p1 $ \h1 -> + withPin p2 $ \h2 -> + do setPinOutputMode h1 OutputDefault Low + setPinOutputMode h2 OutputDefault Low + writePin h1 High + writePin h2 Low + val1 <- readPin h1 + val2 <- readPin h2 + return (val1, val2) + +handleGpioException :: MonadCatch m => (SomeGpioException -> m a) -> m a -> m a +handleGpioException = handle + +testWithPinError :: (MonadGpio h m, MonadMask m, MonadCatch m) => Pin -> Pin -> m (Maybe PinValue) +testWithPinError p1 p2 = handleGpioException (const $ return Nothing) $ + withPin p1 $ \h1 -> + withPin p2 $ \h2 -> + do setPinOutputMode h1 OutputDefault Low + setPinInputMode h2 InputDefault + writePin h1 High -- should fail if p1 == p2 + writePin h2 Low -- should fail in any case + val1 <- readPin h1 + return $ Just val1 + +chip0 :: MockGpioChip +chip0 = MockGpioChip "chip0" 0 (replicate 16 defaultMockPinState) + +chip1 :: MockGpioChip +chip1 = MockGpioChip "chip1" 32 (replicate 32 defaultMockPinState) + +evalSysfsGpioMock' :: SysfsGpioMock a -> MockWorld -> [MockGpioChip] -> Either (Maybe SysfsException) a +evalSysfsGpioMock' a w c = either (Left . fromException) return $ evalSysfsGpioMock a w c + +execSysfsGpioMock' :: SysfsGpioMock a -> MockWorld -> [MockGpioChip] -> Either (Maybe SysfsException) MockWorld +execSysfsGpioMock' a w c = either (Left . fromException) return $ execSysfsGpioMock a w c + +runSysfsGpioMock' :: SysfsGpioMock a -> MockWorld -> [MockGpioChip] -> Either (Maybe SysfsException) (a, MockWorld) +runSysfsGpioMock' a w c = either (Left . fromException) return $ runSysfsGpioMock a w c + +evalSysfsMock' :: SysfsMock a -> MockWorld -> [MockGpioChip] -> Either (Maybe SysfsException) a +evalSysfsMock' a w c = either (Left . fromException) Right $ evalSysfsMock a w c + +spec :: Spec +spec = + do describe "pins" $ + let pinList = map Pin [0..15] + expectedResult = Right pinList + in + it "returns the list of available pins" $ + evalSysfsGpioMock' pins initialMockWorld [chip0] `shouldBe` expectedResult + + describe "pinCapabilities" $ + do it "returns a pin's capabilities" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState + ,defaultMockPinState {_userVisibleDirection = False} + ,defaultMockPinState {_edge = Nothing}] + (Right result) = + evalSysfsGpioMock' + (do c1 <- pinCapabilities (Pin 1) + c2 <- pinCapabilities (Pin 2) + c3 <- pinCapabilities (Pin 3) + return (c1,c2,c3) + ) + initialMockWorld + [testChip] + in do result + `shouldBe` + (PinCapabilities (Set.fromList [InputDefault]) (Set.fromList [OutputDefault]) True, + PinCapabilities Set.empty Set.empty False, + PinCapabilities (Set.fromList [InputDefault]) (Set.fromList [OutputDefault]) False) + it "doesn't leave any pin state around" $ + let (Right world) = + execSysfsGpioMock (void $ pinCapabilities (Pin 1)) initialMockWorld [chip0] + in evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio1") world [] `shouldBe` Right False + it "fails if the pin doesn't exist" $ + let (Left failure) = + evalSysfsGpioMock' (pinCapabilities (Pin 99)) initialMockWorld [chip0] + in failure `shouldBe` (Just $ InvalidPin (Pin 99)) + + describe "openPin/closePin" $ + do it "cleans up properly" $ + let (Right world) = execSysfsGpioMock' testOpenClose initialMockWorld [chip0] + in evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio1") world [] `shouldBe` Right False + it "fails when the pin is unavailable" $ + evalSysfsGpioMock' testOpenClose initialMockWorld [chip1] `shouldBe` Left (Just $ InvalidPin (Pin 1)) + it "openPin does not error when the pin is already open" $ + evalSysfsGpioMock' (openPin (Pin 1) >> openPin (Pin 1) >> return ()) initialMockWorld [chip0] `shouldBe` Right () + + it "closePin does not error when the pin is already closed" $ + evalSysfsGpioMock' (do { h <- openPin (Pin 1) ; closePin h ; closePin h} ) initialMockWorld [chip0] `shouldBe` Right () + + describe "getPinDirection" $ + do it "gets the pin's direction" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In}] + in + do evalSysfsGpioMock' (withPin (Pin 1) getPinDirection) initialMockWorld [chip0] `shouldBe` Right Out + evalSysfsGpioMock' (withPin (Pin 1) getPinDirection) initialMockWorld [testChip] `shouldBe` Right In + + it "fails when the pin direction is not settable" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_userVisibleDirection = False}] + in evalSysfsGpioMock' (withPin (Pin 1) getPinDirection) initialMockWorld [testChip] `shouldBe` Left (Just $ NoDirectionAttribute (Pin 1)) + + describe "getPinInputMode" $ + do it "gets the pin's input mode" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In}] + in + evalSysfsGpioMock' (withPin (Pin 1) getPinInputMode) initialMockWorld [testChip] `shouldBe` Right InputDefault + it "fails when the pin's direction is Out" $ + evalSysfsGpioMock' (withPin (Pin 1) getPinInputMode) initialMockWorld [chip0] `shouldBe` Left (Just $ InvalidOperation (Pin 1)) + + describe "setPinInputMode" $ + do it "sets the pin's input mode and direction" $ + let testChip1 = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = Out, _edge = Just Falling, _activeLow = True}] + testChip2 = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In, _edge = Just Rising}] + (Right (result1,world1)) = runSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinInputMode h InputDefault >> getPinInputMode h) initialMockWorld [testChip1] + (Right (result2,world2)) = runSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinInputMode h InputDefault >> getPinInputMode h) initialMockWorld [testChip2] + in do result1 `shouldBe` InputDefault + result2 `shouldBe` InputDefault + Map.lookup (Pin 1) (mockWorldPins world1) `shouldBe` Just (defaultMockPinState {_direction = In, _edge = Just Falling, _activeLow = True}) + Map.lookup (Pin 1) (mockWorldPins world2) `shouldBe` Just (defaultMockPinState {_direction = In, _edge = Just Rising}) + + it "fails when the input mode is unsupported" $ + evalSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinInputMode h InputFloating) initialMockWorld [chip0] `shouldBe` Left (Just $ (UnsupportedInputMode InputFloating (Pin 1))) + it "fails when the pin's direction is not settable" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_userVisibleDirection = False}] + in evalSysfsGpioMock' (withPin (Pin 1) (\h -> setPinInputMode h InputDefault)) initialMockWorld [testChip] `shouldBe` Left (Just $ NoDirectionAttribute (Pin 1)) + + describe "getPinOutputMode" $ + do it "gets the pin's output mode" $ + evalSysfsGpioMock' (withPin (Pin 1) getPinOutputMode) initialMockWorld [chip0] `shouldBe` Right OutputDefault + it "fails when the pin's direction is Out" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In}] + in evalSysfsGpioMock' (withPin (Pin 1) getPinOutputMode) initialMockWorld [testChip] `shouldBe` Left (Just $ InvalidOperation (Pin 1)) + + describe "setPinOutputMode" $ + do it "sets the pin's output mode, value, and direction" $ + let testChip1 = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In, _value = Low}] + (Right (result1,world1)) = runSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinOutputMode h OutputDefault High >> getPinOutputMode h) initialMockWorld [testChip1] + testChip2 = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In, _value = Low}] + (Right (result2,world2)) = runSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinOutputMode h OutputDefault Low >> getPinOutputMode h) initialMockWorld [testChip2] + testChip3 = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = Out, _value = High}] + (Right (result3,world3)) = runSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinOutputMode h OutputDefault Low >> getPinOutputMode h) initialMockWorld [testChip3] + (Right (result4,world4)) = runSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinOutputMode h OutputDefault High >> getPinOutputMode h) initialMockWorld [chip0] + in do result1 `shouldBe` OutputDefault + result2 `shouldBe` OutputDefault + result3 `shouldBe` OutputDefault + result4 `shouldBe` OutputDefault + Map.lookup (Pin 1) (mockWorldPins world1) `shouldBe` Just (defaultMockPinState {_direction = Out, _value = High}) + Map.lookup (Pin 1) (mockWorldPins world2) `shouldBe` Just (defaultMockPinState {_direction = Out, _value = Low}) + Map.lookup (Pin 1) (mockWorldPins world3) `shouldBe` Just (defaultMockPinState {_direction = Out, _value = Low}) + Map.lookup (Pin 1) (mockWorldPins world4) `shouldBe` Just (defaultMockPinState {_direction = Out, _value = High}) + it "respects the pin's active level" $ + let testChip1 = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In, _value = Low, _activeLow = True}] + (Right (result1,world1)) = runSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinOutputMode h OutputDefault High >> getPinOutputMode h) initialMockWorld [testChip1] + testChip2 = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In, _value = Low, _activeLow = True}] + (Right (result2,world2)) = runSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinOutputMode h OutputDefault Low >> getPinOutputMode h) initialMockWorld [testChip2] + testChip3 = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = Out, _value = High, _activeLow = True}] + (Right (result3,world3)) = runSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinOutputMode h OutputDefault Low >> getPinOutputMode h) initialMockWorld [testChip3] + testChip4 = MockGpioChip "testChip" 1 [defaultMockPinState {_activeLow = True}] + (Right (result4,world4)) = runSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinOutputMode h OutputDefault High >> getPinOutputMode h) initialMockWorld [testChip4] + in do result1 `shouldBe` OutputDefault + result2 `shouldBe` OutputDefault + result3 `shouldBe` OutputDefault + result4 `shouldBe` OutputDefault + Map.lookup (Pin 1) (mockWorldPins world1) `shouldBe` Just (defaultMockPinState {_direction = Out, _activeLow = True, _value = Low}) + Map.lookup (Pin 1) (mockWorldPins world2) `shouldBe` Just (defaultMockPinState {_direction = Out, _activeLow = True, _value = High}) + Map.lookup (Pin 1) (mockWorldPins world3) `shouldBe` Just (defaultMockPinState {_direction = Out, _activeLow = True, _value = High}) + Map.lookup (Pin 1) (mockWorldPins world4) `shouldBe` Just (defaultMockPinState {_direction = Out, _activeLow = True, _value = Low}) + it "fails when the output mode is unsupported" $ + evalSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinOutputMode h OutputPushPull Low) initialMockWorld [chip0] `shouldBe` Left (Just $ (UnsupportedOutputMode OutputPushPull (Pin 1))) + it "can change the pin direction to 'Out' when the pin is configured for edge- or level-triggered reads " $ + evalSysfsGpioMock' + (withPin (Pin 1) $ \h -> + do setPinInputMode h InputDefault + setPinInterruptMode h RisingEdge + setPinOutputMode h OutputDefault Low + setPinInputMode h InputDefault + setPinInterruptMode h FallingEdge + setPinOutputMode h OutputDefault Low + setPinInputMode h InputDefault + setPinInterruptMode h Level + setPinOutputMode h OutputDefault Low + return True) + initialMockWorld + [chip0] + `shouldBe` Right True + it "fails when the pin's direction is not settable" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_userVisibleDirection = False}] + in evalSysfsGpioMock' (withPin (Pin 1) (\h -> setPinOutputMode h OutputDefault Low)) initialMockWorld [testChip] `shouldBe` Left (Just $ NoDirectionAttribute (Pin 1)) + + describe "getPinInterruptMode" $ + do it "gets the pin's interrupt mode" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_edge = Just Falling}] + in + do evalSysfsGpioMock' (withPin (Pin 1) getPinInterruptMode) initialMockWorld [chip0] `shouldBe` Right Disabled + evalSysfsGpioMock' (withPin (Pin 1) getPinInterruptMode) initialMockWorld [testChip] `shouldBe` Right FallingEdge + + it "fails when the pin's interrupt mode is not settable" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_edge = Nothing}] + in evalSysfsGpioMock' (withPin (Pin 1) getPinInterruptMode) initialMockWorld [testChip] `shouldBe` Left (Just $ NoEdgeAttribute (Pin 1)) + + describe "setPinInterruptMode" $ + do it "sets the pin's interrupt mode" $ + evalSysfsGpioMock' testSetInterruptMode initialMockWorld [chip0] `shouldBe` Right (Disabled, RisingEdge, FallingEdge, Level) + it "is idempotent" $ + evalSysfsGpioMock' testSetInterruptModeIdempotent initialMockWorld [chip0] `shouldBe` Right (FallingEdge, FallingEdge) + it "fails when the pin's interrupt mode is not settable" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_edge = Nothing}, defaultMockPinState] + in evalSysfsGpioMock' testSetInterruptMode initialMockWorld [testChip] `shouldBe` Left (Just $ NoEdgeAttribute (Pin 1)) + it "fails when the pin is configured for output" $ + evalSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinInterruptMode h Level) initialMockWorld [chip0] `shouldBe` Left (Just $ InvalidOperation (Pin 1)) + + describe "getPinActiveLevel" $ + do context "when active level is high" $ + do it "returns the pin's active level" $ + evalSysfsGpioMock' (withPin (Pin 1) getPinActiveLevel) initialMockWorld [chip0] `shouldBe` Right ActiveHigh + context "when active level is low" $ + do it "returns the pin's active level" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_activeLow = True}] + in evalSysfsGpioMock' (withPin (Pin 1) getPinActiveLevel) initialMockWorld [testChip] `shouldBe` Right ActiveLow + + describe "setPinActiveLevel" $ + do context "when active level is high" $ + do it "sets the pin's active level to low" $ + let (Right (result, world)) = runSysfsGpioMock' (withPin (Pin 1) (\h -> setPinActiveLevel h ActiveLow >> getPinActiveLevel h)) initialMockWorld [chip0] + in do result `shouldBe` ActiveLow + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just (defaultMockPinState {_activeLow = True}) + it "sets the pin's active level to high" $ + let (Right (result, world)) = runSysfsGpioMock' (withPin (Pin 1) (\h -> setPinActiveLevel h ActiveHigh >> getPinActiveLevel h)) initialMockWorld [chip0] + in do result `shouldBe` ActiveHigh + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just (defaultMockPinState {_activeLow = False}) + context "when active level is low" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_activeLow = True}] + in do it "sets the pin's active level to low" $ + let (Right (result, world)) = runSysfsGpioMock' (withPin (Pin 1) (\h -> setPinActiveLevel h ActiveLow >> getPinActiveLevel h)) initialMockWorld [testChip] + in do result `shouldBe` ActiveLow + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just (defaultMockPinState {_activeLow = True}) + it "sets the pin's active level to high" $ + let (Right (result, world)) = runSysfsGpioMock' (withPin (Pin 1) (\h -> setPinActiveLevel h ActiveHigh >> getPinActiveLevel h)) initialMockWorld [chip0] + in do result `shouldBe` ActiveHigh + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just (defaultMockPinState {_activeLow = False}) + + describe "togglePinActiveLevel" $ + do it "toggles the pin's active level when the pin is configured for output" $ + evalSysfsGpioMock' (withPin (Pin 1) testTogglePinActiveLevel) initialMockWorld [chip0] `shouldBe` Right (ActiveHigh, ActiveLow, ActiveLow, ActiveHigh, ActiveHigh) + it "and when the pin is configured for input" $ + evalSysfsGpioMock' (withPin (Pin 1) (\h -> setPinInputMode h InputDefault >> testTogglePinActiveLevel h)) initialMockWorld [chip0] `shouldBe` Right (ActiveHigh, ActiveLow, ActiveLow, ActiveHigh, ActiveHigh) + + describe "pollPin" $ + do it "waits for the specified trigger and returns the pin's value" $ + pendingWith "need to implement this" + + it "blocks when the interrupt mode is Disabled, until it is changed" $ + pendingWith "need to implement this" + + describe "pollPinTimeout" $ + do it "waits for the specified trigger and returns the pin's value" $ + pendingWith "need to implement this" + it "blocks when the interrupt mode is Disabled, until it is changed" $ + pendingWith "need to implement this" + it "times out" $ + pendingWith "need to implement this" + + describe "readPin" $ + do context "returns the pin's logical level" $ + do it "when the active level is high" $ + evalSysfsGpioMock' (withPin (Pin 1) (\h -> setPinActiveLevel h ActiveHigh >> readPin h)) initialMockWorld [chip0] `shouldBe` Right Low + it "when the active level is low" $ + evalSysfsGpioMock' (withPin (Pin 1) (\h -> setPinActiveLevel h ActiveLow >> readPin h)) initialMockWorld [chip0] `shouldBe` Right High + + describe "writePin" $ + do context "sets the pin's logical value" $ + do it "when the active level is high" $ + let Right (result, world) = runSysfsGpioMock' (withPin (Pin 1) testReadWritePin) initialMockWorld [chip0] + in do result `shouldBe` (Low, High, Low) + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState + it "when the active level is low" $ + let Right (result, world) = runSysfsGpioMock' (withPin (Pin 1) (\h -> setPinActiveLevel h ActiveLow >> testReadWritePin h)) initialMockWorld [chip0] + in do result `shouldBe` (High, Low, High) + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just (defaultMockPinState {_activeLow = True, _value = Low}) + + it "is idempotent" $ + evalSysfsGpioMock' testReadWritePinIdempotent initialMockWorld [chip0] `shouldBe` Right (Low, Low) + + it "fails when the pin direction is In" $ + evalSysfsGpioMock' testWritePinFailsOnInputPin initialMockWorld [chip0] `shouldBe` Left (Just $ PermissionDenied (Pin 1)) + + describe "togglePin" $ + do it "toggles the pin's value" $ + evalSysfsGpioMock' testTogglePinValue initialMockWorld [chip0] `shouldBe` Right (Low, High, High, Low, Low) + it "fails when the pin is not configured for output" $ + evalSysfsGpioMock' (withPin (Pin 1) (\h -> setPinInputMode h InputDefault >> togglePin h)) initialMockWorld [chip0] `shouldBe` Left (Just $ PermissionDenied (Pin 1)) + + describe "operations on an invalid handle fail" $ + -- Note: When used on an invalid handle, GPIO commands which + -- return a 'Maybe' result will fail differently than commands + -- which do not. This is by design. + do it "in getPinDirection" $ + evalSysfsGpioMock' (invalidHandle getPinDirection) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) + + it "in getPinInputMode" $ + evalSysfsGpioMock' (invalidHandle getPinInputMode) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) + + it "in setPinInputMode" $ + evalSysfsGpioMock' (invalidHandle (\d -> setPinInputMode d InputDefault)) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) + + it "in getPinOutputMode" $ + evalSysfsGpioMock' (invalidHandle getPinOutputMode) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) + + it "in setPinOutputMode" $ + evalSysfsGpioMock' (invalidHandle (\h -> setPinOutputMode h OutputDefault Low)) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) + + it "in readPin" $ + evalSysfsGpioMock' (invalidHandle readPin) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) + + it "in pollPin" $ + evalSysfsGpioMock' (invalidHandle pollPin) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) + + it "in pollPinTimeout" $ + evalSysfsGpioMock' (invalidHandle (\h -> pollPinTimeout h 10000)) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) + + it "in writePin" $ + evalSysfsGpioMock' (invalidHandle (\d -> writePin d High)) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) + + it "in togglePin" $ + evalSysfsGpioMock' (invalidHandle togglePin) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) + + it "in getPinInterruptMode" $ + evalSysfsGpioMock' (invalidHandle getPinInterruptMode) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) + + it "in setPinInterruptMode" $ + evalSysfsGpioMock' (invalidHandle (\d -> setPinInterruptMode d Level)) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) + + it "in getPinActiveLevel" $ + evalSysfsGpioMock' (invalidHandle getPinActiveLevel) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) + + it "in setPinActiveLevel" $ + evalSysfsGpioMock' (invalidHandle (\d -> setPinActiveLevel d ActiveHigh)) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) + + it "in togglePinActiveLevel" $ + evalSysfsGpioMock' (invalidHandle togglePinActiveLevel) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) + + describe "withPin" $ + do it "opens and closes the pin as expected" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_value = High}] + (Right world) = execSysfsGpioMock' testWithPin initialMockWorld [testChip] + in evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio1") world [] `shouldBe` Right False + + it "throws an exception when the pin doesn't exist" $ + evalSysfsGpioMock' testWithPin initialMockWorld [chip1] `shouldBe` Left (Just $ InvalidPin (Pin 1)) + + it "can nest" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_value = High}, defaultMockPinState] + (Right (result, world)) = runSysfsGpioMock' (testNestedWithPin (Pin 1) (Pin 2)) initialMockWorld [testChip] + in do result `shouldBe` (High, Low) + evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio1") world [] `shouldBe` Right False + evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio2") world [] `shouldBe` Right False + + it "handles double-open and double-close without complaint" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_value = High}, defaultMockPinState] + (Right (result, world)) = runSysfsGpioMock' (testNestedWithPin (Pin 1) (Pin 1)) initialMockWorld [testChip] + in do result `shouldBe` (Low, Low) + evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio1") world [] `shouldBe` Right False + + it "cleans up when an exception occurs in the computation" $ + let (Right (result, world)) = runSysfsGpioMock' (testWithPinError (Pin 1) (Pin 2)) initialMockWorld [chip0] + in do result `shouldBe` Nothing + evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio1") world [] `shouldBe` Right False + evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio2") world [] `shouldBe` Right False + + describe "InputPin" $ + do context "withInputPin" $ + do it "opens and configures a pin for input, then closes closes it" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In}, defaultMockPinState {_direction = Out}] + (Right world) = + execSysfsGpioMock' + (withInputPin (Pin 1) InputDefault Nothing $ \_ -> + withInputPin (Pin 2) InputDefault Nothing $ \_ -> + return () + ) + initialMockWorld + [testChip] + in do evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio1") world [] `shouldBe` Right False + evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio2") world [] `shouldBe` Right False + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In} + Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In} + it "sets the pin's input mode" $ + evalSysfsGpioMock' + (withInputPin (Pin 1) InputDefault Nothing $ \h -> + getInputPinInputMode h + ) + initialMockWorld + [chip0] + `shouldBe` Right InputDefault + it "sets (or doesn't) the pin's active level" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_activeLow = True}, defaultMockPinState {_activeLow = True}] + (Right world) = + execSysfsGpioMock' + (withInputPin (Pin 1) InputDefault Nothing $ \_ -> + withInputPin (Pin 2) InputDefault (Just ActiveHigh) $ \_ -> + return () + ) + initialMockWorld + [testChip] + in do Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = True} + Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = False} + it "fails if the pin's direction is fixed" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState, defaultMockPinState {_direction = Out, _userVisibleDirection = False}] + in evalSysfsGpioMock' + (withInputPin (Pin 1) InputDefault Nothing $ \_ -> + withInputPin (Pin 2) InputDefault (Just ActiveHigh) $ \_ -> + return () + ) + initialMockWorld + [testChip] + `shouldBe` + Left (Just $ NoDirectionAttribute (Pin 2)) + context "readInputPin" $ + do it "respects the pin's active level" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_value = High}, defaultMockPinState {_value = Low}] + in evalSysfsGpioMock' + (withInputPin (Pin 1) InputDefault Nothing $ \h1 -> + withInputPin (Pin 2) InputDefault (Just ActiveLow) $ \h2 -> + do v1 <- readInputPin h1 + v2 <- readInputPin h2 + return (v1,v2) + ) + initialMockWorld + [testChip] + `shouldBe` + Right (High,High) + context "getInputPinInputMode" $ + do it "gets the pin's input mode" $ + evalSysfsGpioMock' + (withInputPin (Pin 1) InputDefault Nothing $ \h -> + getInputPinInputMode h + ) + initialMockWorld + [chip0] + `shouldBe` Right InputDefault + context "get/setInputPinActiveLevel" $ + do it "gets/sets the pin's active level" $ + let (Right (result, world)) = + runSysfsGpioMock' + (withInputPin (Pin 1) InputDefault (Just ActiveHigh) $ \h1 -> + withInputPin (Pin 2) InputDefault (Just ActiveLow) $ \h2 -> + do setInputPinActiveLevel h1 ActiveLow + setInputPinActiveLevel h2 ActiveHigh + l1 <- getInputPinActiveLevel h1 + l2 <- getInputPinActiveLevel h2 + return (l1,l2) + ) + initialMockWorld + [chip0] + in do result `shouldBe` (ActiveLow,ActiveHigh) + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = True} + Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = False} + context "toggleInputPinActiveLevel" $ + do it "toggles the pin's active level and returns the new value" $ + let (Right (result, world)) = + runSysfsGpioMock' + (withInputPin (Pin 1) InputDefault (Just ActiveHigh) $ \h1 -> + withInputPin (Pin 2) InputDefault (Just ActiveLow) $ \h2 -> + do l1 <- toggleInputPinActiveLevel h1 + l2 <- toggleInputPinActiveLevel h2 + return (l1,l2) + ) + initialMockWorld + [chip0] + in do result `shouldBe` (ActiveLow,ActiveHigh) + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = True} + Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = False} + describe "InterruptPin" $ + do context "withInterruptPin" $ + do it "opens and configures a pin for interrupts, sets its interrupt mode, then closes closes it" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In, _edge = Just None}, defaultMockPinState {_direction = Out, _edge = Just Rising}] + (Right world) = + execSysfsGpioMock' + (withInterruptPin (Pin 1) InputDefault FallingEdge Nothing $ \_ -> + withInterruptPin (Pin 2) InputDefault Disabled Nothing $ \_ -> + return () + ) + initialMockWorld + [testChip] + in do evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio1") world [] `shouldBe` Right False + evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio2") world [] `shouldBe` Right False + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _edge = Just Falling} + Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _edge = Just None} + it "sets (or doesn't) the pin's active level" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_activeLow = True}, defaultMockPinState {_activeLow = True}] + (Right world) = + execSysfsGpioMock' + (withInterruptPin (Pin 1) InputDefault Disabled Nothing $ \_ -> + withInterruptPin (Pin 2) InputDefault Disabled (Just ActiveHigh) $ \_ -> + return () + ) + initialMockWorld + [testChip] + in do Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = True} + Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = False} + it "fails if the pin's direction is fixed" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState, defaultMockPinState {_direction = Out, _userVisibleDirection = False}] + in evalSysfsGpioMock' + (withInterruptPin (Pin 1) InputDefault Disabled Nothing $ \_ -> + withInterruptPin (Pin 2) InputDefault Disabled (Just ActiveHigh) $ \_ -> + return () + ) + initialMockWorld + [testChip] + `shouldBe` + Left (Just $ NoDirectionAttribute (Pin 2)) + it "fails if the pin doesn't support interrupts" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState, defaultMockPinState {_edge = Nothing}] + in evalSysfsGpioMock' + (withInterruptPin (Pin 1) InputDefault Disabled Nothing $ \_ -> + withInterruptPin (Pin 2) InputDefault Disabled (Just ActiveHigh) $ \_ -> + return () + ) + initialMockWorld + [testChip] + `shouldBe` + Left (Just $ NoEdgeAttribute (Pin 2)) + context "readInterruptPin" $ + do it "respects the pin's active level" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_value = High}, defaultMockPinState {_value = Low}] + in evalSysfsGpioMock' + (withInterruptPin (Pin 1) InputDefault Disabled Nothing $ \h1 -> + withInterruptPin (Pin 2) InputDefault Disabled (Just ActiveLow) $ \h2 -> + do v1 <- readInterruptPin h1 + v2 <- readInterruptPin h2 + return (v1,v2) + ) + initialMockWorld + [testChip] + `shouldBe` + Right (High,High) + context "getInterruptPinInputMode" $ + do it "gets the pin's input mode" $ + evalSysfsGpioMock' + (withInterruptPin (Pin 1) InputDefault Disabled Nothing $ \h -> + getInterruptPinInputMode h + ) + initialMockWorld + [chip0] + `shouldBe` Right InputDefault + context "get/setInterruptPinActiveLevel" $ + do it "gets/sets the pin's active level" $ + let (Right (result, world)) = + runSysfsGpioMock' + (withInterruptPin (Pin 1) InputDefault Disabled (Just ActiveHigh) $ \h1 -> + withInterruptPin (Pin 2) InputDefault Disabled (Just ActiveLow) $ \h2 -> + do setInterruptPinActiveLevel h1 ActiveLow + setInterruptPinActiveLevel h2 ActiveHigh + l1 <- getInterruptPinActiveLevel h1 + l2 <- getInterruptPinActiveLevel h2 + return (l1,l2) + ) + initialMockWorld + [chip0] + in do result `shouldBe` (ActiveLow,ActiveHigh) + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = True} + Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = False} + context "toggleInterruptPinActiveLevel" $ + do it "toggles the pin's active level and returns the new value" $ + let (Right (result, world)) = + runSysfsGpioMock' + (withInterruptPin (Pin 1) InputDefault Disabled (Just ActiveHigh) $ \h1 -> + withInterruptPin (Pin 2) InputDefault Disabled (Just ActiveLow) $ \h2 -> + do l1 <- toggleInterruptPinActiveLevel h1 + l2 <- toggleInterruptPinActiveLevel h2 + return (l1,l2) + ) + initialMockWorld + [chip0] + in do result `shouldBe` (ActiveLow,ActiveHigh) + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = True} + Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = False} + context "get/setInterruptPinInterruptMode" $ + do it "gets/sets the pin's interrupt mode" $ + let (Right (result, world)) = + runSysfsGpioMock' + (withInterruptPin (Pin 1) InputDefault Disabled Nothing $ \h1 -> + withInterruptPin (Pin 2) InputDefault RisingEdge Nothing $ \h2 -> + do setInterruptPinInterruptMode h1 RisingEdge + setInterruptPinInterruptMode h2 Disabled + m1 <- getInterruptPinInterruptMode h1 + m2 <- getInterruptPinInterruptMode h2 + return (m1,m2) + ) + initialMockWorld + [chip0] + in do result `shouldBe` (RisingEdge,Disabled) + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _edge = Just Rising} + Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _edge = Just None} + context "pollInterruptPin" $ + do it "waits for interrupts" $ + pendingWith "need to implement this" + it "respects the pin's active level" $ + pendingWith "need to implement this" + + context "pollInterruptPin" $ + do it "waits for interrupts" $ + pendingWith "need to implement this" + it "times out" $ + pendingWith "need to implement this" + it "respects the pin's active level" $ + pendingWith "need to implement this" + describe "OutputPin" $ + do context "withOutputPin" $ + do it "opens and configures a pin for output, sets its value, then closes closes it" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In}, defaultMockPinState {_direction = Out, _value = High}] + (Right world) = + execSysfsGpioMock' + (withOutputPin (Pin 1) OutputDefault Nothing High $ \_ -> + withOutputPin (Pin 2) OutputDefault Nothing Low $ \_ -> + return () + ) + initialMockWorld + [testChip] + in do evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio1") world [] `shouldBe` Right False + evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio2") world [] `shouldBe` Right False + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _value = High} + Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _value = Low} + it "sets (or doesn't) the pin's active level (and the output value is relative to it)" $ + let (Right world) = + execSysfsGpioMock' + (withOutputPin (Pin 1) OutputDefault Nothing Low $ \_ -> + withOutputPin (Pin 2) OutputDefault Nothing High $ \_ -> + withOutputPin (Pin 3) OutputDefault (Just ActiveLow) Low $ \_ -> + withOutputPin (Pin 4) OutputDefault (Just ActiveLow) High $ \_ -> + withOutputPin (Pin 5) OutputDefault (Just ActiveHigh) Low $ \_ -> + withOutputPin (Pin 6) OutputDefault (Just ActiveHigh) High $ \_ -> + return () + ) + initialMockWorld + [chip0] + in do Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState + Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _value = High} + Map.lookup (Pin 3) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _activeLow = True, _value = High} + Map.lookup (Pin 4) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _activeLow = True, _value = Low} + Map.lookup (Pin 5) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _value = Low} + Map.lookup (Pin 6) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _value = High} + it "fails if the pin's direction is fixed" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState, defaultMockPinState {_direction = Out, _userVisibleDirection = False}] + in evalSysfsGpioMock' + (withOutputPin (Pin 1) OutputDefault Nothing High $ \_ -> + withOutputPin (Pin 2) OutputDefault Nothing Low $ \_ -> + return () + ) + initialMockWorld + [testChip] + `shouldBe` + Left (Just $ NoDirectionAttribute (Pin 2)) + context "readOutputPin" $ + do it "respects the pin's active level" $ + evalSysfsGpioMock' + (withOutputPin (Pin 1) OutputDefault Nothing Low $ \h1 -> + withOutputPin (Pin 2) OutputDefault (Just ActiveLow) High $ \h2 -> + do v1 <- readOutputPin h1 + v2 <- readOutputPin h2 + return (v1,v2) + ) + initialMockWorld + [chip0] + `shouldBe` + Right (Low,High) + context "writeOutputPin" $ + do it "writes the output value and respects the pin's active level" $ + let (Right world) = + execSysfsGpioMock' + (withOutputPin (Pin 1) OutputDefault (Just ActiveLow) High $ \h1 -> + withOutputPin (Pin 2) OutputDefault (Just ActiveLow) Low $ \h2 -> + withOutputPin (Pin 3) OutputDefault (Just ActiveHigh) High $ \h3 -> + withOutputPin (Pin 4) OutputDefault (Just ActiveHigh) Low $ \h4 -> + do writeOutputPin h1 Low + writeOutputPin h2 High + writeOutputPin h3 Low + writeOutputPin h4 High + ) + initialMockWorld + [chip0] + in do Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _activeLow = True, _value = High} + Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _activeLow = True, _value = Low} + Map.lookup (Pin 3) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _value = Low} + Map.lookup (Pin 4) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _value = High} + context "toggleOutputPin" $ + do it "toggles the output value, returns the new value, and respects the pin's active level" $ + let (Right (result, world)) = + runSysfsGpioMock' + (withOutputPin (Pin 1) OutputDefault (Just ActiveLow) High $ \h1 -> + withOutputPin (Pin 2) OutputDefault (Just ActiveLow) Low $ \h2 -> + withOutputPin (Pin 3) OutputDefault (Just ActiveHigh) High $ \h3 -> + withOutputPin (Pin 4) OutputDefault (Just ActiveHigh) Low $ \h4 -> + do v1 <- toggleOutputPin h1 + v2 <- toggleOutputPin h2 + v3 <- toggleOutputPin h3 + v4 <- toggleOutputPin h4 + return (v1,v2,v3,v4) + ) + initialMockWorld + [chip0] + in do result `shouldBe` (Low,High,Low,High) + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _activeLow = True, _value = High} + Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _activeLow = True, _value = Low} + Map.lookup (Pin 3) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _value = Low} + Map.lookup (Pin 4) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _value = High} + context "getOutputPinOutputMode" $ + do it "gets the pin's input mode" $ + evalSysfsGpioMock' + (withOutputPin (Pin 1) OutputDefault Nothing Low $ \h -> + getOutputPinOutputMode h + ) + initialMockWorld + [chip0] + `shouldBe` Right OutputDefault + context "get/setOutputPinActiveLevel" $ + do it "gets/sets the pin's active level" $ + let (Right (result, world)) = + runSysfsGpioMock' + (withOutputPin (Pin 1) OutputDefault (Just ActiveHigh) Low $ \h1 -> + withOutputPin (Pin 2) OutputDefault (Just ActiveLow) Low $ \h2 -> + do setOutputPinActiveLevel h1 ActiveLow + setOutputPinActiveLevel h2 ActiveHigh + l1 <- getOutputPinActiveLevel h1 + l2 <- getOutputPinActiveLevel h2 + return (l1,l2) + ) + initialMockWorld + [chip0] + in do result `shouldBe` (ActiveLow,ActiveHigh) + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _activeLow = True} + Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _activeLow = False, _value = High} + context "toggleOutputPinActiveLevel" $ + do it "toggles the pin's active level and returns the new value" $ + let (Right (result, world)) = + runSysfsGpioMock' + (withOutputPin (Pin 1) OutputDefault (Just ActiveHigh) Low $ \h1 -> + withOutputPin (Pin 2) OutputDefault (Just ActiveLow) Low $ \h2 -> + do l1 <- toggleOutputPinActiveLevel h1 + l2 <- toggleOutputPinActiveLevel h2 + return (l1,l2) + ) + initialMockWorld + [chip0] + in do result `shouldBe` (ActiveLow,ActiveHigh) + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _activeLow = True} + Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _activeLow = False, _value = High} diff --git a/test/System/GPIO/TypesSpec.hs b/test/System/GPIO/TypesSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/GPIO/TypesSpec.hs @@ -0,0 +1,142 @@ +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} +{-# LANGUAGE CPP #-} + +#ifndef MIN_VERSION_base +#define MIN_VERSION_base(x,y,z) 1 +#endif + +module System.GPIO.TypesSpec (spec) where + +import System.GPIO.Types + +import Data.Bits +import Test.Hspec +import Test.QuickCheck (property) + +-- Test all our hand-derived instances and functions. + +-- PinValue mimics Bool with respect to Bits and FiniteBits. +-- +ib2v :: (Int -> Bool) -> Int -> PinValue +ib2v f n = boolToValue $ f n + +bi2v :: (Bool -> Int) -> PinValue -> Int +bi2v f a = f (valueToBool a) + +bb2v :: (Bool -> Bool) -> PinValue -> PinValue +bb2v f a = boolToValue $ f (valueToBool a) + +bbb2v :: (Bool -> Bool -> Bool) -> PinValue -> PinValue -> PinValue +bbb2v f a b = boolToValue $ f (valueToBool a) (valueToBool b) + +bib2v :: (Bool -> Int -> Bool) -> PinValue -> Int -> PinValue +bib2v f a n = boolToValue $ f (valueToBool a) n + +#if MIN_VERSION_base(4,8,0) +newBase :: Spec +newBase = + do context "implements the new base-4.8.0.0 FiniteBits typeclass methods" $ + do it "countLeadingZeros" $ property $ + \a -> countLeadingZeros a == bi2v countLeadingZeros a + it "countTrailingZeros" $ property $ + \a -> countTrailingZeros a == bi2v countTrailingZeros a +#else +newBase :: Spec +newBase = return () +#endif + +spec :: Spec +spec = + do describe "Pin" $ + do it "pinNumber" $ property $ + \p@(Pin n) -> n == pinNumber p + + describe "PinDirection" $ + do it "invertDirection" $ + invertDirection In == Out + && invertDirection Out == In + + describe "PinValue" $ + do it "invertValue" $ property $ + \a -> invertValue a == complement a + + it "valueToBool" $ + valueToBool Low == False + && valueToBool High == True + + it "boolToValue" $ + boolToValue False == Low + && boolToValue True == High + + context "implements the Bits typeclass" $ + do it "(.&.)" $ property $ + \a b -> a .&. b == bbb2v (.&.) a b + + it "(.|.)" $ property $ + \a b -> a .|. b == bbb2v (.|.) a b + + it "xor" $ property $ + \a b -> a `xor` b == bbb2v xor a b + + it "complement" $ property $ + \a -> complement a == bb2v complement a + + it "shift" $ property $ + \a n -> a `shift` n == bib2v shift a n + + it "rotate" $ property $ + \a n -> a `rotate` n == bib2v rotate a n + + it "zeroBits" $ property $ + (zeroBits :: PinValue) == boolToValue (zeroBits:: Bool) + + it "bit" $ property $ + \n -> bit n == ib2v bit n + + it "setBit" $ property $ + \a n -> a `setBit` n == bib2v setBit a n + + it "clearBit" $ property $ + \a n -> a `clearBit` n == bib2v clearBit a n + + it "complementBit" $ property $ + \a n -> a `complementBit` n == bib2v complementBit a n + + it "testBit" $ property $ + \a n -> testBit a n == testBit (valueToBool a) n + + it "bitSizeMaybe" $ property $ + \a -> bitSizeMaybe a == bitSizeMaybe (valueToBool a) + + it "bitSize" $ property $ + \a -> bitSize a == bitSize (valueToBool a) + + it "isSigned" $ property $ + \a -> isSigned a == isSigned (valueToBool a) + + it "shiftL" $ property $ + \a n -> a `shiftL` n == bib2v shiftL a n + + it "unsafeShiftL" $ property $ + \a n -> a `unsafeShiftL` n == bib2v unsafeShiftL a n + + it "shiftR" $ property $ + \a n -> a `shiftR` n == bib2v shiftR a n + + it "unsafeShiftR" $ property $ + \a n -> a `unsafeShiftR` n == bib2v unsafeShiftR a n + + it "rotateL" $ property $ + \a n -> a `rotateL` n == bib2v rotateL a n + + it "rotateR" $ property $ + \a n -> a `rotateR` n == bib2v rotateR a n + + it "popCount" $ property $ + \a -> popCount a == popCount (valueToBool a) + + context "implements the FiniteBits typeclass" $ + do it "finiteBitSize" $ property $ + \a -> finiteBitSize a == bi2v finiteBitSize a + + newBase