diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2018 Fernando Freire, 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 Author name here 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,55 @@ +[![Build Status](https://travis-ci.org/dogonthehorizon/git-config.svg?branch=master)](https://travis-ci.org/dogonthehorizon/git-config) + +# git-config + +A simple parser for [Git configuration] files. + +## Getting Started + +This project is built using [Stack], make sure you have it installed before +proceeding. + +You can fire up an interactive session like so: + +``` +stack ghci +``` + +The library can be built or tested like so: + +``` +# Building +stack build +# Running tests +stack test +``` + +## Usage + +A Git configuration is a colletion of sections that contain mappings of keys +to values. + +For the sake of simplicity this is represented as `[Section]` where a +`Section` is a collection of section names and a mapping of keys to values. + +We can use the parser like so: + +```haskell +import qualified Data.Text.IO as TIO +import Text.GitConfig.Parser (parseConfig) + +main :: IO () +main = do + file <- TIO.readFile ".git/config" + case parseConfig file of + Right conf -> + print conf + Left error -> + print error +``` + +If you'd like to do your own parsing you can import the individual combinators +from the `Text.GitConfig.Parser` module. + +[Stack]: https://docs.haskellstack.org/en/stable/README/ +[Git configuration]: https://git-scm.com/docs/git-config/2.16.0#_syntax diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/git-config.cabal b/git-config.cabal new file mode 100644 --- /dev/null +++ b/git-config.cabal @@ -0,0 +1,83 @@ +-- This file has been generated from package.yaml by hpack version 0.20.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 61a8d8d4516720b4def60b163c2a76d8e819827aa17f1edbe115b50258866169 + +name: git-config +version: 0.1.0 +synopsis: A simple parser for Git configuration files. +description: git-config is a simple 'megaparsec' parser for Git configuration files. + . + It aims to provide the simplest API possible for parsing Git configuration + files so that you can get to whatever it was you were doing. + . + A sample of this library in use: + . + > import qualified Data.Text.IO as TIO + > import Text.GitConfig.Parser (parseConfig) + > + > main :: IO () + > main = do + > file <- TIO.readFile ".git/config" + > case parseConfig file of + > Right conf -> + > print conf +category: Library,Git +homepage: https://github.com/dogonthehorizon/git-config#readme +bug-reports: https://github.com/dogonthehorizon/git-config/issues +author: Fernando Freire +maintainer: dogonthehorizon@gmail.com +copyright: 2018 Fernando Freire +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/dogonthehorizon/git-config + +library + hs-source-dirs: + src + default-extensions: OverloadedStrings + ghc-options: -Wall -fno-warn-partial-type-signatures -fno-warn-name-shadowing -fwarn-tabs -fwarn-unused-imports -fwarn-missing-signatures -fwarn-incomplete-patterns + build-depends: + base >=4.7 && <5 + , megaparsec + , text + , unordered-containers + exposed-modules: + Text.GitConfig.Parser + other-modules: + Paths_git_config + default-language: Haskell2010 + +test-suite git-config-test + type: exitcode-stdio-1.0 + main-is: Tasty.hs + hs-source-dirs: + test + default-extensions: OverloadedStrings + ghc-options: -Wall -fno-warn-partial-type-signatures -fno-warn-name-shadowing -fwarn-tabs -fwarn-unused-imports -fwarn-missing-signatures -fwarn-incomplete-patterns -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , git-config + , megaparsec + , smallcheck + , smallcheck-series + , tasty + , tasty-discover + , tasty-hunit + , tasty-smallcheck + , tasty-travis + , text + , unordered-containers + other-modules: + Text.GitConfig.ParserTest + Paths_git_config + default-language: Haskell2010 diff --git a/src/Text/GitConfig/Parser.hs b/src/Text/GitConfig/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Text/GitConfig/Parser.hs @@ -0,0 +1,173 @@ +{-| +Module : Text.GitConfig.Parser +Description : Parser-combinators for Git configuration files. +Copyright : (c) Fernando Freire, 2018 +License : BSD3 +Maintainer : dogonthehorizon@gmail.com +Stability : experimental + +This module provides parser-combinators for Git configuration files. + +It attempts to follow the syntax for Git configuration files outlined in +this document: + +https://git-scm.com/docs/git-config/2.16.0#_syntax + +One notable omission is that no legacy compatability is explicitly provided +(e.g. dot-separated subsection names are not guaranteed to parse correctly). +-} + +{-# LANGUAGE TypeFamilies #-} + +module Text.GitConfig.Parser ( + -- * Types + Parser, + Section(..), + GitConfig, + -- * Lexer + spaceConsumer, + lexeme, + symbol, + brackets, + quotes, + escSeq, + -- * Parser + sectionName, + sectionHeader, + variableName, + variableValue, + mapping, + section, + config, + parseConfig +) where + +import Control.Applicative (empty) +import Control.Monad (void) +import Data.Functor (($>)) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as M +import Data.Text (Text) +import qualified Data.Text as T +import Data.Void (Void) +import Text.Megaparsec (ParseError, Parsec, Token, between, + eof, many, parse, sepBy, some, + (), (<|>)) +import Text.Megaparsec.Char (alphaNumChar, char, eol, + letterChar, printChar, satisfy, + space1) +import qualified Text.Megaparsec.Char.Lexer as Lexer + +type GitConfigError = ParseError (Token Text) Void +type Parser = Parsec Void Text + +data Section = Section [Text] (HashMap Text Text) + deriving (Eq, Show) + +type GitConfig = [Section] + +-- | Whitespace consumer for this parser. +-- +-- Whitespace is considered to be any space character +-- (including carriage return) as well as line comments starting with `#` and +-- `;` . +spaceConsumer :: Parser () +spaceConsumer = Lexer.space space1 lineComment empty + where lineComment = Lexer.skipLineComment "#" <|> Lexer.skipLineComment ";" + +-- | A lexeme for this parser. +lexeme :: Parser a -> Parser a +lexeme = Lexer.lexeme spaceConsumer + +-- | A symbol for this parser. +symbol :: Text -> Parser Text +symbol = Lexer.symbol spaceConsumer + +-- | Return a parser in between brackets. +brackets :: Parser a -> Parser a +brackets = between (symbol "[") (symbol "]") + +-- | Return a parser in between quotes. +quotes :: Parser a -> Parser a +quotes = between (symbol "\"") (symbol "\"") + +-- | Parser for escape sequences. +escSeq :: Parser Char +escSeq = char '\\' *> escSeqChar + where + escSeqChar = char '"' + <|> char '\\' + <|> char '/' + <|> (char 'n' $> '\n') + <|> (char 't' $> '\t') + <|> (char 'r' $> '\r') + <|> (char 'b' $> '\b') + <|> (char 'f' $> '\f') + "escaped character" + +-- | Parse a section name. +-- +-- Section names are case-insensitive. Only alphanumeric +-- characters, - and . are allowed in section names. Sections can be further +-- divided into subsections. To begin a subsection put its name in double +-- quotes, separated by space from the section name, in the section header. +sectionName :: Parser [Text] +sectionName = (section <|> subSection) `sepBy` spaceConsumer + where + sectionChar = alphaNumChar <|> char '.' <|> char '-' + section = fmap T.pack . some $ sectionChar + subSection = fmap T.pack . quotes . many $ + escSeq <|> satisfy (\x -> x `notElem` ['"', '\\']) + +-- | Parse a section header. +-- +-- A section begins with the name of the section in square brackets and +-- continues until the next section begins. +sectionHeader :: Parser [Text] +sectionHeader = brackets sectionName + +-- | Parse a variable name. +-- +-- The variable names are case-insensitive, allow only alphanumeric +-- characters and -, and must start with an alphabetic character. +variableName :: Parser Text +variableName = fmap (T.toLower . T.pack) . lexeme $ p + where + p = (:) <$> letterChar <*> many (alphaNumChar <|> char '-') + +-- | Parse a variable value. +variableValue :: Parser Text +variableValue = T.pack <$> between spaceConsumer eol (many printChar) + +-- | Parse a tuple of 'Text' key and value. +-- +-- in the form name = value (or just name, which is a short-hand to say that +-- the variable is the boolean "true"). -- FIXME parse boolean true +-- +-- A line that defines a value can be continued to the next line by ending +-- it with a \; the backquote and the end-of-line are stripped. Leading +-- whitespaces after name =, the remainder of the line after the first +-- comment character # or ;, and trailing whitespaces of the line are +-- discarded unless they are enclosed in double quotes. Internal whitespaces +-- within the value are retained verbatim. +mapping :: Parser (Text, Text) +mapping = do + varName <- variableName + void (symbol "=") + varValue <- variableValue + return (varName, varValue) + +-- | Parse a complete git config section. +section :: Parser Section +section = do + header <- sectionHeader + void spaceConsumer + sectionValues <- mapping `sepBy` spaceConsumer + return $ Section header (M.fromList sectionValues) + +-- | Parse a complete git config. +config :: Parser GitConfig +config = between spaceConsumer eof $ many section + +parseConfig :: Text -> Either GitConfigError GitConfig +parseConfig = parse config "noSrc" diff --git a/test/Tasty.hs b/test/Tasty.hs new file mode 100644 --- /dev/null +++ b/test/Tasty.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover #-} diff --git a/test/Text/GitConfig/ParserTest.hs b/test/Text/GitConfig/ParserTest.hs new file mode 100644 --- /dev/null +++ b/test/Text/GitConfig/ParserTest.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Text.GitConfig.ParserTest where + +import qualified Data.HashMap.Strict as M +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import Test.SmallCheck.Series.Instances () +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assertEqual, + assertFailure, testCase) +import Test.Tasty.SmallCheck (testProperty) +import qualified Text.GitConfig.Parser as P +import Text.Megaparsec (parse) + +-- | Simple assert helper for HUnit tests on parse results +assertSuccess :: Either e a -> Assertion +assertSuccess res = + case res of + Left _ -> assertFailure "" + Right _ -> return () + +assertFail :: Either e a -> Assertion +assertFail res = + case res of + Left _ -> return () + Right _ -> assertFailure "" + +test_symbol :: TestTree +test_symbol = testProperty + "symbol should parse the given text and consume trailing whitespace" $ + \(t :: Text) -> + case parse (P.symbol t) "" (t <> " ") of + Left _ -> False + Right t' -> t == t' + +test_brackets :: TestTree +test_brackets = testProperty + "brackets should parse the given text between '[' and ']' characters" $ + \(t :: Text) -> + let tBetweenBrackets = "[" <> t <> "]" in + case parse (P.brackets (P.symbol t)) "" tBetweenBrackets of + Left _ -> False + Right t' -> t == t' + +test_quotes :: TestTree +test_quotes = testProperty + "quotes should parse the given text between '\"' characters" $ + \(t :: Text) -> + let tBetweenQuotes = "\"" <> t <> "\"" in + case parse (P.quotes (P.symbol t)) "" tBetweenQuotes of + Left _ -> False + Right t' -> t == t' + +(<&>) :: Functor f => f a -> (a -> b) -> f b +(<&>) = flip fmap + +test_escSeq :: TestTree +test_escSeq = testGroup "ensure all valid escape sequences are parsed" $ + ["\"", "\\", "/", "n", "t", "r", "b", "f"] <&> \(t :: Text) -> + let escaped = "\\" <> t in + testCase (T.unpack $ "char " <> escaped) $ + assertSuccess $ parse P.escSeq "" escaped + +test_sectionName :: TestTree +test_sectionName = testGroup + "sectionName parses both section and subsection names" + [ + testCase "section" $ + assertSuccess $ parse P.sectionName "" "core", + testCase "subSection" $ + assertSuccess $ parse P.sectionName "" "core \"sub/+Section\"" + ] + +test_sectionHeader :: TestTree +test_sectionHeader = testGroup + "sectionHeader parses an entire section header" + [ + testCase "section" $ + assertSuccess $ parse P.sectionHeader "" "[core]", + testCase "subSection" $ + assertSuccess $ parse P.sectionHeader "" "[core \"sub/+Section\"]" + ] + +test_variableName :: TestTree +test_variableName = testGroup "variableName parses a key in a key/val pair" + [ + testCase "valid" $ + assertSuccess $ parse P.variableName "" "aSdF", + testCase "fail start with nonalpha" $ + assertFail $ parse P.variableName "" "+ASDF", + testCase "pass with dash" $ + assertSuccess $ parse P.variableName "" "foo-bar" + ] + +test_variableValue :: TestTree +test_variableValue = testGroup + "variableValue parses the value in a key/value pair" + [ + testCase "valid" $ + assertSuccess $ parse P.variableValue "" "foo\n", + testCase "fail without eol" $ + assertFail $ parse P.variableValue "" "foo" + ] + +test_mapping :: TestTree +test_mapping = testGroup + "mapping parses entire key/value pairs" + [ + testCase "valid" $ + assertSuccess $ parse P.mapping "" "key = value\n", + testCase "temporarily invalid boolean switch" $ + assertFail $ parse P.mapping "" "key\n" + ] + +test_section :: TestTree +test_section = testGroup + "section parses entire sections in a git config" + [ + testCase "valid" $ + assertSuccess $ parse P.section "" "[core]\nfoo = bar\n", + testCase "valid multiple mappings" $ + assertSuccess $ parse P.section "" "[core]\nfoo = bar\nbaz = quux\n", + testCase "valid stop at one section" $ + case parse P.section "" "[core \"subsec\"]\nfoo = bar\n[next \"section\"]\nlol = hi\n" of + Left _ -> assertFailure "" + Right p -> + assertEqual "" + (P.Section ["core", "subsec"] (M.fromList [("foo", "bar")])) p + ] + +test_config :: TestTree +test_config = testGroup + "config parses an entire git configuration" + [ + testCase "valid" $ + assertSuccess $ parse P.config "" "[core]\nfoo=bar\n[remote \"origin\"]\nkey=val\n", + testCase "invalid mapping without section" $ + assertFail $ parse P.config "" "foo=bar\n[remote \"origin\"]\nkey=val\n" + ]