{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeOperators #-}
module System.OsRelease
(
OsReleaseResult(..)
, OsRelease(..)
, parseOsRelease
, readOsRelease
, defaultOsRelease
, defaultAssignments
, parseAssignments
, parseAssignment
, getAllAssignments
, getOsRelease
, parseOsRelease'
)
where
import System.OsRelease.Megaparsec
import Control.Applicative
import Control.Monad
import Control.Exception.Safe
import Data.Aeson
import Data.Aeson.TH
import Data.Char
import Data.Either
import Data.List
import Data.Maybe
import Data.Void
import GHC.Generics
import Prelude hiding ( id
)
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import qualified Text.Megaparsec as MP
data OsReleaseResult = OsReleaseResult {
osRelease :: !OsRelease
, unknown_fields :: [(String, String)]
, parse_errors :: [MP.ParseError String Void]
} deriving (Show)
data OsRelease = OsRelease {
name :: !(String)
, version :: !(Maybe String)
, id :: !(String)
, id_like :: !(Maybe String)
, version_codename :: !(Maybe String)
, version_id :: !(Maybe String)
, pretty_name :: !(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 (Generic, Show)
class GetRecords a where
getRecords :: a -> [String]
instance {-# OVERLAPPABLE #-} GetRecords (f p) => GetRecords (M1 i c f p) where
getRecords (M1 x) = getRecords x
instance {-# OVERLAPPING #-} Selector c => GetRecords (M1 S c f p) where
getRecords x = [selName x]
instance (GetRecords (a p), GetRecords (b p)) => GetRecords ((a :*: b) p) where
getRecords (a :*: b) = getRecords a ++ getRecords b
defaultOsRelease :: OsRelease
defaultOsRelease = OsRelease { name = "Linux"
, version = Nothing
, id = "linux"
, id_like = Nothing
, version_codename = Nothing
, version_id = Nothing
, pretty_name = "Linux"
, 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
}
defaultAssignments :: [(String, String)]
defaultAssignments =
[("NAME", "Linux"), ("ID", "linux"), ("PRETTY_NAME", "Linux")]
getAllAssignments :: String
-> [Either (MP.ParseError String Void) (String, String)]
getAllAssignments = either (const []) (\x -> x) . MP.parse parseAssignments "os-release"
getOsRelease :: [(String, String)]
-> OsRelease
getOsRelease =
(\case
Error _ -> defaultOsRelease
Success v -> v
)
. fromJSON
. Object
. (\x -> HM.union x (HM.fromList . aesonify $ defaultAssignments))
. HM.fromList
. aesonify
where
aesonify = fmap (\(k, v) -> (T.toLower . T.pack $ k, String . T.pack $ v))
readOsRelease :: IO String
readOsRelease = readFile "/etc/os-release" <|> readFile "/usr/lib/os-release"
parseOsRelease :: IO (Maybe OsReleaseResult)
parseOsRelease =
handleIO (\_ -> pure Nothing) . fmap (Just . parseOsRelease') $ readOsRelease
parseOsRelease' :: String -> OsReleaseResult
parseOsRelease' s =
let (errs, ass) = partitionEithers . getAllAssignments $ s
osr = getOsRelease ass
unknown_fields' =
HM.toList
. foldr (\x y -> HM.delete (fmap toUpper x) y) (HM.fromList ass)
$ (init . getRecords . from $ defaultOsRelease)
in OsReleaseResult osr unknown_fields' errs
deriveJSON defaultOptions ''OsRelease