diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,14 @@ +Haskell GPIO interface, designed specifically for the RaspberryPi. + +This library also ships with an executable for directly running gpio commands. Note: when using the executable there are less guarantees about the current state of a pin. For example, when using the library we can be sure that an `ActivePin 'Out` has already been initialized and configured for writing values, when using the executable we are less sure, and therefore errors might occur. + + +Note: this package has limited functionality, might be buggy and is not optimized. It works for simple read/write operations on a few pre-defined pins, but still needs a lot more testing. + +TODO: + * Remove `runLineHack` when reading GPIO value files. + * Optimize file reading to only look at first char. + * Support other pin modes (in/out/up/down/pwm) + * Support edges + * Look into GPIO supported file watching + * Add all pin numbers diff --git a/exec/Main.hs b/exec/Main.hs new file mode 100644 --- /dev/null +++ b/exec/Main.hs @@ -0,0 +1,44 @@ +module Main (main) where + +import Control.Monad +import Options.Generic + +import System.GPIO + +data Command + = Init Int String + | Read Int String + | Write Int String + | Close Int String + deriving (Generic, Show) + +instance ParseRecord Command + +main :: IO () +main = getRecord "GPIO" >>= \case + Init x "in" -> void (initReaderPin (getPin x)) + Init x "out" -> void (initWriterPin (getPin x)) + Init _ _ -> error "Usage error: use 'in' or 'out' for export direction." + + Read x "in" -> reattachToReaderPin (getPin x) >>= readPin >>= print + Read x "out" -> reattachToWriterPin (getPin x) >>= readPin >>= print + Read _ _ -> error "Usage error: use 'in' or 'out' for export direction." + + Write x "hi" -> reattachToWriterPin (getPin x) >>= writePin HI + Write x "lo" -> reattachToWriterPin (getPin x) >>= writePin LO + Write _ _ -> error "Usage error: use 'hi' or 'lo' for write value." + + Close x "in" -> reattachToReaderPin (getPin x) >>= closePin + Close x "out" -> reattachToWriterPin (getPin x) >>= closePin + Close _ _ -> error "Usage error: use 'in' or 'out' for export direction." + where + getPin = throwLeft . parsePin + + +parsePin :: Int -> Either String Pin +parsePin x = case fromInt x of + Nothing -> Left ("Usage error: could not parse pin value from integer: " ++ show x) + Just p -> Right p + +throwLeft :: Either String a -> a +throwLeft = either error id diff --git a/gpio.cabal b/gpio.cabal --- a/gpio.cabal +++ b/gpio.cabal @@ -1,45 +1,56 @@ -name: gpio -version: 0.1.0.2 -synopsis: Haskell GPIO interface, designed specifically for the RaspberryPi. -description: Please see README.md -homepage: http://github.com/tgolson/gpio -license: BSD3 -license-file: LICENSE -author: Tyler Olson -maintainer: tydotg@gmail.com -copyright: 2016 Tyler Olson -category: Hardware -build-type: Simple -cabal-version: >=1.10 +-- This file has been generated from package.yaml by hpack version 0.14.0. +-- +-- see: https://github.com/sol/hpack +name: gpio +version: 0.1.0.3 +synopsis: Haskell GPIO interface, designed specifically for the RaspberryPi. +description: Please see README.md +category: Hardware +homepage: http://github.com/tgolson/gpio +author: Tyler Olson +maintainer: tydotg@gmail.com +copyright: 2016 Tyler Olson +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: + README.md + 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 + hs-source-dirs: + lib + default-extensions: DataKinds DeriveGeneric FlexibleContexts FlexibleInstances GADTs KindSignatures LambdaCase OverloadedStrings ScopedTypeVariables StandaloneDeriving + ghc-options: -Wall build-depends: - base >= 4.5 && < 5, - basic-prelude, - monad-control, - string-conversions + base >= 4.7 && < 5 + , directory + , exceptions + , monad-control + , optparse-generic + , safe + exposed-modules: + System.GPIO + other-modules: + System.GPIO.Path + System.GPIO.Types + Paths_gpio + default-language: Haskell2010 executable gpio - hs-source-dirs: src/gpio - ghc-options: -Wall - default-language: Haskell2010 - main-is: Main.hs + main-is: Main.hs + hs-source-dirs: + exec + default-extensions: DataKinds DeriveGeneric FlexibleContexts FlexibleInstances GADTs KindSignatures LambdaCase OverloadedStrings ScopedTypeVariables StandaloneDeriving + ghc-options: -Wall build-depends: - base >= 4.5 && < 5, - gpio, - basic-prelude, - optparse-generic, - string-conversions - default-extensions: - OverloadedStrings NoImplicitPrelude LambdaCase - StandaloneDeriving FlexibleContexts ScopedTypeVariables - KindSignatures DataKinds GADTs DeriveGeneric + base >= 4.7 && < 5 + , directory + , exceptions + , monad-control + , optparse-generic + , safe + , gpio + default-language: Haskell2010 diff --git a/lib/System/GPIO.hs b/lib/System/GPIO.hs new file mode 100644 --- /dev/null +++ b/lib/System/GPIO.hs @@ -0,0 +1,112 @@ +module System.GPIO + -- Re-exported types + ( Pin(..) + , fromInt + , ActivePin + , Value(..) + , Direction + + -- Exported API + , initReaderPin + , initWriterPin + , readPin + , writePin + , reattachToReaderPin + , reattachToWriterPin + , closePin + ) where + +import Control.Exception (SomeException (..)) +import Control.Monad +import Control.Monad.Catch +import Control.Monad.IO.Class +import Data.Maybe +import Safe +import System.Directory + +import System.GPIO.Path +import System.GPIO.Types + + +data PinException + = InitPinException Pin String + | SetDirectionException Pin Direction String + | ReadPinException Pin String + | WritePinException Pin Value String + | ReattachPinException Pin String + | ClosePinException Pin String + deriving (Show) + +instance Exception PinException + + +initReaderPin :: (MonadCatch m, MonadIO m) => Pin -> m (ActivePin 'In) +initReaderPin = initPin . ReaderPin + +initWriterPin :: (MonadCatch m, MonadIO m) => Pin -> m (ActivePin 'Out) +initWriterPin = initPin . WriterPin + +initPin :: (MonadCatch m, MonadIO m) => ActivePin a -> m (ActivePin a) +initPin pin = do + withVerboseError (InitPinException (unpin pin)) $ + writeFileM exportPath (toData $ unpin pin) + + withVerboseError (SetDirectionException (unpin pin) (direction pin)) $ + writeFileM (directionPath $ unpin pin) (toData (direction pin)) + + return pin + + +readPin :: (MonadCatch m, MonadIO m) => ActivePin a -> m Value +readPin pin = do + x <- readFirstLine $ valuePath (unpin pin) + + case fromData x of + Right v -> return v + Left e -> throwM $ ReadPinException (unpin pin) e + + +writePin :: (MonadCatch m, MonadIO m) => Value -> ActivePin 'Out -> m () +writePin value pin = withVerboseError (WritePinException (unpin pin) value) + $ writeFileM (valuePath $ unpin pin) (toData value) + + +-- Get an active pin from a pin, preserving the invariants required when a pin is initialized. +-- Useful for CLI type commands where pointers to an active pin can be lost between calls. +reattachToReaderPin :: (MonadCatch m, MonadIO m) => Pin -> m (ActivePin 'In) +reattachToReaderPin = reattachToPin . ReaderPin + +reattachToWriterPin :: (MonadCatch m, MonadIO m) => Pin -> m (ActivePin 'Out) +reattachToWriterPin = reattachToPin . WriterPin + +reattachToPin :: (MonadCatch m, MonadIO m) => ActivePin a -> m (ActivePin a) +reattachToPin pin = do + let err = ReattachPinException (unpin pin) + + exists <- liftIO $ doesFileExist (directionPath (unpin pin)) + unless exists $ throwM (err "Pin was never initialized") + + v <- fromData <$> readFirstLine (directionPath (unpin pin)) + dir <- either (throwM . err) return v + + unless (dir == direction pin) $ throwM (err "Attempting to reattach to pin in wrong direction") + + return pin + + +closePin :: (MonadCatch m, MonadIO m) => ActivePin a -> m () +closePin pin = withVerboseError (ClosePinException (unpin pin)) + $ writeFileM unexportPath (toData $ unpin pin) + + +withVerboseError :: MonadCatch m => (String -> PinException) -> m () -> m () +withVerboseError pinException = handle $ \(e :: SomeException) -> throwM $ pinException (show e) + +writeFileM :: MonadIO m => FilePath -> String -> m () +writeFileM fp = liftIO . writeFile fp + +readFileM :: MonadIO m => FilePath -> m String +readFileM = liftIO . readFile + +readFirstLine :: MonadIO m => FilePath -> m String +readFirstLine = fmap (fromMaybe mempty . headMay . lines) . readFileM diff --git a/lib/System/GPIO/Path.hs b/lib/System/GPIO/Path.hs new file mode 100644 --- /dev/null +++ b/lib/System/GPIO/Path.hs @@ -0,0 +1,31 @@ +module System.GPIO.Path + ( basePath + , exportPath + , unexportPath + , pinPath + , valuePath + , directionPath + ) where + +import Data.Monoid ((<>)) + +import System.GPIO.Types + + +basePath :: FilePath +basePath = "/sys/class/gpio" + +exportPath :: FilePath +exportPath = basePath <> "/export" + +unexportPath :: FilePath +unexportPath = basePath <> "/unexport" + +pinPath :: Pin -> FilePath +pinPath pin = basePath <> "/gpio" <> toPath pin + +valuePath :: Pin -> FilePath +valuePath pin = pinPath pin <> "/value" + +directionPath :: Pin -> FilePath +directionPath pin = pinPath pin <> "/direction" diff --git a/lib/System/GPIO/Types.hs b/lib/System/GPIO/Types.hs new file mode 100644 --- /dev/null +++ b/lib/System/GPIO/Types.hs @@ -0,0 +1,82 @@ +module System.GPIO.Types + ( Pin(..) + , pinNum + , fromInt + , unpin + , direction + , ActivePin(..) + , Direction(..) + , Value(..) + , toPath + , toData + , fromData + ) where + + +import Data.Monoid ((<>)) +import Safe + + +-- Available pins and ordering of the pin numbers corresponds to chart found here: +-- https://www.raspberrypi.org/documentation/usage/gpio-plus-and-raspi2/ +data Pin + = P2 | P3 | P4 | P17 | P27 | P22 | P10 | P9 | P11 | P5 | P6 | P13 | P19 | P26 + | P14 | P15 | P18 | P23 | P24 | P25 | P8 | P7 | P12 | P16 | P20 | P21 + deriving (Eq, Read, Show, Enum) + +instance ToPath Pin where toPath = show . pinNum +instance ToData Pin where toData = toPath + +pinNum :: Pin -> Int +pinNum = read . tail . show + +fromInt :: Int -> Maybe Pin +fromInt x = readMay ("P" ++ show x) + +data ActivePin (a :: Direction) where + ReaderPin :: Pin -> ActivePin 'In + WriterPin :: Pin -> ActivePin 'Out + +deriving instance Show (ActivePin a) + +unpin :: ActivePin a -> Pin +unpin = \case ReaderPin p -> p + WriterPin p -> p + +direction :: ActivePin a -> Direction +direction = \case ReaderPin _ -> In + WriterPin _ -> Out + + +data Direction = In | Out deriving (Eq, Show) + +instance ToData Direction where + toData = \case In -> "in" + Out -> "out" + +instance FromData Direction where + fromData = \case "in" -> Right In + "out" -> Right Out + x -> Left ("Cannot parse \"Direction\" from \"" <> x <> "\"") + + +data Value = HI | LO deriving (Eq, Show) + +instance ToData Value where + toData = \case HI -> "1" + LO -> "0" + +instance FromData Value where + fromData = \case "1" -> Right HI + "0" -> Right LO + x -> Left ("Cannot parse \"Value\" from \"" <> x <> "\"") + + +class ToPath a where + toPath :: a -> FilePath + +class ToData a where + toData :: a -> String + +class FromData a where + fromData :: String -> Either String a diff --git a/src/gpio/Main.hs b/src/gpio/Main.hs deleted file mode 100644 --- a/src/gpio/Main.hs +++ /dev/null @@ -1,57 +0,0 @@ -module Main (main) where - -import BasicPrelude -import Data.String.Conversions -import Options.Generic - -import System.GPIO -import System.GPIO.Types - -data InputCommand - = Export Int String - | Unexport Int - | Read Int - | Write Int String - deriving (Generic, Show) - -instance ParseRecord InputCommand - --- optparse-generic has trouble with nested types --- so we can't make 'Command' a parse record --- Instead we use RawCommand for the generic instance, then --- convert to the actual 'Command' type. -data Command - = CmdExport Pin Dir - | CmdUnexport Pin - | CmdRead Pin - | CmdWrite Pin Value - deriving (Generic, Show) - - -toCommand :: InputCommand -> Either Text Command -toCommand = - \case Export i "in" -> (`CmdExport` In) <$> parsePin i - Export i "out" -> (`CmdExport` Out) <$> parsePin i - Export _ _ -> Left "Usage error: use 'in' or 'out' for export direction." - Unexport i -> CmdUnexport <$> parsePin i - Read i -> CmdRead <$> parsePin i - Write i "hi" -> (`CmdWrite` HI) <$> parsePin i - Write i "lo" -> (`CmdWrite` LO) <$> parsePin i - Write _ _ -> Left "Usage error: use 'hi' or 'lo' for write value." - where - parsePin i = case fromInt i of - Nothing -> Left ("Usage error: could not parse pin value from integer: " ++ show i) - Just p -> Right p - -main :: IO () -main = - toCommand <$> getRecord "GPIO" >>= \case - Left e -> error (convertString e) - Right cmd -> case cmd of - CmdExport p In -> void (initReaderPin p) - CmdExport p Out -> void (initWriterPin p) - -- Note: chose a random pin type when closing the pin - -- the type doesn't actually matter... - CmdUnexport p -> closePin (ReaderPin p) - CmdRead p -> readPin (ReaderPin p) >>= print - CmdWrite p v -> writePin (WriterPin p) v diff --git a/src/lib/System/GPIO.hs b/src/lib/System/GPIO.hs deleted file mode 100644 --- a/src/lib/System/GPIO.hs +++ /dev/null @@ -1,103 +0,0 @@ -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 :: (MonadBaseControl IO m, MonadIO m) => Pin -> m (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 deleted file mode 100644 --- a/src/lib/System/GPIO/Types.hs +++ /dev/null @@ -1,77 +0,0 @@ -module System.GPIO.Types - ( Pin(..) - , pinNum - , pinNumT - , fromInt - , ActivePin(..) - , pin - , Dir(..) - , Value(..) - , fromText - , toText - ) 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