sport 1.0.0.0 → 2.0.0.0

raw patch · 6 files changed

+103/−124 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• lib/Sport.hs +4/−0
• lib/Sport/Serial.hs +5/−0
• lib/Sport/Sport.hs +85/−120
• sport.cabal +2/−3
• test/Main.hs +0/−1

@@ -1,5 +1,12 @@ # Revision history for sport +## 2.0.0.0 -- 6-6-2026++* Add `flushSport`, `withOpenSport`+* Add `displaySportException`, `SportException` instances+* Improve concurrency and resource handling+* Add `getOpenSportCfg`+ ## 1.0.0.0 -- 4-30-2026  * Fix `SportAlreadyOpen` bug

@@ -12,6 +12,7 @@   ( -- *** Handle & Daemon     Sport   , withSport+  , withOpenSport   , newSportIO   , newSport   , runSport@@ -19,6 +20,7 @@     openSport   , isOpenSport   , getSportCfg+  , getOpenSportCfg   , defSportCfg   , SportCfg(..)   , BufferMode(..)@@ -30,8 +32,10 @@     readSport   , readSomeSport   , writeSport+  , flushSport   , -- *** Exception     SportException(..)+  , displaySportException   ) where  import Sport.Serial

@@ -1,3 +1,4 @@+-- | Low-level serial IO module Sport.Serial   ( withSerial   , openSerial@@ -11,6 +12,7 @@ import System.IO import System.Posix +-- | Configuration data SerialCfg = SerialCfg   { path :: FilePath   , speed :: BaudRate@@ -21,6 +23,7 @@   , excl :: Bool -- ^ exclusive   } deriving (Eq, Show) +-- | Default configuration defSerialCfg :: SerialCfg defSerialCfg = SerialCfg   { path = "/dev/ttyUSB0"@@ -38,9 +41,11 @@ data StopBits = One | Two   deriving (Eq, Read, Show) +-- | Acquire bracketed serial handle withSerial :: SerialCfg -> (Handle -> IO a) -> IO a withSerial cfg = bracket (openSerial cfg) hClose +-- | Open serial sport handle openSerial :: SerialCfg -> IO Handle openSerial cfg =   bracketOnError (openFd (path cfg) ReadWrite flags) closeFd $ \fd -> do

@@ -1,22 +1,26 @@+-- | Internal high-level serial port module Sport.Sport   ( Sport   , newSportIO   , newSport   , withSport+  , withOpenSport   , runSport   , openSport   , isOpenSport   , getSportCfg+  , getOpenSportCfg   , defSportCfg   , SportCfg(..)   , closeSport   , readSport   , readSomeSport   , writeSport+  , flushSport   , SportException(..)+  , displaySportException   ) where -import Control.Applicative import Control.Concurrent.Async import Control.Concurrent.STM import Control.Exception@@ -25,15 +29,13 @@ import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BS import Data.Functor+import Data.Maybe import qualified Sport.Serial as S import System.IO import System.Posix -data Sport = Sport-  { state :: TVar State-  , rcmd  :: TMVar RdCmd-  , wcmd  :: TMVar WrCmd-  }+-- | Serial port handle+newtype Sport = Sport (TVar State)  -- | Acquire IO serial port newSportIO :: IO Sport@@ -41,11 +43,7 @@  -- | Acquire STM serial port newSport :: STM Sport-newSport =-  Sport-    <$> newTVar Closed-    <*> newEmptyTMVar-    <*> newEmptyTMVar+newSport = Sport <$> newTVar Closed  data State   = Closed@@ -53,20 +51,20 @@   | Open SportCfg Handle   deriving Eq -isOpen :: State -> Bool-isOpen Open{} = True-isOpen _      = False+readHandle :: Sport -> STM Handle+readHandle (Sport s) = do+  st <- readTVar s+  case st of+    Closed    -> retry+    Opening{} -> retry+    Open _ h  -> return h +tryReadHandle :: Sport -> STM (Maybe Handle)+tryReadHandle s = Just `fmap` readHandle s `orElse` pure Nothing+ -- | Check if serial port is open isOpenSport :: Sport -> STM Bool-isOpenSport = fmap isOpen . readTVar . state--data RdCmd-  = Rd Int (TMVar (Either SomeException ByteString))-  | RdSome Int (TMVar (Either SomeException ByteString))--data WrCmd-  = Wr ByteString (TMVar (Either SomeException ()))+isOpenSport s = isJust <$> tryReadHandle s  -- | Handle and serial configuration data SportCfg = SportCfg@@ -99,155 +97,121 @@ -- | Open the serial port. Throw 'SportAlreadyOpen' if the -- serial port was already opened. openSport :: Sport -> SportCfg -> IO ()-openSport (Sport s _ _) cfg' = do+openSport s@(Sport state) cfg' = do   res <- newEmptyTMVarIO   atomically $ do-    st <- readTVar s-    case st of-      Closed        -> writeTVar s $ Opening cfg' res-      Opening cfg _ -> throwSTM $ SportAlreadyOpen $ path cfg-      Open    cfg _ -> throwSTM $ SportAlreadyOpen $ path cfg+    cfgM <- getSportCfg s+    case cfgM of+      Nothing  -> writeTVar state $ Opening cfg' res+      Just cfg -> throwSTM $ SportAlreadyOpen $ path cfg   atomically $ do     result <- takeTMVar res     case result of       Left err -> throwSTM err       Right () -> return () --- | Get current configuration.+-- | Get current configuration. Returns 'Just' if+-- the current state is opening or open. See also 'getOpenSportCfg'. getSportCfg :: Sport -> STM (Maybe SportCfg)-getSportCfg (Sport s _ _) = do+getSportCfg (Sport s) = do   st <- readTVar s   return $ case st of     Closed        -> Nothing     Opening cfg _ -> Just cfg     Open    cfg _ -> Just cfg +-- | Get current open configuration. Returns 'Just' if+-- the current state is open. See also 'getSportCfg'.+getOpenSportCfg :: Sport -> STM (Maybe SportCfg)+getOpenSportCfg (Sport s) = do+  st <- readTVar s+  return $ case st of+    Closed     -> Nothing+    Opening{}  -> Nothing+    Open cfg _ -> Just cfg+ -- | Close the serial port. closeSport :: Sport -> IO ()-closeSport (Sport s r w) = join $ atomically $ do+closeSport (Sport s) = 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+  closeState st +closeState :: State -> STM (IO ())+closeState Closed          = return $ return ()+closeState (Opening _ res) = closeResponse res $> return ()+closeState (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.+-- closed then throw 'SportClosed'. Blocks 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+readSport s n = do+  h <- atomically $ readHandle s `orElse` throwSTM SportClosed+  BS.hGet h n  -- | 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+-- is closed then throw 'SportClosed'. Blocks 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+readSomeSport s n = do+  h <- atomically $ readHandle s `orElse` throwSTM SportClosed+  BS.fromStrict <$> Strict.hGetSome h n  -- | 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 ()+writeSport s bs = do+  h <- atomically $ readHandle s `orElse` throwSTM SportClosed+  BS.hPut h bs +-- | Flush the serial handle. Do nothing if closed.+flushSport :: Sport -> IO ()+flushSport s = do+  hM <- atomically $ tryReadHandle s+  mapM_ hFlush hM+ -- | 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) +-- | Construct the handle, run the daemon,+-- and open the configured serial port. The serial port+-- is closed on leaving scope.+withOpenSport :: SportCfg -> (Sport -> IO a) -> IO a+withOpenSport cfg k =+  withSport $ \s -> bracket_ (openSport s cfg) (closeSport s) (k s)+ -- | Run the serial port daemon and process requests. runSport :: Sport -> IO a-runSport s =-  forever (runState s =<< readTVarIO (state s)) `onException` closeSport s+runSport s@(Sport state) =+  forever (runState s =<< readTVarIO state) `onException` closeSport s  runState :: Sport -> State -> IO ()-runState s st = case st of+runState s@(Sport state) st = case st of   Closed -> waitNewState s st   Opening cfg res ->     handleException res $       opening s cfg res-        `onException` atomically (writeTVar (state s) Closed)-  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 ()+        `onException` atomically (writeTVar state Closed)+  Open{} -> waitNewState s st  waitNewState :: Sport -> State -> IO ()-waitNewState s st = atomically $ check . (st /=) =<< readTVar (state s)+waitNewState (Sport s) st = atomically $ check . (st /=) =<< readTVar s  opening :: Sport -> SportCfg -> TMVar (Either SomeException ()) -> IO ()-opening s cfg res =+opening (Sport 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+      writeTVar s $ Open cfg serial       writeTMVar res $ Right ()  toSerialCfg :: SportCfg -> S.SerialCfg@@ -273,11 +237,12 @@   = SportClosed     -- | User attempted to open a serial port that was already open.   | SportAlreadyOpen String-  deriving Eq--instance Show SportException where-  show e = "sport exception: " <> case e of-    SportClosed -> "serial port closed"-    SportAlreadyOpen p -> "serial port already open: " <> p+  deriving (Eq, Read, Show)  instance Exception SportException++-- | Pretty exception rendering+displaySportException :: SportException -> String+displaySportException e = "sport exception: " <> case e of+  SportClosed -> "serial port closed"+  SportAlreadyOpen p -> "serial port already open: " <> p

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               sport-version:            1.0.0.0+version:            2.0.0.0 synopsis:           UNIX serial port description:        Concurrent serial IO license:            MIT@@ -48,5 +48,4 @@   build-depends:    async,                     base,                     bytestring,-                    sport,-                    stm+                    sport

@@ -1,7 +1,6 @@ module Main (main) where  import Control.Concurrent.Async-import Control.Concurrent.STM import qualified Data.ByteString.Lazy as BS import Sport import System.IO