More faithful replication of lyft/ratelimit config loading rules: part 1

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

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

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))

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'.

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
+  |]

test/Tests.hs

@@ -1 +1 @@
-{-# OPTIONS_GHC -F -pgmF tasty-discover #-}
+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-}