bm (empty) → 0.1.0.2
raw patch · 10 files changed
+1465/−0 lines, 10 filesdep +aesondep +ansi-wl-pprintdep +basesetup-changed
Dependencies added: aeson, ansi-wl-pprint, base, bm, directory, dlist, filepath, network-uri, optparse-applicative, scientific, tasty, tasty-hunit, text, transformers, typed-process, vector, yaml
Files
- CHANGELOG.md +44/−0
- LICENSE +21/−0
- README.md +152/−0
- Setup.hs +2/−0
- app/LibOA.hs +141/−0
- app/Main.hs +301/−0
- bm.cabal +92/−0
- src/BM.hs +396/−0
- test/BM/Test.hs +302/−0
- test/Spec.hs +14/−0
+ CHANGELOG.md view
@@ -0,0 +1,44 @@+# `bm-haskell` Changelog++This project follows the [Haskell package versioning policy][PVP], with+versions in `A.B.C.D` format. `A` may be incremented arbitrarily for+non-technical reasons, but [semantic versioning][SemVer] is otherwise+followed, where `A.B` is the major version, `C` is the minor version, and `D`+is the patch version. Initial development uses versions `0.0.0.D`, for which+every version is considered breaking.++[PVP]: <https://pvp.haskell.org/>+[SemVer]: <https://semver.org/>++The format of this changelog is based on [Keep a Changelog][KaC], with the+following conventions:++* Level-two heading `Unreleased` is used to track changes that have not been+ released.+* Other level-two headings specify the release in `A.B.C.D (YYYY-MM-DD)`+ format, with newer versions above older versions.+* Level-three headings are used to categorize changes as follows:+ 1. Breaking+ 2. Non-Breaking+* Changes are listed in arbitrary order and present tense.++[KaC]: <https://keepachangelog.com/en/1.0.0/>++## 0.1.0.2 (2022-03-02)++### Non-Breaking++* Bump `text` dependency version upper bound+* Bump `optparse-applicative` dependency version upper bound++## 0.1.0.1 (2021-10-10)++### Non-Breaking++* Add dependency bounds++## 0.1.0.0 (2021-07-02)++### Breaking++* Initial release
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License++Copyright (c) 2021-2022 Travis Cardwell++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,152 @@+# bm++[](https://www.repostatus.org/#active)+[](https://github.com/ExtremaIS/bm-haskell/actions)+[](https://hackage.haskell.org/package/bm)+[](https://stackage.org/package/bm)+[](https://stackage.org/nightly/package/bm)++* [Overview](#overview)+* [CLI](#cli)+ * [Requirements](#requirements)+ * [Installation](#installation)+ * [`.deb` Package Installation](#deb-package-installation)+ * [`.rpm` Package Installation](#rpm-package-installation)+ * [Installation From Hackage](#installation-from-hackage)+ * [Installation From Stackage](#installation-from-stackage)+ * [Usage](#usage)+ * [Examples](#examples)+* [Project](#project)+ * [Links](#links)+ * [Tags](#tags)+ * [Contribution](#contribution)+ * [License](#license)++## Overview++`bm` is a utility for opening bookmarks and queries from the command line.+The bookmarks and queries are configured hierarchically in YAML, and they are+referenced using keyword prefixes. It allows you to quickly open bookmarks+and perform search queries in your browser using only your keyboard.++## CLI++### Requirements++`bm` is designed to work on any operating system, but it has only been tested+on Linux.++### Installation++#### `.deb` Package Installation++Check the [Releases][] page for `.deb` packages.++[Releases]: <https://github.com/ExtremaIS/bm-haskell/releases>++#### `.rpm` Package Installation++Check the [Releases][] page for `.rpm` packages.++#### Installation From Hackage++Install `bm` from [Hackage][] using [Cabal][] as follows:++```+$ cabal v2-install bm+```++[Hackage]: <https://hackage.haskell.org/package/bm>+[Cabal]: <https://www.haskell.org/cabal/>++#### Installation From Stackage++Install `bm` from [Stackage][] using [Stack][] as follows:++```+$ stack install bm+```++[Stackage]: <https://www.stackage.org/package/bm>+[Stack]: <https://haskellstack.org/>++### Usage++Bookmarks and search queries are configured using a hierarchy of keywords in a+YAML configuration file. They are selected using keyword prefixes as+command-line arguments. Command-line completion is available for Bash. See+the [`bm` man page](doc/bm.1.md) for details.++Note that the command used to open bookmarks and queries can be customized in+the configuration file. Specifying the command for your specific browser can+make links open considerably faster than with the default (generic) command.++#### Examples++An example configuration file is available in the `config` directory on+GitHub (example for the latest release: [bm.yaml][]). The following are+example commands using this configuration file.++Open a bookmark link by specifying keywords. The Nix homepage can be opened+with the following command:++```+$ bm nix+```++The `nixpkgs` manual can be opened using the following command:++```+$ bm nix pkgs manual+```++Keyword prefixes can also be used. The following command also opens the+`nixpkgs` manual:++```+$ bm n p m+```++When more than one keyword has the same prefix, the first is selected. If a+selected bookmark does not specify a URL, the first child is processed.++The `/` keyword defines a bookmark with a URL as well as a query. When no+query is specified, the URL is opened, allowing you to search with suggestions+using the search field. Open a query by specifying keywords followed by the+query.++```+$ bm / LinearTypes+```++When multiple query arguments are provided, they are joined with a space.++[bm.yaml]: <https://github.com/ExtremaIS/bm-haskell/blob/main/config/bm.yaml>++## Project++### Links++* Hackage: <https://hackage.haskell.org/package/bm>+* Stackage: <https://www.stackage.org/package/bm>+* GitHub: <https://github.com/ExtremaIS/bm-haskell>+* GitHub Actions CI: <https://github.com/ExtremaIS/bm-haskell/actions>++### Tags++All releases are tagged in the `main` branch. Release tags are signed using+the+[`security@extrema.is` GPG key](http://keys.gnupg.net/pks/lookup?op=vindex&fingerprint=on&search=0x1D484E4B4705FADF).++### Contribution++Issues and feature requests are tracked on GitHub:+<https://github.com/ExtremaIS/bm-haskell/issues>++Issues may also be submitted via email to <bugs@extrema.is>.++### License++This project is released under the+[MIT License](https://opensource.org/licenses/MIT) as specified in the+[`LICENSE`](LICENSE) file.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/LibOA.hs view
@@ -0,0 +1,141 @@+------------------------------------------------------------------------------+-- |+-- Module : LibOA+-- Description : supplementary functions for optparse-applicative+-- Copyright : Copyright (c) 2019-2022 Travis Cardwell+-- License : MIT+--+-- This is a collection of functions that I often use with+-- @optparse-applicative@. I do not feel that it is worth maintaining yet+-- another helper package on Hackage, so I just copy the code to different+-- projects as required. If the library grows to a substantial size or others+-- with to use it, I will reconsider.+--+-- Revision: 2022-01-02+------------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-}++module LibOA+ ( -- * Options+ -- $Options+ helper+ , versioner+ -- * Utilities+ , commands+ -- * Help+ , (<||>)+ , section+ , table+ , table_+ , vspace+ ) where++-- https://hackage.haskell.org/package/ansi-wl-pprint+import qualified Text.PrettyPrint.ANSI.Leijen as Doc+import Text.PrettyPrint.ANSI.Leijen (Doc)++-- https://hackage.haskell.org/package/base+import Data.List (intersperse, transpose)+import Data.Maybe (fromMaybe)+#if !MIN_VERSION_base (4,11,0)+import Data.Monoid ((<>))+#endif++-- https://hackage.haskell.org/package/optparse-applicative+import qualified Options.Applicative as OA+#if MIN_VERSION_optparse_applicative (0,16,0)+import qualified Options.Applicative.Builder.Internal as OABI+#endif+import qualified Options.Applicative.Common as OAC+import qualified Options.Applicative.Types as OAT++------------------------------------------------------------------------------+-- $Options+--+-- Option descriptions are not capitalized.++-- | A hidden @-h@ / @--help@ option that always fails, showing the help+--+-- This is the same as 'OA.helper' except that it has a different help+-- message.+helper :: OA.Parser (a -> a)+#if MIN_VERSION_optparse_applicative (0,16,0)+helper = OA.option helpReader $ mconcat+ [ OA.short 'h'+ , OA.long "help"+ , OA.value id+ , OA.metavar ""+ , OABI.noGlobal+ , OA.noArgError (OA.ShowHelpText Nothing)+ , OA.help "show this help text"+ , OA.hidden+ ]+ where+ helpReader = do+ potentialCommand <- OAT.readerAsk+ OA.readerAbort $ OA.ShowHelpText (Just potentialCommand)+#else+helper = OA.abortOption OA.ShowHelpText $ mconcat+ [ OA.short 'h'+ , OA.long "help"+ , OA.help "show help and exit"+ , OA.hidden+ ]+#endif++-- | A hidden @--version@ option that always fails, showing the version+versioner+ :: String -- ^ version string+ -> OA.Parser (a -> a)+versioner verStr = OA.infoOption verStr $ mconcat+ [ OA.long "version"+ , OA.help "show version and exit"+ , OA.hidden+ ]++------------------------------------------------------------------------------+-- $Utilities++-- | Get a list of commands for a parser+commands :: OA.Parser a -> [String]+commands =+ let go _ opt = case OAT.optMain opt of+ OAT.CmdReader _ cmds _ -> reverse cmds+ _otherReader -> []+ in concat . OAC.mapParser go++------------------------------------------------------------------------------+-- $Help++-- | Insert a blank line between two documents+(<||>) :: Doc -> Doc -> Doc+d1 <||> d2 = d1 <> Doc.line <> Doc.line <> d2+infixr 5 <||>++-- | Create a section with a title and indented body+section :: String -> Doc -> Doc+section title = (Doc.text title Doc.<$$>) . Doc.indent 2++-- | Create a table, with formatting+table :: Int -> [[(String, Doc -> Doc)]] -> Doc+table sep rows = Doc.vcat $+ map (fromMaybe Doc.empty . foldr go Nothing . zip lengths) rows+ where+ lengths :: [Int]+ lengths = map ((+) sep . maximum . map (length . fst)) $ transpose rows++ go :: (Int, (String, Doc -> Doc)) -> Maybe Doc -> Maybe Doc+ go (len, (s, f)) = Just . \case+ Just doc -> Doc.fill len (f $ Doc.string s) <> doc+ Nothing -> f $ Doc.string s++-- | Create a table, without formatting+table_ :: Int -> [[String]] -> Doc+table_ sep = table sep . (map . map) (, id)++-- | Vertically space documents with blank lines between them+vspace :: [Doc] -> Doc+vspace = mconcat . intersperse (Doc.line <> Doc.line)
+ app/Main.hs view
@@ -0,0 +1,301 @@+------------------------------------------------------------------------------+-- |+-- Module : Main+-- Description : bm: open bookmarks and queries from the command line+-- Copyright : Copyright (c) 2021-2022 Travis Cardwell+-- License : MIT+--+-- See the README for details.+------------------------------------------------------------------------------++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}++module Main (main) where++-- https://hackage.haskell.org/package/base+import Control.Applicative (optional, some)+import Control.Monad (forM, unless, when)+import Data.List (find, isInfixOf, isPrefixOf, sort, uncons)+import Data.Maybe (catMaybes)+import System.Environment (getArgs)+import System.Exit (ExitCode(ExitFailure), exitSuccess, exitWith)+import System.IO (hPutStrLn, stderr)+import Text.Read (readMaybe)++-- https://hackage.haskell.org/package/directory+import qualified System.Directory as Dir++-- https://hackage.haskell.org/package/filepath+import qualified System.FilePath as FP+import System.FilePath ((</>))++-- https://hackage.haskell.org/package/optparse-applicative+import qualified Options.Applicative as OA+import qualified Options.Applicative.Types as OAT++-- https://hackage.haskell.org/package/typed-process+import qualified System.Process.Typed as TP++-- https://hackage.haskell.org/package/yaml+import qualified Data.Yaml as Yaml++-- (bm)+import qualified BM++-- (bm:executable)+import qualified LibOA++------------------------------------------------------------------------------+-- $Options++data Options+ = Options+ { configOpt :: !(Maybe FilePath)+ , traceOpt :: !Bool+ , args :: ![String]+ }+ deriving Show++configOption :: OA.Parser FilePath+configOption = OA.strOption $ mconcat+ [ OA.long "config"+ , OA.short 'c'+ , OA.metavar "CONFIG"+ , OA.help "config file (default: $XDG_CONFIG_HOME/bm.yaml)"+ ]++traceOption :: OA.Parser Bool+traceOption = OA.switch $ mconcat+ [ OA.long "trace"+ , OA.short 't'+ , OA.help "show trace output for debugging"+ ]++arguments :: OA.Parser [String]+arguments = some . OA.strArgument $ mconcat+ [ OA.metavar "ARG [ARG ...]"+ , OA.help "arguments"+ ]++options :: OA.Parser Options+options = Options+ <$> optional configOption+ <*> traceOption+ <*> arguments++------------------------------------------------------------------------------+-- $Completion++data CompletionOption+ = CompleteDefault+ | CompleteNoSpace++instance Show CompletionOption where+ show = \case+ CompleteDefault -> "DEFAULT"+ CompleteNoSpace -> "NOSPACE"++handleCompletion :: [String] -> IO (Either OA.ParseError [String])+handleCompletion args = case find isOAOption optArgs of+ Just arg ->+ return . Left $ OA.UnexpectedError arg (OAT.SomeParser options)+ Nothing+ | "--complete" `elem` optArgs -> handleComplete args+ | "--complete-bash" `elem` optArgs -> handleCompleteBash args+ | otherwise -> return $ Right args+ where+ optArgs :: [String]+ optArgs = takeWhile (/= "--") args++ isOAOption :: String -> Bool+ isOAOption =+ (&&) <$> ("--" `isPrefixOf`) <*> ("completion" `isInfixOf`)++handleComplete :: [String] -> IO a+handleComplete = \case+ "--complete" : idxArg : args -> do+ idx <- case readMaybe idxArg of+ Just n | n > 0 -> return n+ _invalidIdx -> errorExit $ "invalid index: " ++ idxArg+ goOpts Nothing [] (idx - 1) (drop 1 args)+ _invalidArgs -> do+ mapM_ (hPutStrLn stderr)+ [ "Usage: bm --complete INDEX [ARG ...]"+ , " get completion options"+ , ""+ , "Use one of the following commands to enable bm completion:"+ , " * bm --complete-bash"+ ]+ exitWith $ ExitFailure 2+ where+ longOpts, shortOpts :: [String]+ longOpts = ["--help", "--version", "--config", "--trace"]+ shortOpts = ["-h", "-c", "-t"]++ goOpts :: Maybe FilePath -> [String] -> Int -> [String] -> IO a+ goOpts mConfigPath bmArgsAcc 0 (arg:_args) = do+ when (arg `elem` ["-", "--"]) $ reply longOpts+ when (arg `elem` shortOpts) $ reply [arg]+ case find (isPrefixOf arg) longOpts of+ Just longOpt -> reply [longOpt]+ Nothing -> return ()+ when ("-" `isPrefixOf` arg) $ reply []+ goBM mConfigPath $ reverse (arg : bmArgsAcc)+ goOpts mConfigPath bmArgsAcc 0 [] =+ goBM mConfigPath $ reverse ("" : bmArgsAcc)+ goOpts mConfigPath bmArgsAcc idx (arg:args)+ | arg == "--" = goArgs mConfigPath bmArgsAcc (idx - 1) args+ | arg `elem` ["-c", "--config"] = case uncons args of+ Just (configPath, args')+ | idx == 1 -> goConfig =<< expandHomeDirectory configPath+ | otherwise -> goOpts (Just configPath) bmArgsAcc (idx -2) args'+ Nothing -> goConfig "./"+ | "-" `isPrefixOf` arg = goOpts mConfigPath bmArgsAcc (idx -1) args+ | otherwise = goOpts mConfigPath (arg : bmArgsAcc) (idx - 1) args+ goOpts _mConfigPath _bmArgsAcc _idx [] = reply []++ goArgs :: Maybe FilePath -> [String] -> Int -> [String] -> IO a+ goArgs mConfigPath bmArgsAcc 0 (arg:_args) =+ goBM mConfigPath $ reverse (arg : bmArgsAcc)+ goArgs mConfigPath bmArgsAcc 0 [] =+ goBM mConfigPath $ reverse ("" : bmArgsAcc)+ goArgs mConfigPath bmArgsAcc idx (arg:args) =+ goArgs mConfigPath (arg : bmArgsAcc) (idx - 1) args+ goArgs _mConfigPath _bmArgsAcc _idx [] = reply []++ expandHomeDirectory :: FilePath -> IO FilePath+ expandHomeDirectory arg = case uncons (FP.splitPath arg) of+ Just (part, parts)+ | part `elem` ["~", "~/"] -> do+ homeDir <- Dir.getHomeDirectory+ return . FP.joinPath $ homeDir : parts+ _otherwise -> return arg++ goConfig :: FilePath -> IO a+ goConfig arg = do+ isDir <- Dir.doesDirectoryExist arg+ when isDir $+ goConfigDir . map (arg </>) . sort =<< Dir.listDirectory arg+ when (FP.hasTrailingPathSeparator arg) $ reply []+ isFile <- Dir.doesFileExist arg+ when isFile $ reply [arg | ".yaml" `FP.isExtensionOf` arg]+ let (dir, partial) = FP.splitFileName arg+ isDirDir <- Dir.doesDirectoryExist dir+ unless isDirDir $ reply []+ goConfigDir . map (dir </>) . sort . filter (isPrefixOf partial)+ =<< Dir.listDirectory dir++ goConfigDir :: [FilePath] -> IO a+ goConfigDir paths = do+ dirOrFiles <- fmap catMaybes . forM paths $ \path -> do+ isDir <- Dir.doesDirectoryExist path+ return $ if isDir+ then Just . Left $ FP.addTrailingPathSeparator path+ else if ".yaml" `FP.isExtensionOf` path+ then Just $ Right path+ else Nothing+ case dirOrFiles of+ [Right path] -> reply [path]+ _otherwise -> do+ print CompleteNoSpace+ mapM_ (putStrLn . either id id) dirOrFiles+ exitSuccess++ goBM :: Maybe FilePath -> [String] -> IO a+ goBM mConfigPath args = do+ print CompleteDefault+ configPath <- case mConfigPath of+ Just path -> pure path+ Nothing -> Dir.getXdgDirectory Dir.XdgConfig "bm.yaml"+ exists <- Dir.doesFileExist configPath+ when exists $ do+ eec <- Yaml.decodeFileEither configPath+ case eec of+ Right config -> mapM_ putStrLn $ BM.getCompletion config args+ Left{} -> return ()+ exitSuccess++ reply :: [String] -> IO a+ reply choices = do+ print CompleteDefault+ mapM_ putStrLn choices+ exitSuccess++handleCompleteBash :: [String] -> IO a+handleCompleteBash = \case+ ["--complete-bash", path] | not ("-" `isPrefixOf` path) -> do+ mapM_ putStrLn+ [ "_bm() {"+ , "mapfile -t COMPREPLY < <(\"" ++ path +++ "\" --complete ${COMP_CWORD} ${COMP_WORDS[@]})"+ , "test \"${COMPREPLY[0]}\" != \"" ++ show CompleteNoSpace +++ "\" || compopt -o nospace"+ , "unset \"COMPREPLY[0]\""+ , "}"+ , ""+ , "complete -F _bm bm"+ ]+ exitSuccess+ _invalidArgs -> do+ mapM_ (hPutStrLn stderr)+ [ "Usage: bm --complete-bash PATH"+ , " print a Bash script to enable bm completion"+ , ""+ , "Example usage:"+ , ""+ , " $ source <(bm --complete-bash `which bm`)"+ ]+ exitWith $ ExitFailure 2++parseArgs :: IO Options+parseArgs = do+ eeas <- handleCompletion =<< getArgs+ OA.handleParseResult $ case eeas of+ Right args -> OA.execParserPure OA.defaultPrefs pinfo args+ Left parseError ->+ OA.Failure $ OA.parserFailure OA.defaultPrefs pinfo parseError mempty+ where+ pinfo :: OA.ParserInfo Options+ pinfo+ = OA.info (LibOA.helper <*> LibOA.versioner BM.version <*> options)+ $ mconcat+ [ OA.fullDesc+ , OA.progDesc "open bookmarks and queries from the command line"+ , OA.failureCode 2+ ]++------------------------------------------------------------------------------+-- $Main++errorExit :: String -> IO a+errorExit message = do+ hPutStrLn stderr $ "error: " ++ message+ exitWith $ ExitFailure 1++runProc :: BM.Proc -> IO ()+runProc proc+ = TP.runProcess_+ . TP.setStdin TP.nullStream+ . TP.setStdout TP.nullStream+ . TP.setStderr TP.nullStream+ $ TP.proc (BM.command proc) (BM.arguments proc)++main :: IO ()+main = do+ Options{..} <- parseArgs+ configPath <- case configOpt of+ Just path -> pure path+ Nothing -> Dir.getXdgDirectory Dir.XdgConfig "bm.yaml"+ exists <- Dir.doesFileExist configPath+ unless exists . errorExit $ "configuration file not found: " ++ configPath+ eec <- Yaml.decodeFileEither configPath+ case eec of+ Right config -> do+ let (eep, traceLines) = BM.run config args+ when traceOpt $ mapM_ (hPutStrLn stderr) traceLines+ either errorExit runProc eep+ Left parseException -> do+ hPutStrLn stderr $ "error parsing config file: " ++ configPath+ hPutStrLn stderr $ Yaml.prettyPrintParseException parseException+ exitWith $ ExitFailure 1
+ bm.cabal view
@@ -0,0 +1,92 @@+name: bm+version: 0.1.0.2+category: Utils+synopsis: open bookmarks and queries from the command line+description:+ This package provides a command-line utility that opens bookmarks and+ queries. Please see the README on GitHub at+ <https://github.com/ExtremaIS/bm-haskell#readme>.++homepage: https://github.com/ExtremaIS/bm-haskell#readme+bug-reports: https://github.com/ExtremaIS/bm-haskell/issues+author: Travis Cardwell <travis.cardwell@extrema.is>+maintainer: Travis Cardwell <travis.cardwell@extrema.is>+copyright: Copyright (c) 2021-2022 Travis Cardwell+license: MIT+license-file: LICENSE++cabal-version: 1.24+build-type: Simple+tested-with:+ GHC ==8.6.5+ || ==8.8.4+ || ==8.10.7+ || ==9.0.2+ || ==9.2.1++extra-source-files:+ CHANGELOG.md+ README.md++source-repository head+ type: git+ location: https://github.com/ExtremaIS/bm-haskell.git++flag write-hie+ description: write .hie files+ default: False++library+ hs-source-dirs: src+ exposed-modules:+ BM+ other-modules:+ Paths_bm+ build-depends:+ aeson >=1.4 && < 2.1+ , base >=4.7 && <5+ , dlist >=0.8 && <1.1+ , network-uri >=2.6 && <2.7+ , scientific >=0.3 && <0.4+ , text >=1.2.3 && <2.1+ , transformers >=0.5.6 && <0.6+ , vector >=0.12 && <0.13+ default-language: Haskell2010+ default-extensions:+ OverloadedStrings+ if flag(write-hie)+ ghc-options: -Wall -fwrite-ide-info -hiedir=.hie+ else+ ghc-options: -Wall++executable bm+ hs-source-dirs: app+ main-is: Main.hs+ other-modules:+ LibOA+ build-depends:+ ansi-wl-pprint >=0.6 && <0.7+ , base+ , bm+ , directory >=1.3 && <1.4+ , filepath >=1.4 && <1.5+ , optparse-applicative >=0.14 && <0.18+ , typed-process >=0.2.6 && <0.3+ , yaml >=0.11 && <0.12+ default-language: Haskell2010+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N++test-suite bm-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules:+ BM.Test+ build-depends:+ base+ , bm+ , tasty >=1.0 && <1.5+ , tasty-hunit >=0.10 && <0.11+ , vector+ default-language: Haskell2010+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
+ src/BM.hs view
@@ -0,0 +1,396 @@+------------------------------------------------------------------------------+-- |+-- Module : BM+-- Description : API+-- Copyright : Copyright (c) 2021-2022 Travis Cardwell+-- License : MIT+------------------------------------------------------------------------------++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}++module BM+ ( -- * Constants+ version+ -- * Types+ , Argument+ , Command+ , Error+ , Keyword+ , ParameterName+ , ParameterValue+ , Trace+ , Url+ , Config(..)+ , Bookmark(..)+ , Query(..)+ , Parameter(..)+ , Proc(..)+ -- * API+ , run+ , getCompletion+ ) where++-- https://hackage.haskell.org/package/aeson+import qualified Data.Aeson as A+import Data.Aeson (FromJSON, (.:), (.:?), (.!=))+import qualified Data.Aeson.Types as AT++-- https://hackage.haskell.org/package/base+import Data.List (intercalate, isPrefixOf)+import Data.Maybe (fromMaybe)+import Data.Version (showVersion)+import qualified System.Info++-- https://hackage.haskell.org/package/dlist+import qualified Data.DList as DList+import Data.DList (DList)++-- https://hackage.haskell.org/package/network-uri+import qualified Network.URI as URI++-- https://hackage.haskell.org/package/scientific+import qualified Data.Scientific as Sci++-- https://hackage.haskell.org/package/text+import qualified Data.Text as T++-- https://hackage.haskell.org/package/transformers+import Control.Monad.Trans.Writer (Writer, runWriter, tell)++-- https://hackage.haskell.org/package/vector+import qualified Data.Vector as V+import Data.Vector (Vector)++-- (bm:cabal)+import qualified Paths_bm as Project++------------------------------------------------------------------------------+-- $Constants++-- | bm version string (\"@bm-haskell X.X.X.X@\")+--+-- @since 0.1.0.0+version :: String+version = "bm-haskell " ++ showVersion Project.version++------------------------------------------------------------------------------++-- | Default command, depending on the OS+defaultCommand :: Command+defaultCommand = case System.Info.os of+ "mingw32" -> "start"+ "darwin" -> "open"+ _other -> "xdg-open"++-- | Default query parameter name+defaultParameter :: ParameterName+defaultParameter = "q"++------------------------------------------------------------------------------+-- $Types+--+-- This implementation makes heavy use of the 'String' type. Type aliases are+-- provided to make the API easier to read.++-- | CLI argument or process argument+--+-- @since 0.1.0.0+type Argument = String++-- | Process command+--+-- This command is executed with a single URL argument to open a+-- bookmark/query.+--+-- @since 0.1.0.0+type Command = FilePath++-- | Error message+--+-- @since 0.1.0.0+type Error = String++-- | Bookmark keyword+--+-- The configuration file defines a hierarchy of keywords that are matched+-- against CLI arguments to determine which bookmark/query to open.+--+-- @since 0.1.0.0+type Keyword = String++-- | Query parameter name+--+-- @since 0.1.0.0+type ParameterName = String++-- | Query parameter value+--+-- @since 0.1.0.0+type ParameterValue = String++-- | Trace line for debugging+--+-- @since 0.1.0.0+type Trace = String++-- | Bookmark or query action URL+--+-- @since 0.1.0.0+type Url = String++------------------------------------------------------------------------------++-- | Configuration+--+-- YAML attributes:+--+-- * @command@: top-level command (string, default depends on the OS)+-- * @args@: bookmarks (array of 'Bookmark')+--+-- Default commands:+--+-- * Linux: @xdg-open@+-- * Windows: @start@+-- * macOS: @open@+--+-- @since 0.1.0.0+data Config+ = Config+ { configCommand :: !Command+ , configArgs :: !(Vector Bookmark)+ }+ deriving Show++instance FromJSON Config where+ parseJSON = A.withObject "Config" $ \o ->+ Config+ <$> o .:? "command" .!= defaultCommand+ <*> o .: "args"++------------------------------------------------------------------------------++-- | Bookmark definition+--+-- YAML attributes:+--+-- * @keyword@: bookmark keyword (string)+-- * @command@: command for this bookmark and children (string, optional)+-- * @url@: bookmark URL (string, optional)+-- * @query@: bookmark query definition ('Query', optional)+-- * @args@: child bookmarks (array of 'Bookmark', optional)+--+-- A command be set to override the top-level command, but this is generally+-- not done. If a bookmark is selected and there is no URL, the first child+-- is processed. Only one of @query@ and @args@ may be present.+--+-- @since 0.1.0.0+data Bookmark+ = Bookmark+ { keyword :: !Keyword+ , mCommand :: !(Maybe Command)+ , mUrl :: !(Maybe Url)+ , queryOrArgs :: !(Either Query (Vector Bookmark))+ }+ deriving Show++instance FromJSON Bookmark where+ parseJSON = A.withObject "Bookmark" $ \o -> do+ keyword <- parseToString =<< o .: "keyword"+ mCommand <- o .:? "command"+ mUrl <- o .:? "url"+ mQuery <- o .:? "query"+ mArgs <- o .:? "args"+ queryOrArgs <- case (mQuery, mArgs) of+ (Nothing, Just args) -> pure $ Right args+ (Just query, Nothing) -> pure $ Left query+ (Nothing, Nothing) -> pure $ Right V.empty+ (Just{}, Just{}) -> fail $+ "bookmark has both query and args: " ++ keyword+ pure Bookmark{..}++------------------------------------------------------------------------------++-- | Query definition+--+-- YAML attributes:+--+-- * @action@: URL (string)+-- * @parameter@: query parameter name (string, default: @q@)+-- * @hidden@: array of constant parameters ('Parameter')+--+-- @since 0.1.0.0+data Query+ = Query+ { action :: !Url+ , parameter :: !ParameterName+ , hiddenParameters :: !(Vector Parameter)+ }+ deriving Show++instance FromJSON Query where+ parseJSON = A.withObject "Query" $ \o ->+ Query+ <$> o .: "action"+ <*> o .:? "parameter" .!= defaultParameter+ <*> o .:? "hidden" .!= V.empty++------------------------------------------------------------------------------++-- | HTTP GET parameter definition+--+-- YAML attributes:+--+-- * @name@: parameter name+-- * @value@: constant parameter value+--+-- @since 0.1.0.0+data Parameter+ = Parameter+ { name :: !ParameterName+ , value :: !ParameterValue+ }+ deriving Show++instance FromJSON Parameter where+ parseJSON = A.withObject "Parameter" $ \o ->+ Parameter+ <$> o .: "name"+ <*> (parseToString =<< o .: "value")++-- | Encode an HTTP GET parameter+--+-- Spaces are transformed to plus characters, and other reserved characters+-- are escaped.+encodeParameter :: Parameter -> String+encodeParameter Parameter{..} = encodePart name ++ "=" ++ encodePart value+ where+ encodePart :: String -> String+ encodePart+ = map (\c -> if c == ' ' then '+' else c)+ . URI.escapeURIString ((||) <$> URI.isUnreserved <*> (== ' '))++------------------------------------------------------------------------------++-- | Process specification+--+-- @since 0.1.0.0+data Proc+ = Proc+ { command :: !Command+ , arguments :: ![Argument]+ }+ deriving (Eq, Show)++------------------------------------------------------------------------------+-- $API++-- | Determine the process to execute for the given config and CLI arguments+--+-- @since 0.1.0.0+run+ :: Config+ -> [Argument]+ -> (Either Error Proc, [Trace])+run Config{..} cliArgs = fmap DList.toList . runWriter $ do+ trace $ formatCommand configCommand+ loop configCommand configArgs cliArgs+ where+ loop+ :: Command+ -> Vector Bookmark+ -> [Argument]+ -> Writer (DList Trace) (Either Error Proc)+ loop cmd bms (arg:args) = case V.find (isPrefixOf arg . keyword) bms of+ Just bm -> do+ trace $ formatBookmark bm+ case queryOrArgs bm of+ Left query+ | null args -> case mUrl bm of+ Just url -> openUrl (fromMaybe cmd $ mCommand bm) url+ Nothing -> returnError $ "no query for " ++ keyword bm+ | otherwise -> openQuery (fromMaybe cmd $ mCommand bm) query args+ Right bms'+ | null args -> case mUrl bm of+ Just url -> openUrl (fromMaybe cmd $ mCommand bm) url+ Nothing -> case bms' V.!? 0 of+ Just bm' ->+ loop (fromMaybe cmd $ mCommand bm) bms' [keyword bm']+ Nothing -> returnError $ "no URL for " ++ keyword bm+ | otherwise -> loop (fromMaybe cmd $ mCommand bm) bms' args+ Nothing -> returnError $ "unknown argument: " ++ arg+ loop _cmd _bms [] = returnError "no arguments"++ returnError :: Error -> Writer (DList Trace) (Either Error Proc)+ returnError = return . Left++ openUrl :: Command -> Url -> Writer (DList Trace) (Either Error Proc)+ openUrl cmd url = do+ trace $ unwords [cmd, url]+ return . Right $ Proc cmd [url]++ openQuery+ :: Command+ -> Query+ -> [Argument]+ -> Writer (DList Trace) (Either Error Proc)+ openQuery cmd Query{..} args+ = openUrl cmd+ . (action ++)+ . ('?' :)+ . intercalate "&"+ . map encodeParameter+ $ Parameter parameter (unwords args) : V.toList hiddenParameters++ trace :: Trace -> Writer (DList Trace) ()+ trace = tell . DList.singleton++ formatCommand :: Command -> Trace+ formatCommand = ('[' :) . (++ "]")++ formatKeyword :: Keyword -> Trace+ formatKeyword = ('<' :) . (++ ">")++ formatBookmark :: Bookmark -> Trace+ formatBookmark Bookmark{..} = case mCommand of+ Just command -> unwords [formatKeyword keyword, formatCommand command]+ Nothing -> formatKeyword keyword++------------------------------------------------------------------------------++-- | Get CLI completion options+--+-- @since 0.1.0.0+getCompletion+ :: Config+ -> [Argument] -- ^ current CLI arguments, last one being completed+ -> [Argument] -- ^ completion options+getCompletion Config{..} = loop configArgs+ where+ loop :: Vector Bookmark -> [Argument] -> [Argument]+ loop bms [arg] = filter (isPrefixOf arg) . map keyword $ V.toList bms+ loop bms (arg:args) = case V.find (isPrefixOf arg . keyword) bms of+ Just bm -> case queryOrArgs bm of+ Left{} -> []+ Right bms' -> loop bms' args+ Nothing -> []+ loop _bms [] = []++------------------------------------------------------------------------------+-- $Internal++-- | Parse any scalar value as a string+--+-- Strings, numbers, booleans, and null are parsed as a string. Arrays and+-- objects result in an error.+parseToString :: A.Value -> AT.Parser String+parseToString = \case+ (A.String t) -> pure $ T.unpack t+ (A.Number n) -> pure . either (show @Double) (show @Integer) $+ Sci.floatingOrInteger n+ (A.Bool b) -> pure $ if b then "true" else "false"+ A.Null -> pure "null"+ A.Array{} -> fail "unexpected array"+ A.Object{} -> fail "unexpected object"
+ test/BM/Test.hs view
@@ -0,0 +1,302 @@+module BM.Test (tests) where++-- https://hackage.haskell.org/package/tasty+import Test.Tasty (TestTree, testGroup)++-- https://hackage.haskell.org/package/tasty-hunit+import Test.Tasty.HUnit ((@=?), testCase)++-- https://hackage.haskell.org/package/vector+import qualified Data.Vector as V++-- (bm)+import qualified BM++------------------------------------------------------------------------------++config :: BM.Config+config = BM.Config+ { BM.configCommand = "xdg-open"+ , BM.configArgs = V.fromList [ddg, google, nix, postgres, python, tst]+ }+ where+ ddg = BM.Bookmark+ { BM.keyword = "ddg"+ , BM.mCommand = Nothing+ , BM.mUrl = Just "https://duckduckgo.com"+ , BM.queryOrArgs = Left $ BM.Query+ { BM.action = "https://duckduckgo.com/"+ , BM.parameter = "q"+ , BM.hiddenParameters = V.fromList+ [ BM.Parameter+ { BM.name = "ia"+ , BM.value = "web"+ }+ ]+ }+ }++ google = BM.Bookmark+ { BM.keyword = "google"+ , BM.mCommand = Nothing+ , BM.mUrl = Nothing+ , BM.queryOrArgs = Left $ BM.Query+ { BM.action = "https://www.google.com/search"+ , BM.parameter = "q"+ , BM.hiddenParameters = V.empty+ }+ }++ nix = BM.Bookmark+ { BM.keyword = "nix"+ , BM.mCommand = Nothing+ , BM.mUrl = Just "https://nixos.org/"+ , BM.queryOrArgs = Right $ V.fromList [nixManual, nixOS, nixPkgs]+ }+ nixManual = BM.Bookmark+ { BM.keyword = "manual"+ , BM.mCommand = Nothing+ , BM.mUrl = Just "https://nixos.org/manual/nix/stable"+ , BM.queryOrArgs = Right V.empty+ }+ nixOS = BM.Bookmark+ { BM.keyword = "OS"+ , BM.mCommand = Nothing+ , BM.mUrl = Just "https://nixos.org/manual/nixos/stable"+ , BM.queryOrArgs = Right V.empty+ }+ nixPkgs = BM.Bookmark+ { BM.keyword = "pkgs"+ , BM.mCommand = Nothing+ , BM.mUrl = Just "https://github.com/NixOS/nixpkgs"+ , BM.queryOrArgs = Right $ V.fromList [nixPkgsManual]+ }+ nixPkgsManual = BM.Bookmark+ { BM.keyword = "manual"+ , BM.mCommand = Nothing+ , BM.mUrl = Just "https://nixos.org/manual/nixpkgs/stable"+ , BM.queryOrArgs = Right V.empty+ }++ postgres = BM.Bookmark+ { BM.keyword = "postgres"+ , BM.mCommand = Nothing+ , BM.mUrl = Just "https://www.postgresql.org/docs/current/index.html"+ , BM.queryOrArgs = Right V.empty+ }++ python = BM.Bookmark+ { BM.keyword = "python"+ , BM.mCommand = Nothing+ , BM.mUrl = Just "https://docs.python.org/3/"+ , BM.queryOrArgs = Right V.empty+ }++ tst = BM.Bookmark+ { BM.keyword = "tst"+ , BM.mCommand = Nothing+ , BM.mUrl = Nothing+ , BM.queryOrArgs = Right $ V.fromList [tstAUrl, tstCommand, tstNoUrl]+ }+ tstAUrl = BM.Bookmark+ { BM.keyword = "aurl"+ , BM.mCommand = Nothing+ , BM.mUrl = Just "http://localhost:8001"+ , BM.queryOrArgs = Right V.empty+ }+ tstCommand = BM.Bookmark+ { BM.keyword = "cmd"+ , BM.mCommand = Just "firefox"+ , BM.mUrl = Just "http://localhost:8002"+ , BM.queryOrArgs = Right $ V.fromList [tstCommandChild]+ }+ tstCommandChild = BM.Bookmark+ { BM.keyword = "child"+ , BM.mCommand = Nothing+ , BM.mUrl = Just "http://localhost:8003"+ , BM.queryOrArgs = Right V.empty+ }+ tstNoUrl = BM.Bookmark+ { BM.keyword = "nourl"+ , BM.mCommand = Nothing+ , BM.mUrl = Nothing+ , BM.queryOrArgs = Right V.empty+ }++------------------------------------------------------------------------------++testRun :: TestTree+testRun = testGroup "run"+ [ testCase "exact" $+ ( Right $ BM.Proc+ { BM.command = "xdg-open"+ , BM.arguments = ["https://nixos.org/"]+ }+ , [ "[xdg-open]"+ , "<nix>"+ , "xdg-open https://nixos.org/"+ ]+ ) @=? BM.run config ["nix"]+ , testCase "prefix" $+ ( Right $ BM.Proc+ { BM.command = "xdg-open"+ , BM.arguments = ["https://nixos.org/"]+ }+ , [ "[xdg-open]"+ , "<nix>"+ , "xdg-open https://nixos.org/"+ ]+ ) @=? BM.run config ["n"]+ , testCase "subExact" $+ ( Right $ BM.Proc+ { BM.command = "xdg-open"+ , BM.arguments = ["https://nixos.org/manual/nixpkgs/stable"]+ }+ , [ "[xdg-open]"+ , "<nix>"+ , "<pkgs>"+ , "<manual>"+ , "xdg-open https://nixos.org/manual/nixpkgs/stable"+ ]+ ) @=? BM.run config ["nix", "pkgs", "manual"]+ , testCase "subPrefix" $+ ( Right $ BM.Proc+ { BM.command = "xdg-open"+ , BM.arguments = ["https://nixos.org/manual/nixpkgs/stable"]+ }+ , [ "[xdg-open]"+ , "<nix>"+ , "<pkgs>"+ , "<manual>"+ , "xdg-open https://nixos.org/manual/nixpkgs/stable"+ ]+ ) @=? BM.run config ["n", "p", "m"]+ , testCase "first" $+ ( Right $ BM.Proc+ { BM.command = "xdg-open"+ , BM.arguments =+ ["https://www.postgresql.org/docs/current/index.html"]+ }+ , [ "[xdg-open]"+ , "<postgres>"+ , "xdg-open https://www.postgresql.org/docs/current/index.html"+ ]+ ) @=? BM.run config ["p"]+ , testCase "queryUrlNoArgs" $+ ( Right $ BM.Proc+ { BM.command = "xdg-open"+ , BM.arguments = ["https://duckduckgo.com"]+ }+ , [ "[xdg-open]"+ , "<ddg>"+ , "xdg-open https://duckduckgo.com"+ ]+ ) @=? BM.run config ["d"]+ , testCase "queryUrlArgs" $+ ( Right $ BM.Proc+ { BM.command = "xdg-open"+ , BM.arguments = ["https://duckduckgo.com/?q=haskell+nix&ia=web"]+ }+ , [ "[xdg-open]"+ , "<ddg>"+ , "xdg-open https://duckduckgo.com/?q=haskell+nix&ia=web"+ ]+ ) @=? BM.run config ["d", "haskell", "nix"]+ , testCase "queryNoUrlArgs" $+ ( Right $ BM.Proc+ { BM.command = "xdg-open"+ , BM.arguments = ["https://www.google.com/search?q=haskell+nix"]+ }+ , [ "[xdg-open]"+ , "<google>"+ , "xdg-open https://www.google.com/search?q=haskell+nix"+ ]+ ) @=? BM.run config ["goo", "haskell", "nix"]+ , testCase "queryNoUrlNoArgs" $+ ( Left "no query for google"+ , [ "[xdg-open]"+ , "<google>"+ ]+ ) @=? BM.run config ["goo"]+ , testCase "noUrlSub" $+ ( Right $ BM.Proc+ { BM.command = "xdg-open"+ , BM.arguments = ["http://localhost:8001"]+ }+ , [ "[xdg-open]"+ , "<tst>"+ , "<aurl>"+ , "xdg-open http://localhost:8001"+ ]+ ) @=? BM.run config ["tst"]+ , testCase "noUrlError" $+ ( Left "no URL for nourl"+ , [ "[xdg-open]"+ , "<tst>"+ , "<nourl>"+ ]+ ) @=? BM.run config ["tst", "nourl"]+ , testCase "unknownError" $+ ( Left "unknown argument: unknown"+ , [ "[xdg-open]"+ , "<tst>"+ ]+ ) @=? BM.run config ["tst", "unknown"]+ , testCase "noArgsError" $+ ( Left "no arguments"+ , [ "[xdg-open]"+ ]+ ) @=? BM.run config []+ , testCase "command" $+ ( Right $ BM.Proc+ { BM.command = "firefox"+ , BM.arguments = ["http://localhost:8002"]+ }+ , [ "[xdg-open]"+ , "<tst>"+ , "<cmd> [firefox]"+ , "firefox http://localhost:8002"+ ]+ ) @=? BM.run config ["tst", "cmd"]+ , testCase "commandChild" $+ ( Right $ BM.Proc+ { BM.command = "firefox"+ , BM.arguments = ["http://localhost:8003"]+ }+ , [ "[xdg-open]"+ , "<tst>"+ , "<cmd> [firefox]"+ , "<child>"+ , "firefox http://localhost:8003"+ ]+ ) @=? BM.run config ["tst", "cmd", "child"]+ ]++------------------------------------------------------------------------------++testGetCompletion :: TestTree+testGetCompletion = testGroup "getCompletion"+ [ testCase "all" $+ [ "ddg", "google", "nix", "postgres", "python", "tst"+ ] @=? BM.getCompletion config [""]+ , testCase "exact" $+ ["nix"] @=? BM.getCompletion config ["nix"]+ , testCase "subExact" $+ ["pkgs"] @=? BM.getCompletion config ["nix", "pkgs"]+ , testCase "prefix" $+ ["postgres", "python"] @=? BM.getCompletion config ["p"]+ , testCase "none" $+ [] @=? BM.getCompletion config ["google", "maps"]+ , testCase "noneFirst" $+ [] @=? BM.getCompletion config ["j", "e"]+ , testCase "empty" $+ [] @=? BM.getCompletion config []+ ]++------------------------------------------------------------------------------++tests :: TestTree+tests = testGroup "BM"+ [ testRun+ , testGetCompletion+ ]
+ test/Spec.hs view
@@ -0,0 +1,14 @@+module Main (main) where++-- https://hackage.haskell.org/package/tasty+import Test.Tasty (defaultMain, testGroup)++-- (bm:test)+import qualified BM.Test++------------------------------------------------------------------------------++main :: IO ()+main = defaultMain $ testGroup "test"+ [ BM.Test.tests+ ]