Add config file loading.

Ward.cabal

@@ -17,11 +17,13 @@ executable ward
   main-is:             Main.hs
   other-modules:       Args
                      , Check
+                     , Config
                      , Types
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall
   build-depends:       base
                      , containers
                      , language-c >= 0.6
+                     , parsec
                      , pretty
                      , text
                      , transformers
@@ -40,6 +42,7 @@ test-suite test
                      , HUnit
                      , hspec
                      , language-c
+                     , parsec
                      , pretty
                      , text
                      , transformers

src/Args.hs

@@ -7,7 +7,7 @@ module Args
   , usage
   ) where
 
-import Control.Applicative ((<|>))
+import Control.Applicative (Alternative(..))
 import Control.Arrow (second)
 import Data.List (partition, stripPrefix)
 import System.Environment (getArgs)
@@ -17,8 +17,9 @@ import System.IO (hPutStrLn, stderr)
 data Args = Args
   { preprocessorPath :: FilePath
   , translationUnitPaths :: [FilePath]
-  , flags :: [Flag]
+  , implicitPermissions :: [String]
   , preprocessorFlags :: [String]
+  , configFilePaths :: [FilePath]
   }
 
 parse :: IO Args
@@ -41,18 +42,23 @@ parse = do
   return Args
     { preprocessorPath = ppPath
     , translationUnitPaths = filePaths
-    , flags = parsedFlags
+    , implicitPermissions = [permission | GrantFlag permission <- parsedFlags]
     , preprocessorFlags = defaultPreprocessorFlags ++ ppFlags
+    , configFilePaths = [path | ConfigFlag path <- parsedFlags]
     }
 
 defaultPreprocessorFlags :: [String]
 defaultPreprocessorFlags = ["-D__WARD__"]
 
-data Flag = GrantFlag String
+data Flag = GrantFlag String | ConfigFlag FilePath
 
 parseFlag :: String -> Either String Flag
-parseFlag arg = maybe (Left arg) Right
-  $ try GrantFlag "--grant=" <|> try GrantFlag "-G"
+parseFlag arg = maybe (Left arg) Right $ foldr (<|>) empty
+  [ try GrantFlag "--grant="
+  , try GrantFlag "-G"
+  , try ConfigFlag "--config="
+  , try ConfigFlag "-C"
+  ]
   where
     try f prefix = f <$> stripPrefix prefix arg
 

src/Config.hs

@@ -0,0 +1,103 @@
+module Config
+  ( Config(..)
+  , Restriction(..)
+  , fromFile
+  , fromSource
+  , query
+  ) where
+
+import Control.Monad (void)
+import Data.Foldable (toList)
+import Data.Map (Map)
+import Data.Monoid -- *
+import Data.Text (Text)
+import GHC.Exts (IsString(..))
+import Text.Parsec
+import Text.Parsec.String
+import Types
+import qualified Data.Map as Map
+import qualified Data.Text as Text
+
+newtype Config = Config (Map Permission [(Restriction, Maybe Description)])
+  deriving (Eq, Show)
+
+instance Monoid Config where
+  mempty = Config mempty
+  mappend (Config a) (Config b) = Config $ Map.unionWith (<>) a b
+
+query :: Permission -> Config -> Maybe [(Restriction, Maybe Description)]
+query p (Config c) = Map.lookup p c
+
+data Restriction
+  = !Restriction :& !Restriction
+  | !Restriction :| !Restriction
+  | Not !Restriction
+  | Literal !Permission
+  deriving (Eq, Show)
+
+instance IsString Restriction where
+  fromString = Literal . fromString
+
+infixr 3 :&
+infixr 2 :|
+
+type Description = Text
+
+fromFile :: FilePath -> IO (Either ParseError Config)
+fromFile path = fromSource path <$> readFile path
+
+fromSource :: FilePath -> String -> Either ParseError Config
+fromSource = parse parser
+
+parser :: Parser Config
+parser = Config . Map.fromListWith (<>)
+  <$> between silence eof (many declaration)
+
+declaration :: Parser (Permission, [(Restriction, Maybe Description)])
+declaration = (,)
+  <$> (permission <* silence)
+  <*> (toList <$> optionMaybe restriction) <* operator ';'
+
+restriction :: Parser (Restriction, Maybe Description)
+restriction = lexeme (string "->")
+  *> ((,) <$> expression <*> optionMaybe description)
+
+expression :: Parser Restriction
+expression = orExpression
+  where
+    orExpression = foldr1 (:|) <$> andExpression `sepBy1` operator '|'
+    andExpression = foldr1 (:&) <$> term `sepBy1` operator '&'
+    term = choice
+      [ Literal <$> permission
+      , Not <$> (operator '!' *> term)
+      , parenthesized expression
+      ]
+    parenthesized = between (operator '(') (operator ')')
+
+description :: Parser Description
+description = fmap Text.pack $ lexeme $ quoted $ many $ character <|> escape
+  where
+    character = noneOf "\\\""
+    escape = char '\\' *> choice
+      [ '\\' <$ char '\\'
+      , '"' <$ char '"'
+      ]
+    quoted = between (char '"') (char '"')
+
+permission :: Parser Permission
+permission = Permission . Text.pack <$> lexeme ((:) <$> first <*> many rest)
+  where
+    first = letter <|> char '_'
+    rest = alphaNum <|> char '_'
+
+silence :: Parser ()
+silence = void $ many $ choice
+  [ (:[]) <$> oneOf "\t\n\r "
+  , between (string "//") (void (char '\n') <|> eof) $ many $ noneOf "\n"
+  ]
+
+operator :: Char -> Parser ()
+operator = void . lexeme . char
+
+lexeme :: Parser a -> Parser a
+lexeme = (<* silence)

