packages feed

looper (empty) → 0.0.0.0

raw patch · 8 files changed

+528/−0 lines, 8 filesdep +aesondep +basedep +hspecsetup-changed

Dependencies added: aeson, base, hspec, looper, optparse-applicative, text, time, unliftio

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for looper++## Unreleased changes
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,1 @@+# looper
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ looper.cabal view
@@ -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 <https://github.com/NorfairKing/looper#readme>+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
+ src/Looper.hs view
@@ -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))
+ test/LooperSpec.hs view
@@ -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+        }
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}