diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/gpio.cabal b/gpio.cabal new file mode 100644 --- /dev/null +++ b/gpio.cabal @@ -0,0 +1,43 @@ +name: gpio +version: 0.1.0.0 +synopsis: Simple project template from stack +description: Please see README.md +homepage: http://github.com/githubuser/gpio#readme +license: BSD3 +license-file: LICENSE +author: Author name here +maintainer: example@example.com +copyright: 2016 Author name here +category: Web +build-type: Simple +cabal-version: >=1.10 + + +library + hs-source-dirs: src/lib + ghc-options: -Wall + default-language: Haskell2010 + exposed-modules: System.GPIO, System.GPIO.Types + default-extensions: + OverloadedStrings NoImplicitPrelude LambdaCase + StandaloneDeriving FlexibleContexts ScopedTypeVariables + KindSignatures DataKinds GADTs + build-depends: + base >= 4.5 && < 5, + basic-prelude, + string-conversions, + monad-control + +executable gpio + hs-source-dirs: src/gpio + ghc-options: -Wall + default-language: Haskell2010 + main-is: Main.hs + build-depends: + base >= 4.5 && < 5, + gpio, + basic-prelude + default-extensions: + OverloadedStrings NoImplicitPrelude LambdaCase + StandaloneDeriving FlexibleContexts ScopedTypeVariables + KindSignatures DataKinds GADTs diff --git a/src/gpio/Main.hs b/src/gpio/Main.hs new file mode 100644 --- /dev/null +++ b/src/gpio/Main.hs @@ -0,0 +1,50 @@ +module Main (main) where + +import BasicPrelude +import Control.Concurrent + +import System.GPIO +import System.GPIO.Types + +main :: IO () +main = + getArgs >>= \case + ["export", i, dir] -> case (readMay i >>= fromInt, fromText dir) of + (Just p, Right d) -> case d of + In -> void (initReaderPin p) + Out -> void (initWriterPin p) + _ -> usageError + ["unexport", i] -> case readMay i >>= fromInt of + -- Note: chose a random pin type when closing the pin - doesn't matter... + Just p -> closePin (ReaderPin p) + Nothing -> usageError + ["read", i] -> case readMay i >>= fromInt of + Nothing -> usageError + Just p -> readPin (ReaderPin p) >>= print + ["write", i, val] -> case (readMay i >>= fromInt, fromText val) of + (Just p, Right v) -> writePin (WriterPin p) v + _ -> usageError + [x] -> case (readMay x :: Maybe Int) of + Nothing -> usageError + Just i -> runTest i + _ -> error "Illegal usage!" + where + usageError = error "gpio (init PIN_NUM DIR|close PIN_NUM|read PIN_NUM|write PIN_NUM VALUE|SECONDS)" + runTest s = do + putStrLn "In program" + p <- initWriterPin P18 + + putStrLn $ "Got pin: " ++ show p + writePin p HI + + putStrLn "Set to HI" + v <- readPin p + putStrLn $ "Pin value: " <> show v + + threadDelay (1000000 * s) + putStrLn "Delay over" + + writePin p LO + v' <- readPin p + putStrLn $ "New Pin value: " <> show v' + closePin p diff --git a/src/lib/System/GPIO.hs b/src/lib/System/GPIO.hs new file mode 100644 --- /dev/null +++ b/src/lib/System/GPIO.hs @@ -0,0 +1,103 @@ +module System.GPIO + -- Re-exported types + ( Pin(..) + , ActivePin + , Value(..) + , Dir(..) + + -- Exported API + , initReaderPin + , initWriterPin + , readPin + , writePin + , closePin + ) where + +import BasicPrelude +import Control.Monad.Trans.Control +import Data.String.Conversions + +import System.GPIO.Types + + +-- Exported API ---------------------------------------------------------------- + +initReaderPin :: (MonadBaseControl IO m, MonadIO m) => Pin -> m (ActivePin 'In) +initReaderPin p = initPin activePin >> return activePin + where activePin = ReaderPin p + +initWriterPin :: Pin -> IO (ActivePin 'Out) +initWriterPin p = initPin activePin >> return activePin + where activePin = WriterPin p + +readPin :: (MonadBaseControl IO m, MonadIO m) => ActivePin a -> m Value +readPin p = do + x <- liftIO $ readFile (valuePath $ pin p) + + -- TODO: handle errors after cleaning this up... + case fromText (runLineHack x) of + Right v -> return v + Left e -> error $ convertString $ + "Error reading value file for \"" <> show p <> "\": " <> e + where + -- Note: too lazy to properly handle new lines in the value files + -- it looks like the gpio interface appends newlines + -- so file is read as "1\n" + -- TODO: handle correctly, maybe use hGetChar or something... + runLineHack t = case lines t of + [] -> error "Error: runLineHack failed us." + (x:_) -> x + +writePin :: (MonadBaseControl IO m, MonadIO m) => ActivePin 'Out -> Value -> m () +writePin p v = withVerboseError + ("Error writing value \"" <> show v <> "\" to " <> show p <> ".") + $ liftIO (writeFile (valuePath $ pin p) (toText v)) + +closePin :: (MonadBaseControl IO m, MonadIO m) => ActivePin a -> m () +closePin p = withVerboseError + ("Error closing " <> show p <> ". Was this pin already closed?") + $ liftIO (writeFile unexportPath (pinNumT $ pin p)) + + +-- Internal Pin Utils ---------------------------------------------------------- + +initPin :: (MonadBaseControl IO m, MonadIO m) => ActivePin a -> m () +initPin p = do + let exportErrorMsg = "Error initializing " <> show p <> ". Was this pin already initialized?" + setDirErrorMsg = "Error setting direction for " <> show p <> "." + withVerboseError exportErrorMsg export + withVerboseError setDirErrorMsg setDirection + where + export = liftIO $ writeFile exportPath (pinNumT $ pin p) + setDirection = liftIO $ writeFile (directionPath $ pin p) (toText dir) + dir :: Dir + dir = case p of ReaderPin _ -> In + WriterPin _ -> Out + + +withVerboseError :: (MonadBaseControl IO m) => Text -> m () -> m () +withVerboseError msg = handle handleError + where + handleError :: SomeException -> m () + handleError e = error $ convertString (msg <> "\nRaw Error: " <> show e) + + +-- Path Utils ------------------------------------------------------------------ + +basePath :: FilePath +basePath = "/sys/class/gpio" + +exportPath :: FilePath +exportPath = basePath <> "/export" + +unexportPath :: FilePath +unexportPath = basePath <> "/unexport" + +pinPath :: Pin -> FilePath +pinPath p = basePath <> "/gpio" <> convertString (pinNumT p) + +valuePath :: Pin -> FilePath +valuePath p = pinPath p <> "/value" + +directionPath :: Pin -> FilePath +directionPath p = pinPath p <> "/direction" diff --git a/src/lib/System/GPIO/Types.hs b/src/lib/System/GPIO/Types.hs new file mode 100644 --- /dev/null +++ b/src/lib/System/GPIO/Types.hs @@ -0,0 +1,66 @@ +module System.GPIO.Types where + +import BasicPrelude +import Data.String.Conversions + + +-- Core Types ------------------------------------------------------------------ + +data Pin = P18 | P23 | P24 | P25 deriving (Eq, Show, Enum) + +pinNumDict :: [(Pin, Int)] +pinNumDict = [ (P18, 18) + , (P23, 23) + , (P24, 24) + , (P25, 25) + ] + +pinNum :: Pin -> Int +pinNum p = fromMaybe unexpectedError (lookup p pinNumDict) + where + unexpectedError = error $ convertString + ("Unexpected error. " ++ show p ++ " not defined in 'pinNumDict'") + +pinNumT :: Pin -> Text +pinNumT = show . pinNum + +fromInt :: Int -> Maybe Pin +fromInt i = lookup i (swap <$> pinNumDict) + +data ActivePin (a :: Dir) where + ReaderPin :: Pin -> ActivePin 'In + WriterPin :: Pin -> ActivePin 'Out + +deriving instance Show (ActivePin a) + +pin :: ActivePin a -> Pin +pin = \case ReaderPin p -> p + WriterPin p -> p + +data Dir = In | Out deriving (Show) + +instance ToText Dir where + toText = \case In -> "in" + Out -> "out" +instance FromText Dir where + fromText = \case "in" -> Right In + "out" -> Right Out + x -> Left ("Cannot parse \"Dir\" from \"" <> x <> "\"") + +data Value = HI | LO deriving (Show) + +instance ToText Value where + toText = \case HI -> "1" + LO -> "0" +instance FromText Value where + fromText = \case "1" -> Right HI + "0" -> Right LO + x -> Left ("Cannot parse \"Value\" from \"" <> x <> "\"") + +-- We are going to do a lot of reading/writing to files w/ custom data types. +-- Create a small interface to keep conversions consistent. +class ToText a where + toText :: a -> Text + +class FromText a where + fromText :: Text -> Either Text a