src/Main.hs

@@ -7,10 +7,12 @@ import Data.IORef -- *
 import Data.Traversable (forM)
 import Language.C (parseCFile)
 import Language.C.System.GCC (newGCC)
+import System.Exit (exitFailure)
 import System.IO (hPutStrLn, stderr)
 import Types
 import qualified Args
 import qualified Check
+import qualified Config
 import qualified Data.Set as Set
 import qualified Data.Text as Text
 
@@ -19,15 +21,22 @@ main = do
   args <- Args.parse
   let temporaryDirectory = Nothing
   let preprocessor = newGCC $ Args.preprocessorPath args
+  parsedConfigs <- if null $ Args.configFilePaths args then pure [] else do
+    putStrLn "Loading config files..."
+    traverse Config.fromFile $ Args.configFilePaths args
+  config <- case sequence parsedConfigs of
+    Left parseError -> do
+      hPutStrLn stderr $ "Config parse error:\n" ++ show parseError
+      exitFailure
+    Right configs -> pure $ mconcat configs
   putStrLn "Preprocessing..."
   parseResults <- forM (Args.translationUnitPaths args)
     $ parseCFile preprocessor temporaryDirectory
     $ Args.preprocessorFlags args
   let
     implicitPermissions = Set.fromList
-      [ Permission $ Text.pack permission
-      | Args.GrantFlag permission <- Args.flags args
-      ]
+      $ map (Permission . Text.pack)
+      $ Args.implicitPermissions args
   putStrLn "Checking..."
   case sequence parseResults of
     Left parseError -> do

test/Spec.hs

@@ -5,6 +5,7 @@ module Main
   ) where
 
 import Args (Args(Args))
+import Config (Config(Config), Restriction(..))
 import Data.IORef -- *
 import Data.Text (Text)
 import Data.Traversable (forM)
@@ -13,9 +14,12 @@ import Language.C.Data.Node (NodeInfo)
 import Language.C.System.GCC (newGCC)
 import Test.HUnit hiding (errors)
 import Test.Hspec
+import Text.Parsec (ParseError)
 import Types
 import qualified Args
 import qualified Check
+import qualified Config
+import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.Text as Text
 
@@ -24,6 +28,55 @@ main = hspec spec
 
 spec :: Spec
 spec = do
+
+  describe "with config files" $ do
+
+    it "accepts empty config" $ do
+      configTest "" $ Right mempty
+
+    it "accepts comment at end of file" $ do
+      configTest
+        "// comment"
+        $ Right mempty
+
+    it "accepts multiple comments" $ do
+      configTest
+        "// comment\n\
+        \// comment\n"
+        $ Right mempty
+
+    it "accepts permission declaration" $ do
+      configTest
+        "perm1;"
+        $ Right $ Config $ Map.singleton "perm1" []
+
+    it "accepts multiple permission declarations" $ do
+      configTest
+        "perm1; perm2;"
+        $ Right $ Config $ Map.fromList
+          [ ("perm1", [])
+          , ("perm2", [])
+          ]
+
+    it "accepts relationship declaration" $ do
+      configTest
+        "perm1 -> perm2;"
+        $ Right $ Config $ Map.singleton "perm1" [("perm2", Nothing)]
+
+    it "accepts relationship declaration with description" $ do
+      configTest
+        "perm1 -> perm2 \"perm1 implies perm2\";"
+        $ Right $ Config $ Map.singleton "perm1"
+          [ ("perm2", Just "perm1 implies perm2")
+          ]
+
+    it "accepts relationship declaration with complex expression" $ do
+      configTest
+        "p1 -> p2 & p3 | p4 & !p5 | !(p6 & p7);"
+        $ Right $ Config $ Map.singleton "p1"
+          [ ("p2" :& "p3" :| "p4" :& Not "p5" :| Not ("p6" :& "p7"), Nothing)
+          ]
+
   describe "with simple errors" $ do
 
     it "reports invalid permission actions" $ do
@@ -78,10 +131,14 @@ defArgs :: Args
 defArgs = Args
   { Args.preprocessorPath = "gcc"
   , Args.translationUnitPaths = []
-  , Args.flags = []
+  , Args.implicitPermissions = []
   , Args.preprocessorFlags = []
+  , Args.configFilePaths = []
   }
 
+configTest :: String -> Either ParseError Config -> IO ()
+configTest source expected = Config.fromSource "test" source `shouldBe` expected
+
 wardTest
   :: Args
   -> (([(NodeInfo, Text)], [(NodeInfo, Text)], [(NodeInfo, Text)]) -> IO ())
@@ -94,9 +151,8 @@ wardTest args check = do
     $ Args.preprocessorFlags args
   let
     implicitPermissions = Set.fromList
-      [ Permission $ Text.pack permission
-      | Args.GrantFlag permission <- Args.flags args
-      ]
+      $ map (Permission . Text.pack)
+      $ Args.implicitPermissions args
   case sequence parseResults of
     Left parseError -> assertFailure $ "Parse error: " ++ show parseError
     Right translationUnits -> do