diff --git a/library/System/OsRelease.hs b/library/System/OsRelease.hs --- a/library/System/OsRelease.hs +++ b/library/System/OsRelease.hs @@ -1,19 +1,107 @@ +{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving #-} + module System.OsRelease - ( detect - , OsRelease (..) - , detect' + ( parseOs + , readOs + , readOs' + , OsReleaseValue (..) + , OsReleaseKey (..) + , OsReleaseLine + , OsRelease ) where -data OsRelease = OpenSUSE - deriving (Eq, Show) +import Text.ParserCombinators.Parsec +import Text.Parsec.Prim hiding (try) +import Data.Map.Lazy hiding (foldl) +import Data.Functor.Identity +import Data.String +import Data.Monoid +import Data.Either +import Control.Applicative ((<$>)) +import Control.Monad +import qualified Control.Exception as E -detect :: IO (Maybe OsRelease) -detect = do - osr <- readFile "/etc/os-release" - return . detect' $ lines osr +type OsReleaseLine = (OsReleaseKey, OsReleaseValue) +newtype OsReleaseKey = OsReleaseKey String + deriving (Ord, Eq, IsString, Show) -detect' :: [String] -> Maybe OsRelease -detect' [] = Nothing -detect' ("NAME=openSUSE":_) = Just OpenSUSE -detect' (_:xs) = detect' xs +newtype OsReleaseValue = OsReleaseValue String + deriving (IsString, Eq, Show) + +type OsRelease = Map OsReleaseKey OsReleaseValue + +class Parsable a where + parser :: ParsecT String () Identity a + +instance Parsable OsReleaseKey where + parser = OsReleaseKey <$> many1 (alphaNum <|> char '_') + +instance Parsable OsReleaseValue where + parser = OsReleaseValue <$> (qVal <|> nqVal) + where + qVal :: Parser String + qVal = do + quote <- oneOf "'\"" + value <- manyTill (qValInside quote) (char quote) + noJunk + return (foldl mappend "" value) + + noJunk = try . lookAhead $ eof <|> (void newline) + + qValInside :: Char -> ParsecT String () Identity String + qValInside quote = (qSpecial quote) <|> (:[]) <$> (noneOf $ specials quote) + + qSpecial :: Char -> ParsecT String () Identity String + qSpecial quote = (\x -> [x!!1]) <$> + foldl1 (<|>) [try (string $ "\\" <> [x]) | x <- specials quote] + + specials :: Char -> [Char] + specials quote = + [ quote + , '\\' + , '$' + , '`' + ] + + nqVal :: Parser String + nqVal = do + x <- many alphaNum + noJunk + return x + +instance Parsable OsReleaseLine where + parser = do + var <- parser :: ParsecT String () Identity OsReleaseKey + _ <- char '=' + val <- parser :: ParsecT String () Identity OsReleaseValue + return (var, val) + +instance Parsable OsRelease where + parser = fromList <$> (sepEndBy (parser :: ParsecT String () Identity OsReleaseLine) newline) + + +readOs :: IO (Either OsReleaseError OsRelease) +readOs = do + xs <- readOs' ["/etc/os-release", "/usr/lib/os-release"] + case xs of + Left e -> return $ Left e + Right x -> return . h $ parseOs x + where + h (Left e) = Left $ OsReleaseParseError e + h (Right x) = Right x + +data OsReleaseError = OsReleaseError String + | OsReleaseParseError ParseError + deriving (Show) + +readOs' :: [FilePath] -> IO (Either OsReleaseError String) +readOs' fs = do + xs <- mapM (E.try . readFile) fs :: IO [Either E.IOException String] + return . h $ rights xs + where + h [] = Left . OsReleaseError $ "Neither of " <> unwords fs <> " could be read" + h (x:_) = Right x + +parseOs :: String -> Either ParseError OsRelease +parseOs xs = parse (parser :: ParsecT String () Identity OsRelease) "os-release" xs diff --git a/os-release.cabal b/os-release.cabal --- a/os-release.cabal +++ b/os-release.cabal @@ -9,7 +9,7 @@ homepage: https://github.com/yaccz/os-release name: os-release synopsis: /etc/os-release helpers -version: 0.1.0 +version: 0.2.0 description: /etc/os-release helpers @@ -19,7 +19,12 @@ library build-depends: - base < 5 + base < 5 + , parsec + , containers + , parsec + , containers + , transformers default-language: Haskell2010 exposed-modules: System.OsRelease ghc-options: @@ -34,6 +39,10 @@ base < 5 , os-release , hspec + , parsec + , containers + , transformers + , temporary default-language: Haskell2010 ghc-options: @@ -41,7 +50,7 @@ -Werror hs-source-dirs: library - tests + tests/unit main-is: Spec.hs other-modules: diff --git a/tests/OsReleaseSpec.hs b/tests/OsReleaseSpec.hs deleted file mode 100644 --- a/tests/OsReleaseSpec.hs +++ /dev/null @@ -1,13 +0,0 @@ -module OsReleaseSpec (spec) where - -import Test.Hspec -import System.OsRelease - -spec :: Spec -spec = do - describe "detect" $ do - it "parses" $ do - detect' ["NAME=openSUSE"] `shouldBe` Just OpenSUSE - detect' [] `shouldBe` Nothing - detect' ["NAME=open"] `shouldBe` Nothing - detect' ["NAME=\"openSUSE\""] `shouldBe` Nothing diff --git a/tests/Spec.hs b/tests/Spec.hs deleted file mode 100644 --- a/tests/Spec.hs +++ /dev/null @@ -1,1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/tests/unit/OsReleaseSpec.hs b/tests/unit/OsReleaseSpec.hs new file mode 100644 --- /dev/null +++ b/tests/unit/OsReleaseSpec.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE OverloadedStrings #-} +module OsReleaseSpec (spec) where + +import Test.Hspec +import System.OsRelease +import Data.Map.Lazy +import Data.Monoid +import OsReleaseSpec.Reals +import System.IO.Temp +import System.IO + +spec :: Spec +spec = do + describe "parseOs" $ do + it "parses simple value" $ fooBar "foo=bar" + it "parses simple value with trailing NL" $ fooBar "foo=bar\n" + it "parses single quoted value" $ fooBar "foo='bar'" + it "parses double quoted value" $ fooBar "foo=\"bar\"" + + it "parses _ var" $ parseCase "f_x=''" [("f_x", "")] + + it "parses quoted space" $ parseCase "f='a b'" [("f", "a b")] + it "parses quoted -" $ parseCase "f='a-b'" [("f", "a-b")] + + it "parses special \\" $ specialFooBar "foo='ba\\\\r'" "\\" + it "parses special `" $ specialFooBar "foo='ba\\`r'" "`" + it "parses special '" $ specialFooBar "foo='ba\\'r'" "'" + it "parses special $" $ specialFooBar "foo='ba\\$r'" "$" + it "parses special \"" $ specialFooBar "foo=\"ba\\\"r\"" "\"" + + it "parses multiple values" $ parseCase + "foo=bar\nqux=quux" + [("foo", "bar"), ("qux", "quux")] + + it "parses empty val noquotes" $ parseCase "foo=" [("foo", "")] + it "parses empty val quote \"" $ parseCase "foo=\"\"" [("foo", "")] + it "parses empty val quote '" $ parseCase "foo=''" [("foo", "")] + + it "breaks on misquoting 1" $ errCase "foo=\"bar'" + it "breaks on misquoting 2" $ errCase "foo='bar\"" + it "breaks on unquoted $" $ errCase "foo='ba$r'" + it "breaks on unquoted `" $ errCase "foo='ba`r'" + it "breaks on unquoted \"" $ errCase "foo=\"ba\"r\"" + it "breaks on unquoted '" $ errCase "foo='ba'r'" + it "breaks on unquoted \\" $ errCase "foo='ba\\r'" + it "breaks on unquoted val with space" $ errCase "foo=ba r" + it "breaks on unquoted val with ;" $ errCase "foo=ba;r" + it "breaks on unquoted val with \\" $ errCase "foo=ba\\r" + + it "parses Gentoo os-release" $ realCase Gentoo + it "parses OpenSUSE Factory os-release" $ realCase OpenSUSEFactory + it "parses Arch os-release" $ realCase Arch + + describe "readOs'" $ do + it "reads 1st" $ do + withSystemTempFile "1st.txt" $ \f1 hf1 -> do + withSystemTempFile "2nd.txt" $ \f2 hf2 -> do + hPutStr hf1 "1" + hPutStr hf2 "2" + mapM_ hClose [hf1, hf2] + + xs <- readOs' [f1, f2] + case xs of + Right x -> x `shouldBe` "1" + Left e -> expectationFailure $ show e + + it "reads 2nd" $ do + withSystemTempFile "a-file.txt" $ \f h -> do + hPutStr h "1" + hClose h + + xs <- readOs' ["/oh-well-let's-hope-no-one-makes-this-file", f] + case xs of + Right x -> x `shouldBe` "1" + Left e -> expectationFailure $ show e + + where + fooBar x = parseCase x [("foo", "bar")] + + specialFooBar :: String -> String -> Expectation + specialFooBar x y = parseCase x [("foo", OsReleaseValue $ "ba" <> y <> "r")] + + realCase x = parseCase (input x) (output x) + + parseCase x y = + case parseOs x of + Left e -> expectationFailure $ show e + Right z -> z `shouldBe` (fromList y) + + errCase x = + case parseOs x of + Left _ -> ("1"::String) `shouldBe` "1" + Right z -> expectationFailure (show z) diff --git a/tests/unit/Spec.hs b/tests/unit/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/unit/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}