From d70f1df87682bce27c1cb03a639983cb9c5c4ee1 Mon Sep 17 00:00:00 2001 From: Malo Bourgon Date: Wed, 27 Jan 2021 18:22:20 -0800 Subject: [PATCH] Add keys command, and refactor with Relude --- README.md | 9 ++--- app/Main.hs | 29 +++++++++------- flake.nix | 2 ++ package.yaml | 25 ++++++++------ prefmanager.cabal | 33 +++++------------- prefmanager.nix | 20 ++++------- src/Defaults.hs | 77 ++++++++++++++++++++++++------------------ src/Defaults/Pretty.hs | 63 ++++++++++++++++------------------ src/Defaults/Types.hs | 6 ++-- src/Prelude.hs | 3 ++ stack.yaml | 3 ++ stack.yaml.lock | 7 ++++ 12 files changed, 141 insertions(+), 136 deletions(-) create mode 100644 src/Prelude.hs diff --git a/README.md b/README.md index c3c0061..73139dc 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # macOS Preferences Manager -This project is a WIP, currently only watching functionality has been implemented. +This project is a WIP. ## Usage @@ -9,7 +9,7 @@ Currently available commands: ``` > prefmanager --help -macOS Preferences Manager - a utility for working with macOS preferences +macOS Preferences Manager - a utility for working with macOS preferences. Usage: prefmanager COMMAND @@ -17,8 +17,9 @@ Available options: -h,--help Show this help text Available commands: - watch Watch domain(s) for changes - domains List all domains + watch Watch domain(s) for changes. + domains List all domains. + keys List the current keys in a domain. ``` Watch functionality: diff --git a/app/Main.hs b/app/Main.hs index 97e86d1..43f9c75 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -4,11 +4,6 @@ module Main where import Defaults import Defaults.Types (DomainName(..)) -import Control.Monad (join) -import Data.Coerce (coerce) -import Data.Foldable (traverse_) -import qualified Data.Set as S -import qualified Data.Text as T import Options.Applicative -- | Main @@ -19,31 +14,39 @@ main = join $ execParser opts opts :: ParserInfo (IO ()) opts = info (commands <**> helper) - (fullDesc <> header "macOS Preferences Manager - a utility for working with macOS preferences") + (fullDesc <> header "macOS Preferences Manager - a utility for working with macOS preferences.") -- | App CLI commands commands :: Parser (IO ()) commands = hsubparser ( command "watch" (info - ( watch . S.fromList <$> some + ( watch . fromList <$> some (DomainName <$> strArgument ( metavar "DOMAIN..." - <> completer (listIOCompleter $ fmap (T.unpack . coerce) . S.toList <$> domains) - <> help "Domain(s) that will be watched" + <> help "Domain(s) that will be watched." ) ) <|> flag' (watch =<< domains) ( long "all" <> short 'a' - <> help "Watch all domains including NSGlobalDomain" + <> help "Watch all domains including NSGlobalDomain." ) ) - $ progDesc "Watch domain(s) for changes" + $ progDesc "Watch domain(s) for changes." ) <> command "domains" (info - (pure $ domains >>= traverse_ (putStrLn . T.unpack . coerce) . S.toList) - (progDesc "List all domains") + (pure printDomains) + (progDesc "List all domains.") + ) + <> command "keys" + (info + (printKeys . DomainName <$> strArgument + ( metavar "DOMAIN" + <> help "A domain for which to list keys." + ) + ) + $ progDesc "List the current keys in a domain." ) ) diff --git a/flake.nix b/flake.nix index a9ef210..2d6662c 100644 --- a/flake.nix +++ b/flake.nix @@ -32,8 +32,10 @@ packages = [ compiler.haskell-language-server compiler.implicit-hie + compiler.weeder pkgs.cabal2nix pkgs.stack + pkgs.hlint ]; commands = [ { diff --git a/package.yaml b/package.yaml index e452d14..8917b97 100644 --- a/package.yaml +++ b/package.yaml @@ -14,20 +14,22 @@ extra-source-files: description: Please see the README on GitHub at dependencies: -- base >= 4.7 && < 5 -- async -- containers -- hxt -- optparse-applicative -- patience -- plist -- prettyprinter -- prettyprinter-ansi-terminal -- process -- text +- base-noprelude library: source-dirs: src + dependencies: + - relude + - ansi-terminal + - async + - containers + - hxt + - patience + - plist + - prettyprinter + - prettyprinter-ansi-terminal + - process + - text executables: prefmanager: @@ -39,6 +41,7 @@ executables: - -with-rtsopts=-N dependencies: - prefmanager + - optparse-applicative tests: prefmanager-test: diff --git a/prefmanager.cabal b/prefmanager.cabal index d74a6e3..478cbc1 100644 --- a/prefmanager.cabal +++ b/prefmanager.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: e47b42f89876fbc6a9f6ac24c1b66d161577d67abc0267f021a78a23c1ca8389 +-- hash: 1a8cff5464ff5ded24a399492c6be76412d42e1e21780bb40565735f140afab2 name: prefmanager version: 0.1.0.0 @@ -31,21 +31,23 @@ library Defaults Defaults.Pretty Defaults.Types + Prelude other-modules: Paths_prefmanager hs-source-dirs: src build-depends: - async - , base >=4.7 && <5 + ansi-terminal + , async + , base-noprelude , containers , hxt - , optparse-applicative , patience , plist , prettyprinter , prettyprinter-ansi-terminal , process + , relude , text default-language: Haskell2010 @@ -57,18 +59,9 @@ executable prefmanager app ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - async - , base >=4.7 && <5 - , containers - , hxt + base-noprelude , optparse-applicative - , patience - , plist , prefmanager - , prettyprinter - , prettyprinter-ansi-terminal - , process - , text default-language: Haskell2010 test-suite prefmanager-test @@ -80,16 +73,6 @@ test-suite prefmanager-test test ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - async - , base >=4.7 && <5 - , containers - , hxt - , optparse-applicative - , patience - , plist + base-noprelude , prefmanager - , prettyprinter - , prettyprinter-ansi-terminal - , process - , text default-language: Haskell2010 diff --git a/prefmanager.nix b/prefmanager.nix index 752a5f9..9d65665 100644 --- a/prefmanager.nix +++ b/prefmanager.nix @@ -1,6 +1,6 @@ -{ mkDerivation, async, base, containers, hpack, hxt -, optparse-applicative, patience, plist, prettyprinter -, prettyprinter-ansi-terminal, process, stdenv, text +{ mkDerivation, ansi-terminal, async, base-noprelude, containers +, hpack, hxt, optparse-applicative, patience, plist, prettyprinter +, prettyprinter-ansi-terminal, process, relude, stdenv, text }: mkDerivation { pname = "prefmanager"; @@ -9,18 +9,12 @@ mkDerivation { isLibrary = true; isExecutable = true; libraryHaskellDepends = [ - async base containers hxt optparse-applicative patience plist - prettyprinter prettyprinter-ansi-terminal process text + ansi-terminal async base-noprelude containers hxt patience plist + prettyprinter prettyprinter-ansi-terminal process relude text ]; libraryToolDepends = [ hpack ]; - executableHaskellDepends = [ - async base containers hxt optparse-applicative patience plist - prettyprinter prettyprinter-ansi-terminal process text - ]; - testHaskellDepends = [ - async base containers hxt optparse-applicative patience plist - prettyprinter prettyprinter-ansi-terminal process text - ]; + executableHaskellDepends = [ base-noprelude optparse-applicative ]; + testHaskellDepends = [ base-noprelude ]; prePatch = "hpack"; homepage = "https://github.com/malob/prefmanager#readme"; description = "A CLI utility for managing macOS preferences"; diff --git a/src/Defaults.hs b/src/Defaults.hs index d8b125d..40dc308 100644 --- a/src/Defaults.hs +++ b/src/Defaults.hs @@ -1,70 +1,81 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} module Defaults where import Defaults.Pretty (prettyDomainDiffs) -import Defaults.Types (DomainDiff(..), Domains, Domain, DomainName(..)) +import Defaults.Types (DomainDiff(..), Domains(..), Domain(..), DomainName(..), Key) + +import Relude.Extra (un, wrap, traverseToSnd, keys) import Control.Concurrent.Async (mapConcurrently) -import Data.Coerce (coerce) import Data.List (delete) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe (fromJust) -import Data.Set (Set) -import qualified Data.Set as S -import Data.Text (Text) -import qualified Data.Text as T -import Patience.Map +import qualified Data.Map.Strict as M +import Data.Text (stripEnd, splitOn) +import Patience.Map (diff, isSame, toDelta) import Prettyprinter.Render.Terminal (putDoc) -import System.IO (hFlush, stdout) +import System.Console.ANSI (clearLine, setCursorColumn) +import System.IO (hFlush) import System.Process (shell, readCreateProcess) import Text.XML.HXT.Core (no, withSubstDTDEntities, withValidate) import Text.XML.Plist (PlObject, fromPlDict, readPlistFromString) -- | Convenience function for running macOS @defaults@ command. defaultsCmd :: Text -> IO Text -defaultsCmd (T.unpack -> s) = T.pack <$> readCreateProcess (shell $ "defaults " <> s) "" +defaultsCmd (toString -> t) = toText <$> readCreateProcess (shell $ "/usr/bin/defaults " <> t) "" -- | Convenience function for parsing Plist strings parsePlist :: Text -> IO PlObject -parsePlist = readPlistFromString [withValidate no, withSubstDTDEntities no] . T.unpack +parsePlist = readPlistFromString [withValidate no, withSubstDTDEntities no] . toString -- | Gets list of domains by running @defaults domains@ and adds @NSGlobalDomain@ to the 'Set'. domains :: IO (Set DomainName) domains - = S.fromList - . coerce + = fromList + . wrap . ("NSGlobalDomain" :) - . T.splitOn ", " - . T.stripEnd + . splitOn ", " + . stripEnd <$> defaultsCmd "domains" -- | Runs @defaults export [domain] -@ and parses the output. export :: DomainName -> IO Domain -export (coerce -> d) - = coerce - . M.fromList - . fromJust +export d + = wrap + . fromList @(Map _ _) + . maybeToMonoid . fromPlDict - <$> (defaultsCmd ("export '" <> d <> "' -") >>= parsePlist) + <$> (defaultsCmd ("export '" <> un d <> "' -") >>= parsePlist) -- | Runs 'export' on the 'Set' of provided domains exports :: Set DomainName -> IO Domains -exports = (M.fromList <$>) . mapConcurrently (\d -> (d,) <$> export d) . S.toList +exports = wrap . fmap (fromList @(Map _ _)) . mapConcurrently (traverseToSnd export) . toList diffDomain :: Domain -> Domain -> DomainDiff -diffDomain old new = coerce $ M.filter (not . isSame) $ diff old new +diffDomain (Domain old) (Domain new) = wrap $ M.filter (not . isSame) $ diff old new -- | Watches a 'Set' of domains and prints any changes. watch :: Set DomainName -> IO () -watch ds = exports ds >>= (putStrLn "Watching..." >>) . go where - go :: Domains -> IO () - go old = do +watch ds = exports ds >>= (putStrLn "Watching..." *>) . go 0 where + go :: Int -> Domains -> IO () + go count old = do + putText "Processing domains" + if count > 0 then putText $ " (" <> show count <> " loops with no changes)" else pass + hFlush stdout new <- exports ds - let domainDiffs = uncurry diffDomain <$> toDelta (diff old new) - (if null domainDiffs then pure () else putDoc $ prettyDomainDiffs domainDiffs) - *> hFlush stdout - *> go new + let domainDiffs = uncurry diffDomain <$> toDelta (diff (un old) (un new)) + clearLine + setCursorColumn 0 + if null domainDiffs + then go (count + 1) new + else do + putDoc $ prettyDomainDiffs domainDiffs + go 0 new + +-- | Print the keys of a given domain +printKeys :: DomainName -> IO () +printKeys = traverse_ putStrLn . keys @(Map _ PlObject) . un <=< export + +-- | Print the list of available domains +printDomains :: IO () +printDomains = traverse_ (putTextLn . un) =<< domains diff --git a/src/Defaults/Pretty.hs b/src/Defaults/Pretty.hs index a36571d..1ccbff1 100644 --- a/src/Defaults/Pretty.hs +++ b/src/Defaults/Pretty.hs @@ -4,50 +4,47 @@ module Defaults.Pretty where import Defaults.Types (DomainDiff(..), DomainName(..), Key) -import Data.Bool (bool) -import Data.Coerce (coerce) -import Data.Map (Map, foldrWithKey) +import Prelude hiding (group) +import Relude.Extra (un) + +import Data.Map.Strict (foldMapWithKey) import Patience.Map (Delta(..)) import Prettyprinter import Prettyprinter.Render.Terminal import Text.XML.Plist (PlObject(..)) prettyDomainDiffs :: Map DomainName DomainDiff -> Doc AnsiStyle -prettyDomainDiffs = foldrWithKey go emptyDoc where - go :: DomainName -> DomainDiff -> Doc AnsiStyle -> Doc AnsiStyle - go (DomainName name) diff doc - = doc +prettyDomainDiffs = foldMapWithKey go where + go :: DomainName -> DomainDiff -> Doc AnsiStyle + go (DomainName name) diff + = annotate (bold <> italicized) (pretty name) <> hardline <> hardline - <> annotate (bold <> italicized) (pretty name) - <> hardline <> indent 2 (prettyDomainDiff diff) + <> hardline prettyDomainDiff :: DomainDiff -> Doc AnsiStyle -prettyDomainDiff = foldrWithKey go emptyDoc . coerce where - go :: Key -> Delta PlObject -> Doc AnsiStyle -> Doc AnsiStyle - go key delta doc - = doc - <> hardline - <> case delta of - Delta old new - -> pretty key <+> "(Value changed)" - <> hardline - <> indent 2 (red (pretty old) <> hardline <> green (pretty new)) - New x - -> green - $ pretty key <+> "(Key added)" - <> hardline - <> indent 2 (pretty x) - Old x - -> red - $ pretty key <+> "(Key removed)" - <> hardline - <> indent 2 (pretty x) - Same x - -> pretty key <+> "(No change)" - <> hardline - <> indent 2 (pretty x) +prettyDomainDiff = foldMapWithKey go . un where + go :: Key -> Delta PlObject -> Doc AnsiStyle + go key = (<> hardline <> hardline) . \case + Delta old new + -> pretty key <+> "(Value changed)" + <> hardline + <> indent 2 (red (pretty old) <> hardline <> green (pretty new)) + New x + -> green + $ pretty key <+> "(Key added)" + <> hardline + <> indent 2 (pretty x) + Old x + -> red + $ pretty key <+> "(Key removed)" + <> hardline + <> indent 2 (pretty x) + Same x + -> pretty key <+> "(No change)" + <> hardline + <> indent 2 (pretty x) red = annotate $ colorDull Red green = annotate $ colorDull Green diff --git a/src/Defaults/Types.hs b/src/Defaults/Types.hs index 77a72d2..b74cb3d 100644 --- a/src/Defaults/Types.hs +++ b/src/Defaults/Types.hs @@ -1,7 +1,5 @@ module Defaults.Types where -import Data.Map (Map) -import Data.Text (Text) import Patience.Map (Delta) import Text.XML.Plist (PlObject) @@ -11,10 +9,10 @@ newtype DomainName = DomainName Text deriving (Eq, Ord, Show) type Key = String -- | Representation of the settings of a domain. -type Domain = Map Key PlObject +newtype Domain = Domain (Map Key PlObject) deriving (Eq, Ord, Show) -- | Map of domains. -type Domains = Map DomainName Domain +newtype Domains = Domains (Map DomainName Domain) deriving (Eq, Ord, Show) -- | Map representing the change of the values of keys of a domain. newtype DomainDiff = DomainDiff (Map Key (Delta PlObject)) deriving (Eq, Ord, Show) diff --git a/src/Prelude.hs b/src/Prelude.hs new file mode 100644 index 0000000..3137519 --- /dev/null +++ b/src/Prelude.hs @@ -0,0 +1,3 @@ +module Prelude (module Relude) where + +import Relude diff --git a/stack.yaml b/stack.yaml index 5f93096..85b003d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -6,9 +6,12 @@ packages: extra-deps: - patience-0.3 +- base-noprelude-4.13.0.0 # Use fork of plist package that supports MonadFail - github: malob/plist commit: 5e22be0933bf9a100868b944fa7a8b1236b99255 +allow-newer: true + nix: shell-file: ./stack.nix diff --git a/stack.yaml.lock b/stack.yaml.lock index 443f943..d3176ce 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -11,6 +11,13 @@ packages: sha256: d2ca47451a599605c641b7c353588d7e1ba3d6036c8a52040b7d1b5b1af8959b original: hackage: patience-0.3 +- completed: + hackage: base-noprelude-4.13.0.0@sha256:3cccbfda38e1422ca5cc436d58858ba51ff9114d2ed87915a6569be11e4e5a90,6842 + pantry-tree: + size: 112 + sha256: 90db92c8401880187ce642c5345407bcbd9546ea235524dd445cab2566ee3db1 + original: + hackage: base-noprelude-4.13.0.0 - completed: size: 4351 url: https://github.com/malob/plist/archive/5e22be0933bf9a100868b944fa7a8b1236b99255.tar.gz