diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,46 @@ +# Changelog + +## [0.3.0.0] - 2024-07-18 + +### Changed + +* Moved over to `opt-env-conf`. + +## [0.2.0.1] - 2022-05-07 + +### Changed + +* Made the runner function types more general. + +## [0.2.0.0] - 2021-11-18 + +### Changed + +* Started using `autodocodec` instead of `yamlparse-applicative`. + +## [0.1.0.1] - 2020-05-10 + +### Added + +* `looperEnvironmentParser` + +### Changed + +* Environment parsing via `envparse` + +## [0.0.0.2] - 2019-05-15 + +### Changed + +* Exposed 'readLooperEnvironment' +* Doc fix + +## [0.0.0.1] - 2019-05-15 + +### Changed + +* Better docs + +## [0.0.0.0] - 2019-05-15 + +Initial version diff --git a/looper.cabal b/looper.cabal --- a/looper.cabal +++ b/looper.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.7. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack name: looper -version: 0.2.0.1 +version: 0.3.0.0 description: Configure and run recurring jobs indefinitely homepage: https://github.com/NorfairKing/looper#readme bug-reports: https://github.com/NorfairKing/looper/issues @@ -16,7 +16,8 @@ license-file: LICENSE build-type: Simple extra-source-files: - test_resources/configuration.txt + ChangeLog.md + test_resources/documentation.txt source-repository head type: git @@ -30,11 +31,8 @@ hs-source-dirs: src build-depends: - aeson - , autodocodec - , base >=4.7 && <5 - , envparse - , optparse-applicative + base >=4.7 && <5 + , opt-env-conf , text , time , unliftio @@ -52,10 +50,10 @@ build-tool-depends: sydtest-discover:sydtest-discover build-depends: - autodocodec-yaml - , base >=4.7 && <5 + base >=4.7 && <5 , looper - , optparse-applicative + , opt-env-conf + , opt-env-conf-test , sydtest , unliftio default-language: Haskell2010 diff --git a/src/Looper.hs b/src/Looper.hs --- a/src/Looper.hs +++ b/src/Looper.hs @@ -1,22 +1,18 @@ +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Looper ( LooperDef (..), + milliseconds, seconds, minutes, hours, - LooperFlags (..), - getLooperFlags, - LooperEnvironment (..), - getLooperEnvironment, - readLooperEnvironment, - looperEnvironmentParser, - LooperConfiguration (..), LooperSettings (..), - deriveLooperSettings, + parseLooperSettings, mkLooperDef, runLoopers, runLoopersIgnoreOverrun, @@ -25,17 +21,11 @@ ) where -import Autodocodec -import Control.Applicative import Control.Monad -import Data.Aeson (FromJSON, ToJSON) -import Data.Maybe import Data.Text (Text) import Data.Time -import qualified Env import GHC.Generics (Generic) -import Options.Applicative as OptParse -import qualified System.Environment as System (getEnvironment) +import OptEnvConf import UnliftIO import UnliftIO.Concurrent @@ -54,6 +44,13 @@ } deriving (Generic) +-- | Construct a 'NominalDiffTime' from a number of milliseconds +-- +-- Note that scheduling can easily get in the way of accuracy at this +-- level of granularity. +milliseconds :: Double -> NominalDiffTime +milliseconds = seconds . (/ 60) + -- | Construct a 'NominalDiffTime' from a number of seconds seconds :: Double -> NominalDiffTime seconds = realToFrac @@ -66,126 +63,6 @@ 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 Word, -- Seconds - looperFlagPeriod :: Maybe Word -- Seconds - } - deriving (Show, Eq, Generic) - --- | An optparse applicative parser for 'LooperFlags' -getLooperFlags :: - -- | The name of the looper (best to make this all-lowercase) - String -> - OptParse.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 -> OptParse.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 Word, -- Seconds - looperEnvPeriod :: Maybe Word -- Seconds - } - deriving (Show, Eq, Generic) - --- | Get a 'LooperEnvironment' from the environment -getLooperEnvironment :: - -- | Prefix for each variable (best to make this all-caps) - String -> - -- | Name of the looper (best to make this all-caps too) - String -> - IO LooperEnvironment -getLooperEnvironment prefix name = readLooperEnvironment prefix name <$> System.getEnvironment - --- | Get a 'LooperEnvironment' from a pure environment -readLooperEnvironment :: - -- | Prefix for each variable (best to make this all-caps) - String -> - -- | Name of the looper (best to make this all-caps too) - String -> - [(String, String)] -> - LooperEnvironment -readLooperEnvironment prefix name env = case Env.parsePure (Env.prefixed prefix $ looperEnvironmentParser name) env of - Left _ -> error "This indicates a bug in looper because all environment variables are optional." - Right r -> r - --- | An 'envparse' parser for a 'LooperEnvironment' -looperEnvironmentParser :: - -- | Name of the looper (best to make this all-caps) - String -> - Env.Parser Env.Error LooperEnvironment -looperEnvironmentParser name = - Env.prefixed (name <> "_") $ - LooperEnvironment - <$> Env.var (fmap Just . Env.auto) "ENABLED" (Env.def Nothing <> Env.help "Whether to enable this looper") - <*> Env.var (fmap Just . Env.auto) "PHASE" (Env.def Nothing <> Env.help "The amount of time to wait before starting the looper the first time, in seconds") - <*> Env.var (fmap Just . Env.auto) "PERIOD" (Env.def Nothing <> Env.help "The amount of time to wait between runs of the looper, in seconds") - --- | A structure to configuration for a looper into -data LooperConfiguration = LooperConfiguration - { looperConfEnabled :: Maybe Bool, - looperConfPhase :: Maybe Word, - looperConfPeriod :: Maybe Word - } - deriving stock (Show, Eq, Generic) - deriving (FromJSON, ToJSON) via (Autodocodec LooperConfiguration) - -instance HasCodec LooperConfiguration where - codec = - named "LooperConfiguration" $ - object "LooperConfiguration" $ - LooperConfiguration - <$> parseAlternative - (optionalFieldOrNull "enable" "Enable this looper") - (optionalFieldOrNull "enabled" "Enable this looper") - .= looperConfEnabled - <*> optionalFieldOrNull "phase" "The amount of time to wait before starting the looper the first time, in seconds" .= looperConfPhase - <*> optionalFieldOrNull "period" "The amount of time to wait between runs of the looper, in seconds" .= looperConfPeriod - -- | Settings that you might want to pass into a looper using 'mkLooperDef' data LooperSettings = LooperSettings { looperSetEnabled :: Bool, @@ -194,25 +71,43 @@ } deriving (Show, Eq, Generic) -deriveLooperSettings :: - -- | Default phase +parseLooperSettings :: + String -> NominalDiffTime -> - -- | Default period 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 {..} + Parser LooperSettings +parseLooperSettings looperName defaultPhase defaultPeriod = do + looperSetEnabled <- + subConfig (toConfigCase looperName) $ + subEnv (toEnvCase looperName <> "_") $ + enableDisableSwitch + True + [ help $ unwords ["enable the", looperName, "looper"], + option, + long looperName, + env "ENABLE", + conf "enable" + ] + (looperSetPhase, looperSetPeriod) <- subAll looperName $ do + ph <- + setting + [ help $ unwords ["phase of the", looperName, "looper in seconds"], + reader (fromInteger <$> auto), + option, + name "phase", + metavar "SECONDS", + value defaultPhase + ] + pe <- + setting + [ help $ unwords ["period of the", looperName, "looper in seconds"], + reader (fromInteger <$> auto), + name "period", + metavar "SECONDS", + value defaultPeriod + ] + pure (ph, pe) + pure LooperSettings {..} mkLooperDef :: -- | Name @@ -221,9 +116,9 @@ -- | The function to loop m () -> LooperDef m -mkLooperDef name LooperSettings {..} func = +mkLooperDef n LooperSettings {..} func = LooperDef - { looperDefName = name, + { looperDefName = n, looperDefEnabled = looperSetEnabled, looperDefPeriod = looperSetPeriod, looperDefPhase = looperSetPhase, @@ -237,7 +132,7 @@ -- see 'runLoopersIgnoreOverrun' -- -- Note that this function will loop forever, you need to wrap it using 'async' yourself. -runLoopers :: MonadUnliftIO m => [LooperDef m] -> m () +runLoopers :: (MonadUnliftIO m) => [LooperDef m] -> m () runLoopers = runLoopersIgnoreOverrun looperDefFunc -- | Run loopers with a custom runner, ignoring any overruns @@ -248,7 +143,7 @@ -- -- Note that this function will loop forever, you need to wrap it using 'async' yourself. runLoopersIgnoreOverrun :: - (MonadUnliftIO m, MonadUnliftIO n) => + (MonadUnliftIO n) => -- | Custom runner (LooperDef m -> n ()) -> -- | Loopers @@ -268,7 +163,7 @@ -- -- Note that this function will loop forever, you need to wrap it using 'async' yourself. runLoopersRaw :: - (MonadUnliftIO m, MonadUnliftIO n) => + (MonadUnliftIO n) => -- | Overrun handler (LooperDef m -> n ()) -> -- | Runner @@ -297,5 +192,5 @@ -- 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)) +waitNominalDiffTime :: (MonadIO m) => NominalDiffTime -> m () +waitNominalDiffTime ndt = liftIO $ threadDelay $ round (toRational ndt * 1_000_000) diff --git a/test/LooperSpec.hs b/test/LooperSpec.hs --- a/test/LooperSpec.hs +++ b/test/LooperSpec.hs @@ -1,54 +1,20 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} module LooperSpec ( spec, ) where -import Autodocodec.Yaml import Looper -import Options.Applicative as AP +import OptEnvConf +import OptEnvConf.Test import Test.Syd import UnliftIO 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 "Configuration" $ do - it "has the same schema as before" $ - pureGoldenByteStringFile "test_resources/configuration.txt" (renderColouredSchemaViaCodec @LooperConfiguration) + parserLintSpec $ withLocalYamlConfig $ parseLooperSettings "example" (minutes 1) (minutes 60) + goldenParserReferenceDocumentationSpec (parseLooperSettings "example" (minutes 1) (minutes 60)) "test_resources/documentation.txt" "looper" describe "runLoopers" $ do it "runs one looper as intended" $ do @@ -153,20 +119,3 @@ 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 = - defaultPrefs - { prefShowHelpOnError = True, - prefShowHelpOnEmpty = True - } diff --git a/test_resources/configuration.txt b/test_resources/configuration.txt deleted file mode 100644 --- a/test_resources/configuration.txt +++ /dev/null @@ -1,20 +0,0 @@ -def: LooperConfiguration -# LooperConfiguration -# any of -[ enable: # optional - # Enable this looper - # or null -  -, enabled: # optional - # Enable this looper - # or null -  -] -phase: # optional - # The amount of time to wait before starting the looper the first time, in seconds - # or null -  # between 0 and 18446744073709551615 -period: # optional - # The amount of time to wait between runs of the looper, in seconds - # or null -  # between 0 and 18446744073709551615 diff --git a/test_resources/documentation.txt b/test_resources/documentation.txt new file mode 100644 --- /dev/null +++ b/test_resources/documentation.txt @@ -0,0 +1,49 @@ +Usage: looper --(enable|disable)-example --example-phase SECONDS --example-period SECONDS + +All settings: + enable the example looper + switch: --(enable|disable)-example + env: EXAMPLE_ENABLE BOOL + config: + example.enable: # or null +  + + phase of the example looper in seconds + option: --example-phase SECONDS + env: EXAMPLE_PHASE SECONDS + config: + example.phase: # or null +  + + period of the example looper in seconds + option: --example-period SECONDS + env: EXAMPLE_PERIOD SECONDS + config: + example.period: # or null +  + + +Options: + --(enable|disable)-example enable the example looper + --example-phase phase of the example looper in seconds default: 60s + --example-period period of the example looper in seconds default: 3600s + +Environment Variables: + EXAMPLE_ENABLE BOOL enable the example looper + EXAMPLE_PHASE SECONDS phase of the example looper in seconds + EXAMPLE_PERIOD SECONDS period of the example looper in seconds + +Configuration Values: + enable the example looper + example.enable: + # or null +  + phase of the example looper in seconds + example.phase: + # or null +  + period of the example looper in seconds + example.period: + # or null +  +