jan-matejka / os-release Goto Github PK
View Code? Open in Web Editor NEWos-release parser in haskell
License: BSD 3-Clause "New" or "Revised" License
os-release parser in haskell
License: BSD 3-Clause "New" or "Revised" License
I'm using similar code in ghcup, but don't want to release a second package. Let me know what you think. I liked your parser, so took a few ideas from that, but extended it in some places (e.g. according to the spec, assignments without quotes are also valid). I also removed some inefficiencies due to foldl. I believe this API is simpler and still allows arbitrary control due to allAssignments
:
-- | All the explicitly documented fields of `os-release`.
data OsRelease = OsRelease {
name :: Maybe String
, version :: Maybe String
, id :: Maybe String
, id_like :: Maybe String
, version_codename :: Maybe String
, version_id :: Maybe String
, pretty_name :: Maybe String
, ansi_color :: Maybe String
, cpe_name :: Maybe String
, home_url :: Maybe String
, documentation_url :: Maybe String
, support_url :: Maybe String
, bug_report_url :: Maybe String
, privacy_policy_url :: Maybe String
, build_id :: Maybe String
, variant :: Maybe String
, variant_id :: Maybe String
, logo :: Maybe String
} deriving (Show)
emptyOsRelease :: OsRelease
emptyOsRelease = OsRelease { name = Nothing
, version = Nothing
, id = Nothing
, id_like = Nothing
, version_codename = Nothing
, version_id = Nothing
, pretty_name = Nothing
, ansi_color = Nothing
, cpe_name = Nothing
, home_url = Nothing
, documentation_url = Nothing
, support_url = Nothing
, bug_report_url = Nothing
, privacy_policy_url = Nothing
, build_id = Nothing
, variant = Nothing
, variant_id = Nothing
, logo = Nothing
}
-- | Parse a single line assignment and extract the right hand side.
-- This is only a subset of a shell parser, see
-- https://www.freedesktop.org/software/systemd/man/os-release.html
parseAssignment :: MP.Parsec Void String (String, String)
parseAssignment =
(,)
<$> (MP.space *> key)
<*> (MP.char '=' *> (MP.try qval <|> mempty) <* MP.space <* MP.eof)
where
dropSpace :: String -> String
dropSpace = reverse . dropWhile (\x -> x == ' ' || x == '\t') . reverse
key :: MP.Parsec Void String String
key = some (MP.try MP.alphaNumChar <|> MP.char '_')
qval :: MP.Parsec Void String String
qval = do
c <- MP.lookAhead MP.printChar
case c of
' ' -> pure ""
'"' -> MP.char c *> val c <* MP.char c
'\'' -> MP.char c *> val c <* MP.char c
-- no quote, have to drop trailing spaces
_ -> fmap dropSpace (some MP.alphaNumChar)
val :: Char -> MP.Parsec Void String String
val q = many (qspecial q <|> MP.noneOf (specials q)) -- noneOf may be too lax
qspecial :: Char -> MP.Parsec Void String Char
qspecial q =
fmap (!! 1)
. choice'
. fmap (\s -> MP.try . MP.chunk $ ['\\', s])
$ (specials q)
specials :: Char -> [Char]
specials q = [q, '\\', '$', '`']
-- | Get all allAssignments as `(key, val)` from the `os-release`
-- file contents.
allAssignments :: String -- ^ file contents of os-release
-> [(String, String)]
allAssignments = rights . fmap (MP.parse parseAssignment "") . lines
-- | Parse the assignments into OsRelease.
--
-- This can't fail and will create an "empty" product type instead on
-- failure.
osRelease :: [(String, String)] -- ^ assignments
-> OsRelease
osRelease =
(\case
Error _ -> emptyOsRelease
Success v -> v
)
. fromJSON
. Object
. HM.fromList
. fmap (\(k, v) -> (T.toLower . T.pack $ k, String . T.pack $ v))
-- | Tries to read `/etc/os-release` and `/usr/lib/os_release` in order.
-- Throws an exception if both files do not exist.
readOsRelease :: IO String
readOsRelease = do
let os_release1 :: Path Abs
os_release1 = [abs|/etc/os-release|]
let os_release2 :: Path Abs
os_release2 = [abs|/usr/lib/os-release|]
bs <- readFile os_release1 <|> readFile os_release2
-- os-release is utf8
pure . UTF8.toString $ bs
-- | Tries to read `/etc/os-release` and `/usr/lib/os_release` in order
-- and parses into `OsRelease`. Throws an exception if both files do not
-- exist.
parseOsRelease :: IO OsRelease
parseOsRelease = fmap (osRelease . allAssignments) readOsRelease
deriveJSON defaultOptions ''OsRelease
because
yac@linux-1e2q % cabal upload dist/os-release-0.2.2.tar.gz
Uploading dist/os-release-0.2.2.tar.gz...
Error: dist/os-release-0.2.2.tar.gz: 400 Bad Request
Error: Invalid package
'ghc-options: -Wall -Werror' makes the package very easy to break with future
GHC versions because new GHC versions often add new warnings. Use just
'ghc-options: -Wall' instead. If you want to use this, make it conditional
based on a flag (with 'manual: True' and 'default: False') and enable that
flag during development.
A declarative, efficient, and flexible JavaScript library for building user interfaces.
๐ Vue.js is a progressive, incrementally-adoptable JavaScript framework for building UI on the web.
TypeScript is a superset of JavaScript that compiles to clean JavaScript output.
An Open Source Machine Learning Framework for Everyone
The Web framework for perfectionists with deadlines.
A PHP framework for web artisans
Bring data to life with SVG, Canvas and HTML. ๐๐๐
JavaScript (JS) is a lightweight interpreted programming language with first-class functions.
Some thing interesting about web. New door for the world.
A server is a program made to process requests and deliver data to clients.
Machine learning is a way of modeling and interpreting data that allows a piece of software to respond intelligently.
Some thing interesting about visualization, use data art
Some thing interesting about game, make everyone happy.
We are working to build community through open source technology. NB: members must have two-factor auth.
Open source projects and samples from Microsoft.
Google โค๏ธ Open Source for everyone.
Alibaba Open Source for everyone
Data-Driven Documents codes.
China tencent open source team.