sport (empty) → 0.1.0.0
raw patch · 8 files changed
+505/−0 lines, 8 filesdep +asyncdep +basedep +bytestring
Dependencies added: async, base, bytestring, stm, unix
Files
- CHANGELOG.md +5/−0
- LICENSE +20/−0
- README.md +19/−0
- lib/Sport.hs +36/−0
- lib/Sport/Main.hs +23/−0
- lib/Sport/Serial.hs +98/−0
- lib/Sport/Sport.hs +255/−0
- sport.cabal +49/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for sport++## 0.1.0.0 -- 4-20-2026++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2026 Standard Semiconductor++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,19 @@+# Sport++UNIX Serial Port++```hs+import Sport++main = withSport $ \s -> do+ openSport s defSportCfg{path="/dev/ttyUSB1"}+ bs <- readSport s 64+ writeSport s bs+```++Development++```+cabal build+cabal haddock+```
+ lib/Sport.hs view
@@ -0,0 +1,36 @@+-- | UNIX Serial Port+--+-- @+-- import Sport+--+-- main = withSport $ \\s -> do+-- openSport s defSportCfg{path="\/dev\/ttyUSB1", speed=B19200}+-- bs <- readSport s 64+-- writeSport s bs+-- @+module Sport+ ( -- *** Handle & Daemon+ Sport+ , withSport+ , newSportIO+ , newSport+ , runSport+ , -- *** Open & Close+ openSport+ , defSportCfg+ , SportCfg(..)+ , BufferMode(..)+ , Parity(..)+ , StopBits(..)+ , closeSport+ , -- *** Read & Write+ readSport+ , readSomeSport+ , writeSport+ , -- *** Exception+ SportException(..)+ ) where++import Sport.Serial+import Sport.Sport+import System.IO
+ lib/Sport/Main.hs view
@@ -0,0 +1,23 @@+module Sport.Main (sportMain) where++import Control.Concurrent.Async+import Control.Monad+import qualified Data.ByteString.Lazy.Char8 as BS+import Sport.Sport+import System.IO+import System.Posix++sportMain :: IO ()+sportMain =+ withSport $ \s -> do+ putStrLn "...UNIX.SERIAL.PORT..."+ hSetBuffering stdin NoBuffering+ hSetBuffering stdout NoBuffering+ openSport s defSportCfg{speed = B19200}+ concurrently_ (reading s) (writing s)++reading :: Sport -> IO a+reading s = forever $ putChar . BS.head =<< readSport s 1++writing :: Sport -> IO a+writing s = forever $ writeSport s . BS.singleton =<< getChar
+ lib/Sport/Serial.hs view
@@ -0,0 +1,98 @@+module Sport.Serial+ ( withSerial+ , openSerial+ , SerialCfg(..)+ , Parity(..)+ , StopBits(..)+ , defSerialCfg+ ) where++import Control.Exception+import System.IO+import System.Posix++data SerialCfg = SerialCfg+ { path :: FilePath+ , speed :: BaudRate+ , byteSize :: Int -- ^ number of bits per byte+ , parity :: Maybe Parity+ , stopBits :: StopBits+ , rtimeout :: Maybe Int+ , excl :: Bool -- ^ exclusive+ } deriving (Eq, Show)++defSerialCfg :: SerialCfg+defSerialCfg = SerialCfg+ { path = "/dev/ttyUSB0"+ , speed = B115200+ , byteSize = 8+ , parity = Nothing+ , stopBits = One+ , rtimeout = Nothing+ , excl = True+ }++data Parity = Even | Odd+ deriving (Eq, Read, Show)++data StopBits = One | Two+ deriving (Eq, Read, Show)++withSerial :: SerialCfg -> (Handle -> IO a) -> IO a+withSerial cfg = bracket (openSerial cfg) hClose++openSerial :: SerialCfg -> IO Handle+openSerial cfg =+ bracketOnError (openFd (path cfg) ReadWrite flags) closeFd $ \fd -> do+ configAttrs fd cfg+ fdToHandle fd+ where+ flags =+ defaultFileFlags+ { noctty = True+ , nonBlock = True+ , exclusive = excl cfg+ }++-- | configure FD terminal attributes+configAttrs :: Fd -> SerialCfg -> IO ()+configAttrs fd cfg = do+ attrs <- getTerminalAttributes fd+ setTerminalAttributes fd (config attrs) Immediately+ where+ config attrs = attrs+ `withInputSpeed` speed cfg+ `withOutputSpeed` speed cfg+ `withBits` byteSize cfg+ `withParity` parity cfg+ `withStopBits` stopBits cfg+ `withoutMode` StartStopInput+ `withoutMode` StartStopOutput+ `withoutMode` EnableEcho+ `withoutMode` EchoErase+ `withoutMode` EchoKill+ `withoutMode` ProcessInput+ `withoutMode` ProcessOutput+ `withoutMode` MapCRtoLF+ `withoutMode` EchoLF+ `withoutMode` HangupOnClose+ `withoutMode` KeyboardInterrupts+ `withoutMode` ExtendedFunctions+ `withMode` LocalMode+ `withMode` ReadEnable+ `withReadTimeout` rtimeout cfg+ `withMinInput` 0++withParity :: TerminalAttributes -> Maybe Parity -> TerminalAttributes+withParity attrs Nothing = attrs `withoutMode` EnableParity+withParity attrs (Just p) = case p of+ Even -> attrs `withoutMode` OddParity+ Odd -> attrs `withMode` OddParity++withStopBits :: TerminalAttributes -> StopBits -> TerminalAttributes+withStopBits attrs One = attrs `withoutMode` TwoStopBits+withStopBits attrs Two = attrs `withMode` TwoStopBits++withReadTimeout :: TerminalAttributes -> Maybe Int -> TerminalAttributes+withReadTimeout attrs Nothing = attrs+withReadTimeout attrs (Just t) = attrs `withTime` t
+ lib/Sport/Sport.hs view
@@ -0,0 +1,255 @@+module Sport.Sport+ ( Sport+ , newSportIO+ , newSport+ , withSport+ , runSport+ , openSport+ , defSportCfg+ , SportCfg(..)+ , closeSport+ , readSport+ , readSomeSport+ , writeSport+ , SportException(..)+ ) where++import Control.Applicative+import Control.Concurrent.Async+import Control.Concurrent.STM+import Control.Exception+import Control.Monad+import qualified Data.ByteString as Strict+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as BS+import Data.Functor+import qualified Sport.Serial as S+import System.IO+import System.Posix++data Sport = Sport+ { state :: TVar State+ , rcmd :: TMVar RdCmd+ , wcmd :: TMVar WrCmd+ }++-- | Acquire IO serial port+newSportIO :: IO Sport+newSportIO = atomically newSport++-- | Acquire STM serial port+newSport :: STM Sport+newSport =+ Sport+ <$> newTVar Closed+ <*> newEmptyTMVar+ <*> newEmptyTMVar++data State+ = Closed+ | Opening SportCfg (TMVar (Either SomeException ()))+ | Open SportCfg Handle+ deriving Eq++data RdCmd+ = Rd Int (TMVar (Either SomeException ByteString))+ | RdSome Int (TMVar (Either SomeException ByteString))++data WrCmd+ = Wr ByteString (TMVar (Either SomeException ()))++-- | Handle and serial configuration+data SportCfg = SportCfg+ { binaryMode :: Bool -- ^ Binary mode True, text mode False.+ , bufferMode :: BufferMode+ , path :: FilePath+ , speed :: BaudRate+ , byteSize :: Int -- ^ number of bits per byte+ , parity :: Maybe S.Parity+ , stopBits :: S.StopBits+ , rtimeout :: Maybe Int+ , excl :: Bool -- ^ exclusive+ }+ deriving Eq++-- | Binary with no buffering+defSportCfg :: SportCfg+defSportCfg =+ SportCfg+ True+ NoBuffering+ (S.path S.defSerialCfg)+ (S.speed S.defSerialCfg)+ (S.byteSize S.defSerialCfg)+ (S.parity S.defSerialCfg)+ (S.stopBits S.defSerialCfg)+ (S.rtimeout S.defSerialCfg)+ (S.excl S.defSerialCfg)++-- | Open the serial port. Throw 'SportAlreadyOpen' if the+-- serial port was already opened.+openSport :: Sport -> SportCfg -> IO ()+openSport (Sport s _ _) cfg = do+ res <- newEmptyTMVarIO+ atomically $ do+ st <- readTVar s+ case st of+ Closed -> writeTVar s $ Opening cfg res+ _ -> throwSTM SportAlreadyOpen+ atomically $ do+ result <- takeTMVar res+ case result of+ Left err -> throwSTM err+ Right () -> return ()++-- | Close the serial port.+closeSport :: Sport -> IO ()+closeSport (Sport s r w) = join $ atomically $ do+ st <- readTVar s+ writeTVar s Closed+ (rM, wM) <- (,) <$> tryTakeTMVar r <*> tryTakeTMVar w+ forM_ rM $ \cmd -> case cmd of+ Rd _ res -> closeResponse res+ RdSome _ res -> closeResponse res+ forM_ wM $ \(Wr _ res) -> closeResponse res+ case st of+ Closed -> return $ return ()+ Opening _ res -> closeResponse res $> return ()+ Open _ serial -> return $ hClose serial++closeResponse :: TMVar (Either SomeException a) -> STM ()+closeResponse res = void $ tryPutTMVar res $ Left $ toException SportClosed++-- | Read n bytes from the serial port. If the serial port is+-- closed then throw 'SportClosed'. Block if the serial port is+-- busy handling a concurrent request or until all n bytes are available.+readSport :: Sport -> Int -> IO ByteString+readSport (Sport s r _) n = do+ res <- newEmptyTMVarIO+ atomically $ do+ st <- readTVar s+ case st of+ Closed -> throwSTM SportClosed+ Open{} -> putTMVar r $ Rd n res+ _ -> retry+ atomically $ do+ result <- takeTMVar res+ case result of+ Left err -> throwSTM err+ Right bs -> return bs++-- | Read up to n bytes from the serial port. If the serial port+-- is closed then throw 'SportClosed'. Block if the serial port+-- is busy handling a concurrent request or until some of+-- the n bytes are available.+readSomeSport :: Sport -> Int -> IO ByteString+readSomeSport (Sport s r _) n = do+ res <- newEmptyTMVarIO+ atomically $ do+ st <- readTVar s+ case st of+ Closed -> throwSTM SportClosed+ Open{} -> putTMVar r $ RdSome n res+ _ -> retry+ atomically $ do+ result <- takeTMVar res+ case result of+ Left err -> throwSTM err+ Right bs -> return bs++-- | Write bytes to the serial port. If the serial port+-- is closed then throw 'SportClosed'. Block if the serial+-- port is busy handling a concurrent request.+writeSport :: Sport -> ByteString -> IO ()+writeSport (Sport s _ w) bs = do+ res <- newEmptyTMVarIO+ atomically $ do+ st <- readTVar s+ case st of+ Closed -> throwSTM SportClosed+ Open{} -> putTMVar w $ Wr bs res+ _ -> retry+ atomically $ do+ result <- takeTMVar res+ case result of+ Left err -> throwSTM err+ Right () -> return ()++-- | Acquire a serial port and run the daemon.+withSport :: (Sport -> IO a) -> IO a+withSport k = do+ s <- newSportIO+ either id id <$> race (k s) (runSport s)++-- | Run the serial port daemon and process requests.+runSport :: Sport -> IO a+runSport s =+ forever (runState s =<< readTVarIO (state s)) `onException` closeSport s++runState :: Sport -> State -> IO ()+runState s st = case st of+ Closed -> waitNewState s st+ Opening cfg res -> handleException res $ opening s cfg res+ Open _ serial -> runConcurrently $ asum $ map Concurrently+ [ waitNewState s st+ , readHandler s serial+ , writeHandler s serial+ ]++readHandler :: Sport -> Handle -> IO a+readHandler s serial = forever $ do+ cmd <- atomically $ takeTMVar $ rcmd s+ case cmd of+ Rd n res -> handleException res $ do+ bs <- BS.hGet serial n+ atomically $ writeTMVar res $ Right bs+ RdSome n res -> handleException res $ do+ bs <- BS.fromStrict <$> Strict.hGetSome serial n+ atomically $ writeTMVar res $ Right bs++writeHandler :: Sport -> Handle -> IO a+writeHandler s serial = forever $ do+ cmd <- atomically $ takeTMVar $ wcmd s+ case cmd of+ Wr bs res -> handleException res $ do+ BS.hPut serial bs+ atomically $ writeTMVar res $ Right ()++waitNewState :: Sport -> State -> IO ()+waitNewState s st = atomically $ check . (st /=) =<< readTVar (state s)++opening :: Sport -> SportCfg -> TMVar (Either SomeException ()) -> IO ()+opening s cfg res =+ bracketOnError (S.openSerial $ toSerialCfg cfg) hClose $ \serial -> do+ hSetBinaryMode serial $ binaryMode cfg+ hSetBuffering serial $ bufferMode cfg+ atomically $ do+ writeTVar (state s) $ Open cfg serial+ writeTMVar res $ Right ()++toSerialCfg :: SportCfg -> S.SerialCfg+toSerialCfg s =+ S.SerialCfg+ (path s)+ (speed s)+ (byteSize s)+ (parity s)+ (stopBits s)+ (rtimeout s)+ (excl s)++handleException :: TMVar (Either SomeException a) -> IO () -> IO ()+handleException res k = k `catches`+ [ Handler $ \e -> throwIO (e :: SomeAsyncException)+ , Handler $ \e -> atomically $ void $ tryPutTMVar res $ Left (e :: SomeException)+ ]++-- | Serial port exceptions+data SportException+ -- | User required an open sport but it was closed.+ = SportClosed+ -- | User attempted to open a serial port that was already open.+ | SportAlreadyOpen+ deriving (Eq, Read, Show)++instance Exception SportException
+ sport.cabal view
@@ -0,0 +1,49 @@+cabal-version: 3.0+name: sport+version: 0.1.0.0+synopsis: UNIX serial port+description: Concurrent serial IO+license: MIT+license-file: LICENSE+author: Standard Semiconductor+maintainer: standardsemiconductor@gmail.com+copyright: David Cox+category: System, Hardware, Concurrency, STM+build-type: Simple+extra-doc-files: CHANGELOG.md+ README.md++source-repository head+ type: git+ location: https://github.com/standardsemiconductor/sport++library+ ghc-options: -Wall -O2+ default-language: Haskell2010+ hs-source-dirs: lib+ exposed-modules: Sport,+ Sport.Main,+ Sport.Serial,+ Sport.Sport+ build-depends: async,+ base < 5,+ bytestring,+ stm,+ unix++--executable sport+-- ghc-options: -Wall -O2 -threaded+-- default-language: Haskell2010+-- hs-source-dirs: exe+-- main-is: Main.hs+-- build-depends: base,+-- sport++--test-suite test+-- ghc-options: -Wall+-- default-language: Haskell2010+-- hs-source-dirs: test+-- type: exitcode-stdio-1.0+-- main-is: Main.hs+-- build-depends: base,+-- sport