diff --git a/fencer.cabal b/fencer.cabal index 8244173..b870c9f 100644 --- a/fencer.cabal +++ b/fencer.cabal @@ -57,6 +57,7 @@ library build-depends: base, base-prelude, + extra, hashable, monad-loops, time, @@ -110,6 +111,7 @@ test-suite test-fencer test other-modules: Fencer.Types.Test + Fencer.Rules.Test Fencer.Server.Test default-language: Haskell2010 @@ -118,12 +120,16 @@ test-suite test-fencer , aeson-qq , base , base-prelude + , directory , grpc-haskell + , filepath + , neat-interpolation , proto3-wire , proto3-suite , tasty , tasty-discover , tasty-hunit + , temporary , text , tinylog , unordered-containers diff --git a/lib/Fencer/Main.hs b/lib/Fencer/Main.hs index ae13bd9..253e6f8 100644 --- a/lib/Fencer/Main.hs +++ b/lib/Fencer/Main.hs @@ -14,10 +14,7 @@ import BasePrelude import Control.Concurrent.STM (atomically) import qualified Data.List.NonEmpty as NE -import Named ((:!), arg) -import System.Directory (listDirectory, doesFileExist) -import System.FilePath ((), takeExtension, takeFileName) -import qualified Data.Yaml as Yaml +import System.FilePath (()) import qualified System.Logger as Logger import System.Logger (Logger) @@ -100,31 +97,3 @@ reloadRules logger settings appState = do ] Logger.info logger $ Logger.msg (Logger.val "Applied new rules") - --- | Gather rate limiting rules (*.yml, *.yaml) from a directory. --- Subdirectories are not included. --- --- Throws an exception for unparseable or unreadable files. -loadRulesFromDirectory - :: "directory" :! FilePath - -> "ignoreDotFiles" :! Bool - -> IO [DomainDefinition] -loadRulesFromDirectory - (arg #directory -> directory) - (arg #ignoreDotFiles -> ignoreDotFiles) - = - do - files <- - filterM doesFileExist . map (directory ) =<< - listDirectory directory - let ruleFiles = - (if ignoreDotFiles then filter (not . isDotFile) else id) $ - filter isYaml files - mapM Yaml.decodeFileThrow ruleFiles - -- TODO: what does lyft/ratelimit do with unparseable files? - where - isYaml :: FilePath -> Bool - isYaml file = takeExtension file `elem` [".yml", ".yaml"] - - isDotFile :: FilePath -> Bool - isDotFile file = "." `isPrefixOf` takeFileName file diff --git a/lib/Fencer/Rules.hs b/lib/Fencer/Rules.hs index e9e5f2d..cf7a1b7 100644 --- a/lib/Fencer/Rules.hs +++ b/lib/Fencer/Rules.hs @@ -4,17 +4,66 @@ -- | Working with rate limiting rules. module Fencer.Rules - ( definitionsToRuleTree + ( loadRulesFromDirectory + , definitionsToRuleTree , applyRules ) where import BasePrelude +import Control.Monad.Extra (partitionM, concatMapM) import qualified Data.HashMap.Strict as HM +import Named ((:!), arg) +import System.Directory (listDirectory, doesFileExist, doesDirectoryExist, pathIsSymbolicLink) +import System.FilePath ((), takeFileName) +import qualified Data.Yaml as Yaml import Fencer.Types +-- | Read rate limiting rules from a directory, recursively. Files are +-- assumed to be YAML, but do not have to have a @.yml@ extension. +-- +-- Throws an exception for unparseable or unreadable files. +loadRulesFromDirectory + :: "directory" :! FilePath + -> "ignoreDotFiles" :! Bool + -> IO [DomainDefinition] +loadRulesFromDirectory + (arg #directory -> directory) + (arg #ignoreDotFiles -> ignoreDotFiles) + = + do + files <- listAllFiles directory + mapM Yaml.decodeFileThrow $ + if ignoreDotFiles + then filter (not . isDotFile) files + else files + where + isDotFile :: FilePath -> Bool + isDotFile file = "." `isPrefixOf` takeFileName file + + -- | Is the path a true directory (not a symlink)? + isDirectory :: FilePath -> IO Bool + isDirectory dir = + liftA2 (&&) + (doesDirectoryExist dir) + (not <$> (pathIsSymbolicLink dir `catchIOError` \_ -> pure False)) + + -- | List all files in a directory, recursively, without following + -- symlinks. + listAllFiles :: FilePath -> IO [FilePath] + listAllFiles dir = do + -- TODO: log exceptions + contents <- + map (dir ) <$> + (listDirectory dir `catchIOError` \_ -> pure []) + -- files = normal files and links to files + -- dirs = directories, but not links to directories + (files, other) <- partitionM doesFileExist contents + dirs <- filterM isDirectory other + (files ++) <$> concatMapM listAllFiles dirs + -- | Convert a list of descriptors to a 'RuleTree'. definitionsToRuleTree :: [DescriptorDefinition] -> RuleTree definitionsToRuleTree = HM.fromList . map (\d -> (makeKey d, makeBranch d)) diff --git a/lib/Fencer/Types.hs b/lib/Fencer/Types.hs index 9231145..ffbb078 100644 --- a/lib/Fencer/Types.hs +++ b/lib/Fencer/Types.hs @@ -85,7 +85,7 @@ timeUnitToSeconds = \case -- | Domain name. Several rate limiting rules can belong to the same domain. newtype DomainId = DomainId Text - deriving stock (Eq, Show) + deriving stock (Eq, Ord, Show) deriving newtype (Hashable, FromJSON) -- | Unwrap 'DomainId'. diff --git a/test/Fencer/Rules/Test.hs b/test/Fencer/Rules/Test.hs new file mode 100644 index 0000000..714212c --- /dev/null +++ b/test/Fencer/Rules/Test.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLabels #-} + +-- | Tests for "Fencer.Rules". +module Fencer.Rules.Test + ( test_loadRulesYaml + , test_loadRulesNonYaml + , test_loadRulesRecursively + ) +where + +import BasePrelude + +import Data.Text (Text) +import qualified Data.Text.IO as TIO +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (assertEqual, testCase) +import qualified System.IO.Temp as Temp +import NeatInterpolation (text) +import System.FilePath (()) +import System.Directory (createDirectoryIfMissing) +import Data.List (sortOn) + +import Fencer.Types +import Fencer.Rules + +-- | Test that 'loadRulesFromDirectory' loads rules from YAML files. +test_loadRulesYaml :: TestTree +test_loadRulesYaml = + testCase "Rules are loaded from YAML files" $ do + Temp.withSystemTempDirectory "fencer-config" $ \tempDir -> do + TIO.writeFile (tempDir "config1.yml") domain1Text + TIO.writeFile (tempDir "config2.yaml") domain2Text + definitions <- + loadRulesFromDirectory (#directory tempDir) (#ignoreDotFiles True) + assertEqual "unexpected definitions" + (sortOn domainDefinitionId [domain1, domain2]) + (sortOn domainDefinitionId definitions) + +-- | Test that 'loadRulesFromDirectory' loads rules from all files, not just +-- YAML files. +-- +-- This counterintuitive behavior matches the behavior of @lyft/ratelimit@. +test_loadRulesNonYaml :: TestTree +test_loadRulesNonYaml = + testCase "Rules are loaded from non-YAML files" $ do + Temp.withSystemTempDirectory "fencer-config" $ \tempDir -> do + TIO.writeFile (tempDir "config1.bin") domain1Text + TIO.writeFile (tempDir "config2") domain2Text + definitions <- + loadRulesFromDirectory (#directory tempDir) (#ignoreDotFiles True) + assertEqual "unexpected definitions" + (sortOn domainDefinitionId [domain1, domain2]) + (sortOn domainDefinitionId definitions) + +-- | Test that 'loadRulesFromDirectory' loads rules recursively. +-- +-- This matches the behavior of @lyft/ratelimit@. +test_loadRulesRecursively :: TestTree +test_loadRulesRecursively = + testCase "Rules are loaded recursively" $ do + Temp.withSystemTempDirectory "fencer-config" $ \tempDir -> do + createDirectoryIfMissing True (tempDir "domain1") + TIO.writeFile (tempDir "domain1/config.yml") domain1Text + createDirectoryIfMissing True (tempDir "domain2/config") + TIO.writeFile (tempDir "domain2/config/config.yml") domain2Text + definitions <- + loadRulesFromDirectory (#directory tempDir) (#ignoreDotFiles True) + assertEqual "unexpected definitions" + (sortOn domainDefinitionId [domain1, domain2]) + (sortOn domainDefinitionId definitions) + +---------------------------------------------------------------------------- +-- Sample definitions +---------------------------------------------------------------------------- + +domain1 :: DomainDefinition +domain1 = DomainDefinition + { domainDefinitionId = DomainId "domain1" + , domainDefinitionDescriptors = descriptor1 :| [] + } + where + descriptor1 :: DescriptorDefinition + descriptor1 = DescriptorDefinition + { descriptorDefinitionKey = RuleKey "some key" + , descriptorDefinitionValue = Just $ RuleValue "some value" + , descriptorDefinitionRateLimit = Nothing + , descriptorDefinitionDescriptors = Nothing + } + +domain1Text :: Text +domain1Text = [text| + domain: domain1 + descriptors: + - key: some key + value: some value + |] + +domain2 :: DomainDefinition +domain2 = DomainDefinition + { domainDefinitionId = DomainId "domain2" + , domainDefinitionDescriptors = descriptor2 :| [] + } + where + descriptor2 :: DescriptorDefinition + descriptor2 = DescriptorDefinition + { descriptorDefinitionKey = RuleKey "some key 2" + , descriptorDefinitionValue = Nothing + , descriptorDefinitionRateLimit = Nothing + , descriptorDefinitionDescriptors = Nothing + } + +domain2Text :: Text +domain2Text = [text| + domain: domain2 + descriptors: + - key: some key 2 + |] diff --git a/test/Tests.hs b/test/Tests.hs index 70c55f5..327adf4 100644 --- a/test/Tests.hs +++ b/test/Tests.hs @@ -1 +1 @@ -{-# OPTIONS_GHC -F -pgmF tasty-discover #-} +{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-}