diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for looper + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Tom Sydney Kerckhove (c) 2019 + +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 Tom Sydney Kerckhove 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# looper 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/looper.cabal b/looper.cabal new file mode 100644 --- /dev/null +++ b/looper.cabal @@ -0,0 +1,62 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.1. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 6d5e9c51a2ad417bcd1f5ef7076cd6bfb6093bbb44f76e44d9ba235473ba9919 + +name: looper +version: 0.0.0.0 +description: Please see the README on GitHub at +homepage: https://github.com/NorfairKing/looper#readme +bug-reports: https://github.com/NorfairKing/looper/issues +author: Tom Sydney Kerckhove +maintainer: syd@cs-syd.eu +copyright: Copyright: (c) 2019 Tom Sydney Kerckhove +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/NorfairKing/looper + +library + exposed-modules: + Looper + other-modules: + Paths_looper + hs-source-dirs: + src + build-depends: + aeson + , base >=4.7 && <5 + , optparse-applicative + , text + , time + , unliftio + default-language: Haskell2010 + +test-suite looper-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + LooperSpec + Paths_looper + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , base >=4.7 && <5 + , hspec + , looper + , optparse-applicative + , text + , time + , unliftio + default-language: Haskell2010 diff --git a/src/Looper.hs b/src/Looper.hs new file mode 100644 --- /dev/null +++ b/src/Looper.hs @@ -0,0 +1,271 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} + +module Looper + ( LooperDef(..) + , seconds + , minutes + , hours + , LooperFlags(..) + , getLooperFlags + , LooperEnvironment(..) + , getLooperEnvironment + , LooperConfiguration(..) + , LooperSettings(..) + , deriveLooperSettings + , mkLooperDef + , runLoopers + , runLoopersIgnoreOverrun + , runLoopersRaw + , waitNominalDiffTime + ) where + +import GHC.Generics (Generic) + +import Control.Applicative +import Control.Monad + +import qualified System.Environment as System (getEnvironment) + +import Data.Aeson +import Data.Maybe +import Data.String +import Data.Text (Text) +import Data.Time + +import Options.Applicative +import Text.Read + +import UnliftIO +import UnliftIO.Concurrent + +-- | A looper definition +data LooperDef m = + LooperDef + { looperDefName :: Text -- ^ The name of the looper, can be useful for logging + , looperDefEnabled :: Bool -- ^ Whether this looper is enabled + , looperDefPeriod :: NominalDiffTime -- ^ The time between the start of each run + , looperDefPhase :: NominalDiffTime -- ^ The time before the first run + , looperDefFunc :: m () -- ^ The function to run + } + deriving (Generic) + +-- | Construct a 'NominalDiffTime' from a number of seconds +seconds :: Double -> NominalDiffTime +seconds = realToFrac + +-- | Construct a 'NominalDiffTime' from a number of minutes +minutes :: Double -> NominalDiffTime +minutes = seconds . (* 60) + +-- | Construct a 'NominalDiffTime' from a number of hours +hours :: Double -> NominalDiffTime +hours = minutes . (* 60) + +-- | A structure to parse command-line flags for a looper into +data LooperFlags = + LooperFlags + { looperFlagEnabled :: Maybe Bool + , looperFlagPhase :: Maybe Int -- Seconds + , looperFlagPeriod :: Maybe Int -- Seconds + } + deriving (Show, Eq, Generic) + +-- | An optparse applicative parser for 'LooperFlags' +getLooperFlags :: String -> Parser LooperFlags +getLooperFlags name = + LooperFlags <$> doubleSwitch name (unwords ["enable the", name, "looper"]) mempty <*> + option + (Just <$> auto) + (mconcat + [ long $ name <> "-phase" + , metavar "SECONDS" + , value Nothing + , help $ unwords ["the phase for the", name, "looper in seconsd"] + ]) <*> + option + (Just <$> auto) + (mconcat + [ long $ name <> "-period" + , metavar "SECONDS" + , value Nothing + , help $ unwords ["the period for the", name, "looper in seconds"] + ]) + +doubleSwitch :: String -> String -> Mod FlagFields Bool -> Parser (Maybe Bool) +doubleSwitch name helpText mods = + let enabledValue = True + disabledValue = False + defaultValue = True + in ((last . map Just) <$> + some + ((flag' + enabledValue + (hidden <> internal <> long ("enable-" ++ name) <> help helpText <> mods) <|> + flag' + disabledValue + (hidden <> internal <> long ("disable-" ++ name) <> help helpText <> mods)) <|> + flag' + disabledValue + (long ("(enable|disable)-" ++ name) <> + help ("Enable/disable " ++ helpText ++ " (default: " ++ show defaultValue ++ ")") <> + mods))) <|> + pure Nothing + +-- | A structure to parse environment variables for a looper into +data LooperEnvironment = + LooperEnvironment + { looperEnvEnabled :: Maybe Bool + , looperEnvPhase :: Maybe Int -- Seconds + , looperEnvPeriod :: Maybe Int -- Seconds + } + deriving (Show, Eq, Generic) + +-- | Get a 'LooperEnvironment' from a the environment +getLooperEnvironment :: + String -- ^ Prefix for each variable (best to make this all-caps) + -> String -- ^ Name of the looper (best to make this all-caps too) + -> IO LooperEnvironment +getLooperEnvironment prefix name = readLooperEnvironment prefix name <$> System.getEnvironment + +-- | Get a 'LooperEnvironment' from a pure environment +readLooperEnvironment :: + String -- ^ Prefix for each variable (best to make this all-caps) + -> String -- ^ Name of the looper (best to make this all-caps too) + -> [(String, String)] + -> LooperEnvironment +readLooperEnvironment prefix name env = + let v :: IsString s => String -> Maybe s + v k = fromString <$> lookup (prefix <> k) env + r :: Read a => String -> Maybe a + r k = v k >>= readMaybe + lr :: Read a => String -> Maybe a + lr k = r $ name <> "_" <> k + in LooperEnvironment + { looperEnvEnabled = lr "ENABLED" + , looperEnvPhase = lr "PHASE" + , looperEnvPeriod = lr "PERIOD" + } + +-- | A structure to configuration for a looper into +data LooperConfiguration = + LooperConfiguration + { looperConfEnabled :: Maybe Bool + , looperConfPhase :: Maybe Int + , looperConfPeriod :: Maybe Int + } + deriving (Show, Eq, Generic) + +-- | You can parse Data.Aeson's JSON or Data.Yaml's YAML to parse a 'LooperConfiguration'. +-- You can also use Data.Yaml.Config. +instance FromJSON LooperConfiguration where + parseJSON = + withObject "LooperConfiguration" $ \o -> + LooperConfiguration <$> o .:? "enabled" <*> o .:? "phase" <*> o .: "period" + +-- | Settings that you might want to pass into a looper using 'mkLooperDef' +data LooperSettings = + LooperSettings + { looperSetEnabled :: Bool + , looperSetPhase :: NominalDiffTime + , looperSetPeriod :: NominalDiffTime + } + deriving (Show, Eq, Generic) + +deriveLooperSettings :: + NominalDiffTime + -> NominalDiffTime + -> LooperFlags + -> LooperEnvironment + -> Maybe LooperConfiguration + -> LooperSettings +deriveLooperSettings defaultPhase defaultPeriod LooperFlags {..} LooperEnvironment {..} mlc = + let looperSetEnabled = + fromMaybe True $ looperFlagEnabled <|> looperEnvEnabled <|> (mlc >>= looperConfEnabled) + looperSetPhase = + maybe defaultPhase fromIntegral $ + looperFlagPhase <|> looperEnvPhase <|> (mlc >>= looperConfPhase) + looperSetPeriod = + maybe defaultPeriod fromIntegral $ + looperFlagPeriod <|> looperEnvPeriod <|> (mlc >>= looperConfPeriod) + in LooperSettings {..} + +mkLooperDef :: + Text -- Name + -> LooperSettings + -> m () -- The function to loop + -> LooperDef m +mkLooperDef name LooperSettings {..} func = + LooperDef + { looperDefName = name + , looperDefEnabled = looperSetEnabled + , looperDefPeriod = looperSetPeriod + , looperDefPhase = looperSetPhase + , looperDefFunc = func + } + +-- | Simply run loopers +-- +-- > runLoopers = runLoopersIgnoreOverrun $ looperDefFunc +-- +-- see 'runLoopersIgnoreOverrun' +-- +-- Note that this function will loop forever, you need to wrap it using 'async' yourself. +runLoopers :: MonadUnliftIO m => [LooperDef m] -> m () +runLoopers = runLoopersIgnoreOverrun looperDefFunc + +-- | Run loopers with a custom runner, ignoring any overruns +-- +-- > runLoopersIgnoreOverrun = runLoopersRaw (pure ()) +-- +-- see 'runLoopersRaw' +-- +-- Note that this function will loop forever, you need to wrap it using 'async' yourself. +runLoopersIgnoreOverrun :: + MonadUnliftIO m + => (LooperDef m -> m ()) -- ^ Custom runner + -> [LooperDef m] -- ^ Loopers + -> m () +runLoopersIgnoreOverrun = runLoopersRaw (pure ()) + +-- | Run loopers, with a custom runner and overrun handler +-- +-- * The overrun handler is run when the looper function takes longer than its period. +-- You can use this to log a warning, for example. +-- +-- * The runner function is used to run the looper function +-- You can use 'looperDefFunc' @ :: LooperDef m -> m ()@ to run a 'LooperDef', and you +-- can wrap this function in some custom logic before you pass it into 'runLoopersRaw' +-- In this manner you can add logging or metrics, for example. +-- +-- Note that this function will loop forever, you need to wrap it using 'async' yourself. +runLoopersRaw :: + MonadUnliftIO m + => m () -- ^ Overrun handler + -> (LooperDef m -> m ()) -- ^ Runner + -> [LooperDef m] -- ^ Loopers + -> m () +runLoopersRaw onOverrun runLooper = + mapConcurrently_ $ \ld@LooperDef {..} -> + when looperDefEnabled $ do + waitNominalDiffTime looperDefPhase + let loop = do + start <- liftIO $ getCurrentTime + runLooper ld + end <- liftIO $ getCurrentTime + let elapsed = diffUTCTime end start + let nextWait = looperDefPeriod - elapsed + if (nextWait < 0) + then onOverrun + else waitNominalDiffTime nextWait + loop + loop + +-- | Wait for a given 'NominalDiffTime' +-- +-- This takes care of the conversion to microseconds to pass to 'threadDelay' for you. +-- +-- > waitNominalDiffTime ndt = liftIO $ threadDelay $ round (toRational ndt * (1000 * 1000)) +waitNominalDiffTime :: MonadIO m => NominalDiffTime -> m () +waitNominalDiffTime ndt = liftIO $ threadDelay $ round (toRational ndt * (1000 * 1000)) diff --git a/test/LooperSpec.hs b/test/LooperSpec.hs new file mode 100644 --- /dev/null +++ b/test/LooperSpec.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE OverloadedStrings #-} + +module LooperSpec + ( spec + ) where + +import Test.Hspec + +import Options.Applicative as AP +import UnliftIO + +import Looper + +spec :: Spec +spec = do + describe "getLooperFlags" $ do + it "parses default values for an empty list of arguments" $ do + parserSucceedsWith + (getLooperFlags "test") + [] + (LooperFlags + {looperFlagEnabled = Nothing, looperFlagPhase = Nothing, looperFlagPeriod = Nothing}) + it "parses an enable flag correctly" $ do + parserSucceedsWith + (getLooperFlags "test") + ["--enable-test"] + (LooperFlags + {looperFlagEnabled = Just True, looperFlagPhase = Nothing, looperFlagPeriod = Nothing}) + it "parses an disable flag correctly" $ do + parserSucceedsWith + (getLooperFlags "test") + ["--disable-test"] + (LooperFlags + {looperFlagEnabled = Just False, looperFlagPhase = Nothing, looperFlagPeriod = Nothing}) + describe "runLoopers" $ do + it "runs one looper as intended" $ do + v <- newTVarIO (0 :: Int) + let l = + LooperDef + { looperDefName = "l1" + , looperDefEnabled = True + , looperDefPeriod = seconds 0.01 + , looperDefPhase = seconds 0 + , looperDefFunc = atomically $ modifyTVar' v succ + } + a <- async $ runLoopers [l] + waitNominalDiffTime $ seconds 0.015 + cancel a + r <- readTVarIO v + r `shouldBe` 2 + it "does not run a looper before its phase" $ do + v <- newTVarIO (0 :: Int) + let l = + LooperDef + { looperDefName = "l" + , looperDefEnabled = True + , looperDefPeriod = seconds 0.01 + , looperDefPhase = seconds 0.02 + , looperDefFunc = atomically $ modifyTVar' v succ + } + a <- async $ runLoopers [l] + waitNominalDiffTime $ seconds 0.015 + cancel a + r <- readTVarIO v + r `shouldBe` 0 + it "runs two loopers as intended" $ do + v1 <- newTVarIO (0 :: Int) + v2 <- newTVarIO (0 :: Int) + v3 <- newTVarIO (0 :: Int) + let l1 = + LooperDef + { looperDefName = "l1" + , looperDefEnabled = True + , looperDefPeriod = seconds 0.01 + , looperDefPhase = seconds 0 + , looperDefFunc = + atomically $ do + modifyTVar' v1 succ + modifyTVar' v2 succ + } + let l2 = + LooperDef + { looperDefName = "l2" + , looperDefEnabled = True + , looperDefPeriod = seconds 0.005 + , looperDefPhase = seconds 0.005 + , looperDefFunc = + atomically $ do + modifyTVar' v2 succ + modifyTVar' v3 succ + } + a <- async $ runLoopers [l1, l2] + waitNominalDiffTime $ seconds 0.0225 + cancel a + r1 <- readTVarIO v1 + r2 <- readTVarIO v2 + r3 <- readTVarIO v3 + (r1, r2, r3) `shouldBe` (3, 7, 4) + describe "runLoopersRaw" $ do + it "runs one looper as intended with a custom runner" $ do + v1 <- newTVarIO (0 :: Int) + v2 <- newTVarIO (0 :: Int) + let inc1 = atomically $ modifyTVar' v1 succ + inc2 = atomically $ modifyTVar' v2 succ + let l = + LooperDef + { looperDefName = "l" + , looperDefEnabled = True + , looperDefPeriod = seconds 0.01 + , looperDefPhase = seconds 0 + , looperDefFunc = inc1 + } + a <- async $ runLoopersRaw (pure ()) (\ld -> looperDefFunc ld >> inc2) [l] + waitNominalDiffTime $ seconds 0.015 + cancel a + r1 <- readTVarIO v1 + r2 <- readTVarIO v2 + (r1, r2) `shouldBe` (2, 2) + it "runs one looper as intended with a custom overrun hook" $ do + v1 <- newTVarIO (0 :: Int) + v2 <- newTVarIO (0 :: Int) + let inc1 = atomically $ modifyTVar' v1 succ + inc2 = atomically $ modifyTVar' v2 succ + let l = + LooperDef + { looperDefName = "l" + , looperDefEnabled = True + , looperDefPeriod = seconds 0.01 + , looperDefPhase = seconds 0 + , looperDefFunc = inc1 >> waitNominalDiffTime (seconds 0.015) + } + a <- async $ runLoopersRaw inc2 looperDefFunc [l] + waitNominalDiffTime $ seconds 0.035 + cancel a + r1 <- readTVarIO v1 + r2 <- readTVarIO v2 + (r1, r2) `shouldBe` (3, 2) + +parserSucceedsWith :: (Show a, Eq a) => Parser a -> [String] -> a -> Expectation +parserSucceedsWith parser args expectedValue = + case execParserPure parserPrefs (info parser mempty) args of + AP.Success r -> r `shouldBe` expectedValue + AP.Failure fp -> + let (err, ec) = renderFailure fp "test" + in expectationFailure $ + unlines ["Failed to parse:", err, "would have resulted in exit code", show ec] + AP.CompletionInvoked _ -> expectationFailure "Tried to invoke a completion, should not happen" + where + parserPrefs :: ParserPrefs + parserPrefs = + ParserPrefs + { prefMultiSuffix = "" + , prefDisambiguate = True + , prefShowHelpOnError = True + , prefShowHelpOnEmpty = True + , prefBacktrack = True + , prefColumns = 80 + } 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 #-}