diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,13 @@ +# Unreleased + +- `sak gitit create` takes `-r` / `--add-remote` to add the newly created repo as a remote of the current local repo (named after the target), or `-n NAME` / `--remote-name NAME` to choose the remote name. Works in git and jj repos; checks run before the remote repo is created. +- Local targets now report an absolute path, so it works as a remote URL. +- gitit API errors (GitHub, GitLab, Bitbucket) are reported as one line with the HTTP status and the forge's message, instead of crashing on an empty or non-JSON response body. +- Bitbucket: optional `BITBUCKET_PROJECT` selects the project new repos are created in. +- README: full gitit documentation, including token setup for each forge. +- README: expanded documentation for every knife (flags, output, what each one does under the hood), and a note on sudo. +- `make readme` regenerates `.github/README.md` (what GitHub displays) from README.org; `make sdist` now runs it too. + # 1.1.0.5 - 2026-07-11 - Made build static to get around dynamic mixmatch issues with GHC versions. diff --git a/CHANGELOG.org b/CHANGELOG.org --- a/CHANGELOG.org +++ b/CHANGELOG.org @@ -1,6 +1,22 @@ #+TITLE: Changelog for swiss-army-knife #+AUTHOR: Fred Mitchell #+EMAIL: fred.mitchell@atomlogik.de +* Unreleased + + =sak gitit create= takes =-r= / =--add-remote= to add the newly created + repo as a remote of the current local repo (named after the target), or + =-n NAME= / =--remote-name NAME= to choose the remote name. Works in git + and jj repos; checks run before the remote repo is created. + + Local targets now report an absolute path, so it works as a remote URL. + + gitit API errors (GitHub, GitLab, Bitbucket) are reported as one line + with the HTTP status and the forge's message, instead of crashing on an + empty or non-JSON response body. + + Bitbucket: optional =BITBUCKET_PROJECT= selects the project new repos are + created in. + + README: full gitit documentation, including token setup for each forge. + + README: expanded documentation for every knife (flags, output, what each + one does under the hood), and a note on sudo. + + =make readme= regenerates =.github/README.md= (what GitHub displays) from + README.org; =make sdist= now runs it too. * 1.1.0.5 - 2026-07-11 + Made build static to get around dynamic mixmatch issues with GHC versions. + Static made optional for Hackage installs. diff --git a/README.org b/README.org --- a/README.org +++ b/README.org @@ -1,10 +1,13 @@ +#+OPTIONS: tags:nil -:nil ^:{} H:4 * swiss-army-knife :TOC_7_gh: - [[#created-by][Created By]] - [[#introduction][Introduction]] - [[#installation][Installation]] - - [[#statiic-builds-from-hackage][Statiic Builds from Hackage]] + - [[#static-builds-from-hackage][Static Builds from Hackage]] - [[#documentation][Documentation]] + - [[#privileges-sudo][Privileges (sudo)]] - [[#sak---help][sak --help]] + - [[#sak-version][sak version]] - [[#sak-extip][sak extip]] - [[#sak-kernel][sak kernel]] - [[#sak-sleep][sak sleep]] @@ -12,6 +15,14 @@ - [[#sak-wg][sak wg]] - [[#sak-nm][sak nm]] - [[#sak-sn][sak sn]] + - [[#sak-gitit][sak gitit]] + - [[#managing-targets][Managing targets]] + - [[#creating-a-repo][Creating a repo]] + - [[#local][Local]] + - [[#github][GitHub]] + - [[#gitlab][GitLab]] + - [[#bitbucket][Bitbucket]] + - [[#errors][Errors]] - [[#examples][Examples]] ** Created By @@ -33,63 +44,372 @@ As I find out about them, I will fix them as quickly as I can. ** Installation + using cabal (recommended) - cabal update - cabal install swiss-army-knife + #+begin_src sh + cabal update + cabal install swiss-army-knife + #+end_src + On Arch from the AUR | using aura | aura -A swiss-army-knife | | using yay | yay -S swiss-army-knife | | using paru | paru -S swiss-army-knife | -*** Statiic Builds from Hackage +*** Static Builds from Hackage To build a statically-linked binary, install: - + `ghc-static` (Arch: `pacman -S ghc-static`) - + a static gmp (Arch: AUR `libgmp-static`) - + a static zlib — Arch's official package dropped `libz.a` as of 1.3.2; + + =ghc-static= (Arch: =pacman -S ghc-static=) + + a static gmp (Arch: AUR =libgmp-static=) + + a static zlib — Arch's official package dropped =libz.a= as of 1.3.2; build it yourself from https://zlib.net if needed. - Then: `cabal install swiss-army-knife -fstatic` + Then: =cabal install swiss-army-knife -fstatic= ** Documentation - These are the current "knives" implemented. More to come. Open - to suggestions. - + Note that you no longer have to prepend "sudo" to do system-level - operations. + These are the current "knives". More to come; suggestions welcome. + + Every knife is a sub-command of =sak=, and each has its own help: + #+begin_src fish + sak --help # list all knives + sak wg --help # options for one knife + #+end_src + +*** Privileges (sudo) + You don't need to run =sak= itself with =sudo=. The knives that + change system services (=wg=, =nm=, =sn=) call =sudo systemctl= + themselves, so expect a password prompt unless your sudoers + configuration allows =systemctl= without one. The other knives + run as your normal user. + *** sak --help - Will list all the current commands. + Lists all the knives with a one-line description of each. + =-v= / =--verbose= is accepted as a global flag, but no knife + uses it yet. + +*** sak version + Prints the installed version of Swiss Army Knife. + *** sak extip - Will tell you what your external IP is for your connection, - either in IPv4 or IPv6 Useful if you use a VPN + Shows the external (public) IP address of your connection, which + is what the rest of the internet sees. Handy for confirming that a + VPN is actually in use. By default it also shows the approximate + location and time zone of that address. + + | Flag | Meaning | + |------------------+-----------------------------------------------------| + | -n, --nolocation | Show only the IP address, without location lookup. | + | -i, --ipv6 | Show your IPv6 address instead of the IPv4 address. | + + Example output: + #+begin_example + 203.0.113.42 + Location: Frankfurt am Main, Germany (DE) + Timezone: Europe/Berlin + #+end_example + + The address comes from jsonip.com; the location from ip-api.com. + =-i= only works if your connection has IPv6. The location lookup + is done over plain HTTP and may reflect your IPv4 address even + with =-i=; use =-n= if you'd rather not send that request. + *** sak kernel - Will tell you the version of the installed kernel as well - as the running version. Support is in for Arch, Debian, and - RedHat, but only Arch has been tested. + Shows the kernel you are running and the kernel packages that are + installed, so you can tell whether you need a reboot after an + upgrade. + + | Flag | Meaning | + |-------------------+--------------------------------------------------------------| + | -j, --justversion | Print only the running kernel version (useful in scripts). | + + Example output (Arch): + #+begin_example + Running kernel: 6.17.7-arch1-1 + Installed kernels: + linux 6.17.8.arch1-1 + linux-lts 6.12.57-1 + #+end_example + + The running kernel comes from =uname -r=. Installed kernels are + looked up with the distribution's package manager: + + | Distribution family | How | + |--------------------------------------------------------+-----------------------------------------------| + | Arch | =pacman -Q= for linux, linux-lts, linux-zen, linux-hardened | + | Debian, Ubuntu, Mint, Pop!_OS, Kali, elementary, Zorin | =dpkg-query= for =linux-image-*= | + | RHEL, CentOS, Fedora, Rocky, AlmaLinux, Oracle | =rpm -qa kernel*= (headers, devel etc. excluded) | + + Arch is the most tested. If the packages can't be determined, + =sak kernel= says so and still shows the running kernel. + *** sak sleep - Will put your system in standby mode. + Suspends the machine (=systemctl suspend=). + + | Flag | Meaning | + |--------------------+------------------------------------------| + | -w, --wait SECONDS | Wait this many seconds before suspending. | + + #+begin_src fish + sak sleep # suspend now + sak sleep -w 300 # suspend in 5 minutes + #+end_src + + Suspend is requested with =-i=, so it goes ahead even if a program + (a video player, a download) is holding a suspend inhibitor. The + wait runs in the foreground; press Ctrl-C during it to cancel. + *** sak zfscheck - If you use the zfs from archzfs, sometimes it - does not keep up with the latest kernel release. - Check to see the latest kernel zfs supports before - you do a system upgrade. Other distros will probably - not have the zfs sync issues that Arch does. + *Arch Linux with archzfs only.* ZFS on Arch is an out-of-tree + module, and archzfs sometimes lags behind the newest kernel. If + you upgrade the kernel before ZFS supports it, the ZFS module + won't load and your pools won't import. =zfscheck= tells you, + before you upgrade, whether the kernel currently in the repos is + supported. That lets you stay on the regular =linux= kernel (held + back when needed) instead of switching to =linux-lts=. + + | Flag | Meaning | + |------------+-------------------------------------------------------------| + | -f, --full | Also show where the supported-kernel ceiling was read from. | + + It compares: + + the =linux= version in the repos, the one installed, and the + one running; + + the OpenZFS version the repos would install (=zfs-dkms=, or + =zfs-utils=), and the newest kernel that OpenZFS release + supports (=Linux-Maximum= in its =META= file, read from + =/usr/src/zfs-VERSION/META= if present, otherwise fetched from + the OpenZFS release tag on GitHub with =curl=); + + the exact kernel build that the prebuilt =zfs-linux= package + targets, if that package is available. + + It then gives a verdict for both ways of installing ZFS: + #+begin_example + DKMS route: OK + Prebuilt route: NO + + Upgrade possible: install linux, linux-headers and the ZFS packages in one transaction. + #+end_example + + + *DKMS route*: OK when the repo kernel's major.minor version is + no newer than what the OpenZFS release supports. + + *Prebuilt route*: OK only when =zfs-linux= was built for exactly + the repo kernel. + + If neither is OK it tells you not to upgrade the kernel yet. + Add =linux= (and =linux-headers=) to =IgnorePkg= in + =/etc/pacman.conf= to hold it back while upgrading everything + else, and run =zfscheck= again later. + + The repo versions come from pacman's sync databases, so the result + is only as fresh as your last database sync. =curl= must be + installed for the GitHub fallback. + *** sak wg - If you use WireGuard for your VPN, manage it from - here. List your installed WireGuard options, - and swap among them. you can start, stop, and list your - WireGuard VPNs. + Manages WireGuard VPNs set up for =wg-quick=: each + =/etc/wireguard/NAME.conf= is a VPN called =NAME=, run by the + systemd unit =wg-quick@NAME=. - Now supports enabling and disabling of the underlying daemon. + | Flag | Meaning | + |--------------------+--------------------------------------------------------------------| + | -l, --list | List each VPN with whether it is active and whether it is enabled. | + | -a, --activate VPN | Start VPN for this session only. | + | -A, --enable VPN | Start VPN and enable it, so it also starts at boot. | + | -d, --deactivate | Stop every active VPN. They stay enabled for the next boot. | + | -D, --disable | Disable every enabled VPN, and stop them. | + | -r, --reactivate | Restart every active VPN (e.g. after editing a config). | + + =-l= can be combined with any one other flag; the rest are + mutually exclusive. The list is printed before the action runs, + so it shows the state beforehand. + + #+begin_src fish + sak wg -l # what's there and what's running + sak wg -d; sak wg -a de-berlin # switch VPNs (one action per call) + #+end_src + + =sak= needs to be able to read the =/etc/wireguard= directory to + find the VPN names. + *** sak nm - Manage NetworkManager - Now supports enabling and disabling of the underlying daemon. + Controls NetworkManager (=NetworkManager.service=). Give exactly one + flag: + | Flag | Meaning | + |------------------+--------------------------------------------| + | -a, --activate | Start it for this session. | + | -A, --enable | Start it and enable it at boot. | + | -d, --deactivate | Stop it; it still starts at the next boot. | + | -D, --disable | Stop it and disable it at boot. | + | -r, --reactivate | Restart it. | + + Together with =sak sn= this makes switching between NetworkManager + and systemd-networkd a two-command job, e.g. =sak nm -D; sak sn -A=. + Don't leave both enabled: they will fight over the interfaces. + *** sak sn - Manage systemd-networkd - Now supports enabling and disabling of the underlying daemon. + Controls systemd-networkd. It acts on both + =systemd-networkd.socket= and =systemd-networkd.service=, so the + socket doesn't restart the service behind your back. Give exactly + one flag: + | Flag | Meaning | + |------------------+----------------------------------------------------------| + | -a, --activate | Start socket and service for this session. | + | -A, --enable | Start both, and enable the service at boot. | + | -d, --deactivate | Stop both; the service still starts at the next boot. | + | -D, --disable | Stop both, and disable the service at boot. | + | -r, --reactivate | Restart both (e.g. after editing a =.network= file). | + +*** sak gitit + Creates the remote repository for a local Git (or jj) repo, on + your own filesystem or on GitHub, GitLab or Bitbucket, and can add + it as a remote of the local repo in the same step. + + Destinations are called /targets/. Each target has a name, a kind + (=local=, =github=, =gitlab= or =bitbucket=) and a location. They + are stored in =~/.config/swiss-army-knife/config.yaml= under the + =gitit= key, and managed with the sub-commands below rather than + by editing the file. + +**** Managing targets + | Command | Description | + |----------------------------------+-------------------------------------------------------------------| + | sak gitit list | List the configured targets and their kinds. | + | sak gitit add KIND NAME LOCATION | Add a target (KIND: local, github, gitlab or bitbucket). | + | sak gitit delete NAME | Remove a target. | + | sak gitit default NAME | Record a target as the default (not yet used by =create=). | + + LOCATION is a directory for =local= targets, and the forge's SSH + prefix for the others. + + For example: + #+begin_src fish + sak gitit add local origin ~/pCloud/repo + sak gitit add github github git@github.com:flajann2 + sak gitit add gitlab gitlab git@gitlab.com:eltoro-maestro + sak gitit add bitbucket bitbucket git@bitbucket.org:eltoro-maestro + #+end_src + + For the forges the LOCATION is informational: the account a repo + is created in comes from the credentials described below. + +**** Creating a repo + #+begin_src fish + sak gitit create TARGET REPONAME [-r | -n NAME] + #+end_src + + | Flag | Meaning | + |------------------------+-------------------------------------------------------------------------------| + | -r, --add-remote | Also add the new repo as a remote of the current repo, named after the target. | + | -n, --remote-name NAME | Same, but use NAME as the remote name (e.g. =origin=). Implies =-r=. | + + Without either flag, gitit only creates the repo and prints the + =git remote add= command for you to run yourself. + + With =-r= or =-n=, run gitit from inside the local repo. Before + anything is created, gitit checks that + + the current directory is inside a git or jj repo, and + + the local repo does not already have a remote with that name, + so a typo never leaves an orphaned repo on the forge. In a jj + repo (including a colocated one) the remote is added with + =jj git remote add=, otherwise with =git remote add=. If adding + the remote fails after the repo was created, gitit prints the + exact command to add it by hand. + + Repos are currently created as public on all forges. + +**** Local + Creates a bare repo at =LOCATION/REPONAME.git=, for example on a + cloud-backed filesystem such as pCloud. The path is made absolute, + so it works as a remote URL from any directory. Fails if that path + already exists. + +**** GitHub + Needs a GitHub token, taken from the first of: + 1. the =GITHUB_TOKEN= environment variable, or + 2. the GitHub CLI's login (=gh auth token=), after =gh auth login=. + A classic token needs the =repo= scope (=public_repo= is enough for + public repos); a fine-grained token needs /Administration: write/. + The repo is created under the account the token belongs to. + +**** GitLab + Needs a GitLab token, taken from the first of: + 1. the =GITLAB_TOKEN= environment variable, or + 2. glab's saved login (=glab config get token=), after + =glab auth login=. If glab keeps the token in the system + keyring, gitit cannot read it from there; use =GITLAB_TOKEN=. + The token is a personal access token with the =api= scope, + created under /Edit profile → Access tokens/ + (https://gitlab.com/-/user_settings/personal_access_tokens). + For a self-hosted GitLab, set =GITLAB_HOST= (the same variable + glab uses); the default is =gitlab.com=. The project is created + in your user namespace. + +**** Bitbucket + Bitbucket has no CLI login to borrow, so it is configured with + environment variables: + + | Variable | Required | Meaning | + |-----------------------+----------+----------------------------------------------------------| + | =BITBUCKET_WORKSPACE= | yes | Workspace slug, as in =bitbucket.org/WORKSPACE/...= | + | =BITBUCKET_EMAIL= | yes | The email address you log in to Atlassian with. | + | =BITBUCKET_TOKEN= | yes | An Atlassian API token with Bitbucket scopes (see below). | + | =BITBUCKET_PROJECT= | no | Key of the project to create the repo in. | + + *The token.* Use an Atlassian *API token*, not a repository, + project or workspace access token (those are tied to one + resource and cannot create new repos). Create it at + https://id.atlassian.com/manage-profile/security/api-tokens: + 1. Choose *Create API token with scopes* (the plain + /Create API token/ button makes a token Bitbucket rejects with + "API Token provided has no Bitbucket scopes"). + 2. Pick *Bitbucket* as the app. + 3. Grant =read:repository:bitbucket=, =write:repository:bitbucket= + and =admin:repository:bitbucket=. Nothing else is needed; avoid + the =delete:= scopes. + 4. Copy the token; it is shown only once. + + *The project.* Every Bitbucket repo belongs to a project. Without + =BITBUCKET_PROJECT=, Bitbucket uses the workspace's default + project, and if you can't create repos there it answers + "You can't create repositories under this project". Set it to + the key of a project you administer (shown under the workspace's + /Projects/ page). + + In fish: + #+begin_src fish + set -Ux BITBUCKET_WORKSPACE eltoro-maestro + set -Ux BITBUCKET_EMAIL you@example.com + set -Ux BITBUCKET_PROJECT KEY + read -s -x -U BITBUCKET_TOKEN # paste the token; it is not echoed + #+end_src + + To check the credentials without gitit (expect =200=; =401= means + the email/token pair is wrong): + #+begin_src fish + curl -s -o /dev/null -w '%{http_code}\n' -u "$BITBUCKET_EMAIL:$BITBUCKET_TOKEN" \ + "https://api.bitbucket.org/2.0/repositories/$BITBUCKET_WORKSPACE?pagelen=1" + #+end_src + + Bitbucket repo slugs are lowercase, so =MyRepo= becomes =myrepo=. + +**** Errors + API failures are reported as one line with the HTTP status and the + forge's own message, for example: + #+begin_example + gitit: Bitbucket API error (HTTP 400): project: You can't create repositories under this project. + #+end_example + When the forge sends no message (Bitbucket answers a bad token with + an empty 401), gitit says whether the problem is authentication + (401) or permissions/scopes (403). + ** Examples - | Command | Description | - |-----------+--------------------------------------------------------------------------------------------------------------------| - | sak extip | Will list your external IP and location information | - | sak wg -l | (If you are using wg_quick) will list all of your available WG vpns, as well as their active and enabled statuses. | - | sak wg -d | Will deactivate (but not disable) all WireGuard VPNs. | - | sak wg -D | Will disable (but not deactivate) all WireGuard VPNs. | - | sak sn -A | Will enable and start systemd-networkd. | - | sak nm -D | Will disable and stop NetworkManager. | - |-----------+--------------------------------------------------------------------------------------------------------------------| + | Command | Description | + |--------------------------------+--------------------------------------------------------------------------------------------------------------------| + | sak extip | Will list your external IP and location information | + | sak wg -l | (If you are using wg_quick) will list all of your available WG vpns, as well as their active and enabled statuses. | + | sak wg -d | Will deactivate (but not disable) all WireGuard VPNs. | + | sak wg -D | Will disable all enabled WireGuard VPNs, and stop them. | + | sak sn -A | Will enable and start systemd-networkd. | + | sak nm -D | Will disable and stop NetworkManager. | + | sak extip -n | Will print just your external IPv4 address. | + | sak kernel -j | Will print just the running kernel version. | + | sak sleep -w 300 | Will suspend the machine in 5 minutes. | + | sak zfscheck | Will tell you whether archzfs supports the kernel in the repos, before you upgrade. | + | sak gitit create origin myrepo | Will create a new remote repo named "myrepo" in the origin target. | + | sak gitit create github myrepo -r | Will create "myrepo" on GitHub and add it as remote "github" of the current repo. | + | sak gitit create gitlab myrepo -n origin | Will create "myrepo" on GitLab and add it as remote "origin" of the current repo. | + | | | + |--------------------------------+--------------------------------------------------------------------------------------------------------------------| diff --git a/app/SwissArmyKnife.hs b/app/SwissArmyKnife.hs --- a/app/SwissArmyKnife.hs +++ b/app/SwissArmyKnife.hs @@ -1,25 +1,51 @@ --- main for Swiss Army Knife, cli. +-- | main for Swiss Army Knife, cli. module Main where import Options.Applicative -import Data.Semigroup ((<>)) + ( (<**>) + , fullDesc + , header + , info + , progDesc + , execParser + , helper ) import CommandLine -import Knives + ( Command( SysNet + , ExtIP + , Kernel + , Sleep + , Version + , ZfsCheck + , WireGuard + , NetMan + , Gitit ) + , opts ) +import Knives.ExtIP ( knifeExtIP ) +import Knives.Kernel ( knifeKernel ) +import Knives.NetMan ( knifeNetMan ) +import Knives.Sleep ( knifeSleep ) +import Knives.SysNet ( knifeSysNet ) +import Knives.Version ( knifeVersion ) +import Knives.WireGuard ( knifeWireGuard ) +import Knives.ZfsCheck ( knifeZfsCheck ) +import Knives.Gitit ( knifeGitit ) + main :: IO () main = do - (globalOpts, cmd) <- execParser $ info (opts <**> helper) + (_, cmd) <- execParser $ info (opts <**> helper) ( fullDesc <> progDesc "Many useful utilities, such as getting your external IP address, installed kernel, controlling your WireGuard, etc." <> header "Swiss Army Knife -- Many useful functions for the hacker in all of us." ) - + case cmd of ExtIP extipOpts -> knifeExtIP extipOpts Kernel kernelOpts -> knifeKernel kernelOpts - Sleep sleepOpts -> knifeSleep sleepOpts - Version versionOpts -> knifeVersion versionOpts + Sleep sleepOpts -> knifeSleep sleepOpts + Version versionOpts -> knifeVersion versionOpts ZfsCheck zfsOpts -> knifeZfsCheck zfsOpts WireGuard wgOpts -> knifeWireGuard wgOpts NetMan nmOpts -> knifeNetMan nmOpts SysNet snOpts -> knifeSysNet snOpts + Gitit gititOpts -> knifeGitit gititOpts diff --git a/lib/CommandLine.hs b/lib/CommandLine.hs --- a/lib/CommandLine.hs +++ b/lib/CommandLine.hs @@ -3,6 +3,23 @@ module CommandLine where import Options.Applicative + ( optional, + auto, + argument, + command, + help, + info, + long, + metavar, + option, + progDesc, + short, + str, + strOption, + subparser, + switch, + Parser ) +import Data.Maybe (fromMaybe) -- Define data types for our commands and options data Command @@ -14,6 +31,7 @@ | WireGuard WireGuardOptions | NetMan NetManOptions | SysNet SysNetOptions + | Gitit GititCommand deriving Show data ExtIPOptions = ExtIPOptions @@ -57,6 +75,17 @@ , reactivateSN :: Bool } deriving Show +-- | gitit is now a sub-command group +data GititCommand + = GititList + | GititAdd String String String + | GititDelete String + | GititDefault String + | GititCreate String String (Maybe String) + -- ^ TARGET REPONAME, and the local remote name to register the + -- new repo under (Nothing = don't touch the local repo) + deriving Show + data GlobalOptions = GlobalOptions { verbose :: Bool } deriving Show @@ -159,7 +188,58 @@ <> short 'r' <> help "Reactivate (restart) systemd-networkd socket and service") +-- Individual gitit sub-command parsers +gititListParser :: Parser GititCommand +gititListParser = pure GititList + +gititAddParser :: Parser GititCommand +gititAddParser = mkGititAdd + <$> argument str (metavar "KIND" <> help "Kind of target") + <*> argument str (metavar "REMOTE" <> help "Remote repo, normally the same as KIND") + <*> argument str (metavar "LOCATION" <> help "Location path, depending on KIND") + where + mkGititAdd :: String -> String -> String -> GititCommand + mkGititAdd targetKind mRemote mLocation = GititAdd targetKind mRemote mLocation + +gititDeleteParser :: Parser GititCommand +gititDeleteParser = GititDelete + <$> argument str (metavar "REMOTE" <> help "Remote repo to delete") + +gititDefaultParser :: Parser GititCommand +gititDefaultParser = GititDefault + <$> argument str (metavar "REMOTE" <> help "Remote repo to make the default") + +gititCreateParser :: Parser GititCommand +gititCreateParser = mkGititCreate + <$> argument str (metavar "KIND" <> help "Target to create a new repository in") + <*> argument str (metavar "REPONAME" <> help "Name of the new repo") + <*> switch ( long "add-remote" + <> short 'r' + <> help "Add the new repo as a remote of the current local repo, named after the target" ) + <*> optional (strOption ( long "remote-name" + <> short 'n' + <> metavar "NAME" + <> help "Add the new repo as a remote under NAME instead (implies --add-remote)" )) + where + mkGititCreate :: String -> String -> Bool -> Maybe String -> GititCommand + mkGititCreate target repo addRemote mName = GititCreate target repo $ + case mName of + Just n -> Just n + Nothing + | addRemote -> Just target + | otherwise -> Nothing + +-- Combine gitit's sub-commands into one parser +gititOptionsParser :: Parser GititCommand +gititOptionsParser = subparser + ( command "list" (info gititListParser (progDesc "List known remote repositories")) + <> command "add" (info gititAddParser (progDesc "Add a remote repo")) + <> command "delete" (info gititDeleteParser (progDesc "Delete a remote repo")) + <> command "default" (info gititDefaultParser (progDesc "Make repo the default")) + <> command "create" (info gititCreateParser (progDesc "Create a new repo in the remote repository")) + ) + -- Combine the subcommand parsers commandParser :: Parser Command commandParser = subparser @@ -171,6 +251,7 @@ <> command "wg" (info (WireGuard <$> wgOptionsParser) (progDesc "Manage WireGuard VPNs")) <> command "nm" (info (NetMan <$> nmOptionsParser) (progDesc "Manage NetworkManager")) <> command "sn" (info (SysNet <$> snOptionsParser) (progDesc "Manage systemd-networkd")) + <> command "gitit" (info (Gitit <$> gititOptionsParser) (progDesc "Manage gitit remote repositories")) ) -- Combine global options with the command parser diff --git a/lib/Config.hs b/lib/Config.hs new file mode 100644 --- /dev/null +++ b/lib/Config.hs @@ -0,0 +1,121 @@ +-- | Config.hs — generic per-knife configuration storage. +-- The on-disk YAML file is a flat map from knife name to that knife's +-- own config blob. Knives own their own types; nobody needs to know +-- about anyone else's schema, and a knife that doesn't call +-- getKnifeConfig never touches the file at all. + +{-# LANGUAGE OverloadedStrings #-} + +module Config + ( getKnifeConfig + , setKnifeConfig + , configDir + , configFile + ) where + +import Data.Aeson (FromJSON, ToJSON, Value(..), fromJSON, toJSON, Result(..)) +import qualified Data.Aeson.KeyMap as KM +import Data.Aeson.Key (fromText) +import Data.IORef +import Data.Text (Text) +import qualified Data.Text as T +import Data.Yaml (decodeFileEither, encodeFile, prettyPrintParseException) +import System.Directory + ( XdgDirectory(XdgConfig) + , getXdgDirectory + , createDirectoryIfMissing + , doesFileExist + ) +import System.FilePath (()) +import System.IO (hPutStrLn, stderr) +import System.IO.Unsafe (unsafePerformIO) + +appName :: String +appName = "swiss-army-knife" + +configDir :: IO FilePath +configDir = getXdgDirectory XdgConfig appName + +configFile :: IO FilePath +configFile = ( "config.yaml") <$> configDir + +-- | Whole config file as a raw JSON object, cached after first load so +-- repeated getKnifeConfig calls in one run don't re-hit disk. +{-# NOINLINE configCache #-} +configCache :: IORef (Maybe Value) +configCache = unsafePerformIO (newIORef Nothing) + +loadRawConfig :: IO Value +loadRawConfig = do + dir <- configDir + file <- configFile + createDirectoryIfMissing True dir + exists <- doesFileExist file + if not exists + then pure (Object KM.empty) + else do + result <- decodeFileEither file + case result of + Right val -> pure val + Left err -> do + hPutStrLn stderr $ + "Warning: failed to parse " <> file <> ": " + <> prettyPrintParseException err + hPutStrLn stderr "Starting from an empty configuration." + pure (Object KM.empty) + +getRawConfig :: IO Value +getRawConfig = do + cached <- readIORef configCache + case cached of + Just v -> pure v + Nothing -> do + v <- loadRawConfig + writeIORef configCache (Just v) + pure v + +persistRawConfig :: Value -> IO () +persistRawConfig v = do + file <- configFile + encodeFile file v + writeIORef configCache (Just v) + +-- | Get a knife's own config section, identified by a unique key +-- (e.g. "wireguard", "zfscheck"). If the section is missing, or fails +-- to parse as that knife's type, the given default is written into +-- the file under that key — leaving every other knife's section +-- untouched — and returned. +getKnifeConfig :: (FromJSON a, ToJSON a) => Text -> a -> IO a +getKnifeConfig key def = do + raw <- getRawConfig + case raw of + Object obj -> + case KM.lookup (fromText key) obj of + Just v -> case fromJSON v of + Success a -> pure a + Error err -> do + hPutStrLn stderr $ + "Warning: config section \"" <> T.unpack key + <> "\" is invalid: " <> err + hPutStrLn stderr "Using defaults for this section." + writeDefault obj + Nothing -> writeDefault obj + _ -> writeDefault KM.empty + where + writeDefault obj = do + let obj' = KM.insert (fromText key) (toJSON def) obj + persistRawConfig (Object obj') + pure def + +-- | Unconditionally write a knife's config section, overwriting +-- whatever was there before. Use this for knife operations that +-- explicitly mutate config (add/delete/set-default), as opposed to +-- getKnifeConfig's "read, or seed with defaults on first use." +setKnifeConfig :: ToJSON a => Text -> a -> IO () +setKnifeConfig key val = do + raw <- getRawConfig + let obj = case raw of + Object o -> o + _ -> KM.empty + obj' = KM.insert (fromText key) (toJSON val) obj + persistRawConfig (Object obj') diff --git a/lib/Knives/Gitit.hs b/lib/Knives/Gitit.hs new file mode 100644 --- /dev/null +++ b/lib/Knives/Gitit.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedRecordDot #-} + +{-| +Module : Knives.Gitit +Description : Create remote for local git repo +Maintainer : fred.mitchell@atomlogik.de + +For a locally defined git repo, create the remote version and +move push it there. +-} + +module Knives.Gitit where + +import Config ( getKnifeConfig ) +import System.Process () +import CommandLine ( GititCommand(..) ) +import Knives.Gitit.Yaml +import Knives.Gitit.Target +import Knives.Gitit.Repo +import Utils () + +-- | Dispatch on the gitit sub-command. +knifeGitit :: GititCommand -> IO () +knifeGitit cmd = do + cfg <- getKnifeConfig "gitit" defaultGititConfig + _ <- case cmd of + GititList -> listTarget cfg + GititAdd target remote location -> addTarget cfg target remote location + GititDelete name -> deleteTarget cfg name + GititDefault name -> setDefaultTarget cfg name + GititCreate kind name remote -> createRepo cfg kind name remote + pure () + +-- >>> getKnifeConfig "gitit" defaultGititConfig +-- GititConfig {targets = [Target {name = "origin", kind = Local, path = "/repo"},Target {name = "github", kind = GitHub, path = "git@github.com:flajann2"},Target {name = "gitlab", kind = GitLab, path = "git@gitlab.com:eltoro-maestro"},Target {name = "bitbucket", kind = Bitbucket, path = "git@bitbucket.org:eltoro-maestro"}], defaultTarget = Nothing} diff --git a/lib/Knives/Gitit/Repo.hs b/lib/Knives/Gitit/Repo.hs new file mode 100644 --- /dev/null +++ b/lib/Knives/Gitit/Repo.hs @@ -0,0 +1,368 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiWayIf #-} + +{-| +Module : Knives.Gitit.Repo +Description : Repo creation and manipulation +Maintainer : fred.mitchell@atomlogik.de + +Deals with repo maitenance for the various +collections like Local, GitHub, Gitlab, etc. +-} + +module Knives.Gitit.Repo where + +import Data.Aeson.Types (Parser, parseMaybe) +import Control.Applicative ((<|>)) +import qualified Data.ByteString.Lazy.Char8 as BL +import qualified Data.Text as T +import Network.HTTP.Simple +import qualified Data.ByteString.Char8 as B +import System.Process (CreateProcess(..) + , proc + , readCreateProcessWithExitCode + , readProcess) +import System.Environment (lookupEnv) +import System.Exit (ExitCode(..)) +import System.Directory ( doesFileExist + , doesDirectoryExist + , createDirectory + , makeAbsolute) +import Data.List (find) +import Data.Char (isSpace, toLower) +import Data.Maybe (fromMaybe) +-- import Config ( getKnifeConfig, setKnifeConfig ) +-- import CommandLine ( GititCommand(..) ) +import Data.Aeson + ( withObject + , object + , (.:) + , (.:?) + , Value(..) + , decode + , encode + , KeyValue((.=)) ) +import Control.Exception (try, SomeException) +-- import Control.Monad (when) +import Utils () +-- import Control.Monad.Extra (whenJust) +import System.IO (hPutStrLn, stderr) +import Knives.Gitit.Yaml + +-- | "sak gitit list" -- list all targets +listTarget :: GititConfig -> IO () +listTarget cfg = putStrLn $ unlines [t.name <> " - " <> show t.kind | t <- cfg.targets] + + +-- | Look up a target by its name. +findTarget :: GititConfig -> String -> Maybe Target +findTarget cfg n = find (\t -> t.name == n) cfg.targets + + +data PathKind = IsFile | IsDir | Missing + deriving (Show, Eq) + +pathKind :: FilePath -> IO PathKind +pathKind p = do + isFile <- doesFileExist p + isDir <- doesDirectoryExist p + pure $ if | isFile -> IsFile + | isDir -> IsDir + | otherwise -> Missing + +trim :: [Char] -> [Char] +trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace + +-- | An environment variable, treating "" as unset. +nonEmptyEnv :: String -> IO (Maybe String) +nonEmptyEnv v = do + e <- lookupEnv v + pure $ case e of + Just s | not (null s) -> Just s + _ -> Nothing + +-- | Token from an env var, falling back to a CLI command's output. +tokenFrom :: String -> String -> [String] -> IO (Maybe B.ByteString) +tokenFrom var cmd args = do + env <- nonEmptyEnv var + case env of + Just t -> pure (Just (B.pack t)) + Nothing -> do + r <- try (readProcess cmd args "") :: IO (Either SomeException String) + pure $ case r of + Right out | let t = trim out, not (null t) -> Just (B.pack t) + _ -> Nothing + +-- | fetches the GITHUB_TOKEN environment variable, or derives it from gh +githubToken :: IO (Maybe B.ByteString) +githubToken = tokenFrom "GITHUB_TOKEN" "gh" ["auth", "token"] + +-- | GitLab host; honours GITLAB_HOST (same variable glab uses) for self-hosted instances. +gitlabHost :: IO String +gitlabHost = fromMaybe "gitlab.com" <$> nonEmptyEnv "GITLAB_HOST" + +-- | fetches GITLAB_TOKEN, or derives it from glab's config +gitlabToken :: String -> IO (Maybe B.ByteString) +gitlabToken host = tokenFrom "GITLAB_TOKEN" "glab" ["config", "get", "token", "--host", host] + +-- | Pull a human-readable error out of a forge's JSON error body. +-- Bitbucket: {"error": {"message": ...}} +-- GitHub: {"message": ..., "errors": [...]} +-- GitLab: {"message": ...} (message may be a string, object or list) +apiMessage :: Value -> Maybe String +apiMessage = parseMaybe $ withObject "error body" $ \o -> bitbucket o <|> plain o + where + bitbucket o = (o .: "error") >>= withObject "error" (.: "message") + plain o = do + m <- o .: "message" :: Parser Value + errs <- o .:? "errors" :: Parser (Maybe Value) + pure $ render m <> maybe "" (\e -> " " <> render e) errs + render (String t) = T.unpack t + render v = BL.unpack (encode v) + +-- | Explain an HTTP failure; falls back to a status-based hint when the +-- body is empty (Bitbucket sends a bare 401 for bad credentials). +describeFailure :: Int -> BL.ByteString -> String +describeFailure code body = case decode body >>= apiMessage of + Just m -> m + Nothing + | not (BL.null body) -> BL.unpack body + | code == 401 -> "authentication failed (check the token and, for Bitbucket, the email)" + | code == 403 -> "permission denied (the token lacks the needed scopes or rights)" + | otherwise -> "empty response" + +-- | Send an API request without ever throwing: network errors, non-2xx +-- statuses and unparseable bodies are all reported on stderr. +apiCall :: String -> Request -> IO (Maybe Value) +apiCall site req = do + r <- try (httpLBS req) :: IO (Either HttpException (Response BL.ByteString)) + case r of + Left e -> Nothing <$ hPutStrLn stderr ("gitit: " <> site <> " request failed: " <> show e) + Right resp -> do + let code = getResponseStatusCode resp + body = getResponseBody resp + if code >= 200 && code < 300 + then case decode body of + Just v -> pure (Just v) + Nothing -> Nothing <$ hPutStrLn stderr + ("gitit: " <> site <> " returned HTTP " <> show code <> " with a non-JSON body") + else Nothing <$ hPutStrLn stderr + ("gitit: " <> site <> " API error (HTTP " <> show code <> "): " <> describeFailure code body) + +-- | Return the extracted URL, or report the API's response on stderr. +extractOr :: String -> (Value -> Maybe String) -> Value -> IO (Maybe String) +extractOr site f v = case f v of + Just u -> pure (Just u) + Nothing -> Nothing <$ hPutStrLn stderr ("gitit: " <> site <> " API error: " <> BL.unpack (encode v)) + +-- | Bitbucket returns clone URLs as links.clone = [{name, href}, ...] +bitbucketSshUrl :: Value -> Maybe String +bitbucketSshUrl = parseMaybe $ withObject "repo" $ \o -> do + clones <- (o .: "links") >>= (.: "clone") + pairs <- mapM (withObject "clone" (\c -> (,) <$> c .: "name" <*> c .: "href")) clones + maybe (fail "no ssh clone link") pure (lookup ("ssh" :: String) pairs) + +-- Local repo / remote handling --------------------------------------------- + +-- | Which front-end manages the repo in the current directory. +-- jj is preferred when present, since it also covers colocated repos +-- (where it writes the remote through to .git/config). +data LocalVcs = Jj | Git + deriving (Show, Eq) + +-- | Run a command, never throwing: a missing executable shows up as +-- exit code 127 with the exception text on stderr. +runQuiet :: String -> [String] -> IO (ExitCode, String, String) +runQuiet cmd args = do + r <- try (readCreateProcessWithExitCode (proc cmd args) "") + :: IO (Either SomeException (ExitCode, String, String)) + pure $ either (\e -> (ExitFailure 127, "", show e)) id r + +-- | Find the VCS for the current directory, if we are inside a repo at all. +detectVcs :: IO (Maybe LocalVcs) +detectVcs = do + (jc, _, _) <- runQuiet "jj" ["root"] + if jc == ExitSuccess + then pure (Just Jj) + else do + (gc, out, _) <- runQuiet "git" ["rev-parse", "--is-inside-work-tree"] + pure $ if gc == ExitSuccess && trim out == "true" then Just Git else Nothing + +-- | Does the local repo already have a remote with this name? +remoteExists :: LocalVcs -> String -> IO Bool +remoteExists Git n = (\(c, _, _) -> c == ExitSuccess) <$> runQuiet "git" ["remote", "get-url", n] +remoteExists Jj n = do + (c, out, _) <- runQuiet "jj" ["git", "remote", "list"] + pure $ c == ExitSuccess && any ((== [n]) . take 1 . words) (lines out) + +-- | The command that registers a remote, for running and for printing. +remoteAddCmd :: LocalVcs -> String -> String -> (String, [String]) +remoteAddCmd Git n url = ("git", ["remote", "add", n, url]) +remoteAddCmd Jj n url = ("jj", ["git", "remote", "add", n, url]) + +showCmd :: (String, [String]) -> String +showCmd (c, xs) = unwords (c : xs) + +-- | Check, before anything is created remotely, that the remote can be +-- added afterwards. Returns the VCS to use, or reports why not. +preflightRemote :: String -> IO (Maybe LocalVcs) +preflightRemote n = do + mvcs <- detectVcs + case mvcs of + Nothing -> Nothing <$ hPutStrLn stderr + "gitit: --add-remote given, but the current directory is not inside a git or jj repo" + Just vcs -> do + taken <- remoteExists vcs n + if taken + then Nothing <$ hPutStrLn stderr + ("gitit: the local repo already has a remote named " <> n + <> " (choose another with --remote-name NAME)") + else pure (Just vcs) + +-- | Register the newly-created repo as a remote of the local one. +addLocalRemote :: LocalVcs -> String -> String -> IO () +addLocalRemote vcs n url = do + let c@(cmd, args) = remoteAddCmd vcs n url + (code, _out, err) <- runQuiet cmd args + case code of + ExitSuccess -> putStrLn $ " Added remote " <> n <> " -> " <> url + ExitFailure k -> do + hPutStrLn stderr $ "gitit: adding the remote failed (" <> show k <> "): " <> trim err + hPutStrLn stderr $ " The repo was created; add it by hand with: " <> showCmd c + +-- | "sak gitit create TARGET REPONAME [-r | -n NAME]" - create a repo in the +-- specified target, optionally registering it as a remote of the current repo. +createRepo :: GititConfig -> String -> String -> Maybe String -> IO () +createRepo cfg t r mRemote = case mRemote of + Nothing -> create Nothing + Just n -> preflightRemote n >>= maybe (putStrLn "failed") (\vcs -> create (Just (vcs, n))) + where + create mAdd = do + result <- createRepo' cfg t r + case result of + Nothing -> putStrLn "failed" + Just url -> do + putStrLn "" + putStrLn $ " Creation of " <> url <> " worked." + case mAdd of + Just (vcs, n) -> addLocalRemote vcs n url + Nothing -> do + putStrLn " To add this remote to your local repo, execute:" + putStrLn $ " git remote add " <> t <> " " <> url + putStrLn " or rerun with --add-remote (-r) to have gitit do it." + + +createRepo' :: GititConfig -> String -> String -> IO (Maybe String) +createRepo' cfg targetName repoName = + case findTarget cfg targetName of + Nothing -> Nothing <$ hPutStrLn stderr ("No target named " <> targetName) + Just t -> case t.kind of + Local -> createLocal t repoName + GitHub -> createGitHub t repoName + GitLab -> createGitLab t repoName + Bitbucket -> createBitbucket t repoName + where + createLocal + , createGitHub + , createGitLab + , createBitbucket :: Target -> String -> IO (Maybe String) + + -- Local ---------------------------------------------------------------- + + createLocal t n = do + -- absolute, so the URL still works as a remote from any directory + repo <- makeAbsolute (t.path <> "/" <> n <> ".git") + pk <- pathKind repo + case pk of + Missing -> initRepo repo + IsFile -> Nothing <$ hPutStrLn stderr (repo <> " already exists and is a file.") + IsDir -> Nothing <$ hPutStrLn stderr (repo <> " already exists.") + + initRepo repo = do + putStrLn $ "Creating new repo " <> repo + createDirectory repo + (code + , _out + , err) <- readCreateProcessWithExitCode ((proc "git" ["init", "--bare"]) { cwd = Just repo }) "" + case code of + ExitSuccess -> do + putStrLn $ "Initialized bare repo at " <> repo + return $ Just repo + ExitFailure n -> do + hPutStrLn stderr $ "git init failed (" <> show n <> "): " <> err + return Nothing + + -- GitHub --------------------------------------------------------------- + + createGitHub _t n = do + mtok <- githubToken + case mtok of + Nothing -> Nothing <$ hPutStrLn stderr + "gitit: no GitHub token (set GITHUB_TOKEN or run `gh auth login`)" + Just tok -> do + res <- createGitHub' tok n False + maybe (pure Nothing) (extractOr "GitHub" (parseMaybe (withObject "repo" (.: "ssh_url")))) res + + createGitHub' :: B.ByteString -> String -> Bool -> IO (Maybe Value) + createGitHub' token name priv = do + let req = setRequestMethod "POST" + $ setRequestHeader "Authorization" ["Bearer " <> token] + $ setRequestHeader "Accept" ["application/vnd.github+json"] + $ setRequestHeader "X-GitHub-Api-Version" ["2022-11-28"] + $ setRequestHeader "User-Agent" ["swiss-army-knife-gitit"] -- GitHub rejects requests without one + $ setRequestBodyJSON (object [ "name" .= name + , "private" .= priv ]) + $ "https://api.github.com/user/repos" + apiCall "GitHub" req + + -- GitLab --------------------------------------------------------------- + + createGitLab _t n = do + host <- gitlabHost + mtok <- gitlabToken host + case mtok of + Nothing -> Nothing <$ hPutStrLn stderr + "gitit: no GitLab token (set GITLAB_TOKEN or run `glab auth login`)" + Just tok -> do + res <- createGitLab' host tok n False + maybe (pure Nothing) (extractOr "GitLab" (parseMaybe (withObject "project" (.: "ssh_url_to_repo")))) res + + createGitLab' :: String -> B.ByteString -> String -> Bool -> IO (Maybe Value) + createGitLab' host token name priv = do + let vis = if priv then "private" else "public" :: String + req = setRequestHeader "PRIVATE-TOKEN" [token] + $ setRequestHeader "User-Agent" ["swiss-army-knife-gitit"] + $ setRequestBodyJSON (object [ "name" .= name + , "path" .= name + , "visibility" .= vis ]) + $ parseRequest_ ("POST https://" <> host <> "/api/v4/projects") + apiCall "GitLab" req + + -- Bitbucket ------------------------------------------------------------ + + createBitbucket _t n = do + mws <- nonEmptyEnv "BITBUCKET_WORKSPACE" + mem <- nonEmptyEnv "BITBUCKET_EMAIL" + mtok <- nonEmptyEnv "BITBUCKET_TOKEN" + mprj <- nonEmptyEnv "BITBUCKET_PROJECT" -- optional project key + case (,,) <$> mws <*> mem <*> mtok of + Nothing -> Nothing <$ hPutStrLn stderr + "gitit: Bitbucket needs BITBUCKET_WORKSPACE, BITBUCKET_EMAIL and BITBUCKET_TOKEN" + Just (ws, em, tok) -> do + res <- createBitbucket' ws em tok mprj n False + maybe (pure Nothing) (extractOr "Bitbucket" bitbucketSshUrl) res + + -- Every Bitbucket repo belongs to a project. Without one, Bitbucket + -- uses the workspace's default project, which may not allow creation. + createBitbucket' :: String -> String -> String -> Maybe String -> String -> Bool -> IO (Maybe Value) + createBitbucket' ws email token mProject name priv = do + let slug = map toLower name -- Bitbucket slugs are lowercase + req = setRequestBasicAuth (B.pack email) (B.pack token) + $ setRequestHeader "User-Agent" ["swiss-army-knife-gitit"] + $ setRequestBodyJSON (object ( [ "scm" .= ("git" :: String) + , "is_private" .= priv ] + <> maybe [] (\k -> [ "project" .= object [ "key" .= k ] ]) mProject )) + $ parseRequest_ ( "POST https://api.bitbucket.org/2.0/repositories/" + <> ws <> "/" <> slug ) + apiCall "Bitbucket" req diff --git a/lib/Knives/Gitit/Target.hs b/lib/Knives/Gitit/Target.hs new file mode 100644 --- /dev/null +++ b/lib/Knives/Gitit/Target.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE MultiWayIf #-} + +{-| +Module : Knives.Gitit.Target +Description : Create remote for local git repo +Maintainer : fred.mitchell@atomlogik.de + +The data amd Yaml support. +-} + +module Knives.Gitit.Target where + +import Network.HTTP.Simple () +import System.Directory () +import Config ( setKnifeConfig ) +import System.Process () +import Data.Aeson () +import Utils () +import System.IO (hPutStrLn, stderr) +import Knives.Gitit.Yaml + +parseKind :: String -> Maybe TargetKind +parseKind "local" = Just Local +parseKind "github" = Just GitHub +parseKind "gitlab" = Just GitLab +parseKind "bitbucket" = Just Bitbucket +parseKind _ = Nothing + +-- | "sak gitit add KIND REMOTE LOCATION" — register a new target. +-- Rejects a duplicate name and an unrecognized kind rather than +-- silently overwriting or storing garbage. +addTarget :: GititConfig -> String -> String -> String -> IO () +addTarget cfg kind remote location = case parseKind kind of + Nothing -> hPutStrLn stderr ("Unknown kind: " <> kind) + Just k + | any ((== remote) . name) (targets cfg) -> + hPutStrLn stderr ("A target named " <> remote <> " already exists") + | otherwise -> do + let newTarget = Target { name = remote + , kind = k + , path = location } + cfg' = cfg { targets = targets cfg <> [newTarget] } + setKnifeConfig "gitit" cfg' + putStrLn ("Added target " <> remote) + +-- | "sak gitit delete NAME" — remove a target by name. Also clears +-- defaultTarget if it pointed at the one being deleted, so the +-- config never references a target that no longer exists. +deleteTarget :: GititConfig -> String -> IO () +deleteTarget cfg nameArg + | not (any ((== nameArg) . name) (targets cfg)) = + hPutStrLn stderr ("No target named " <> nameArg) + | otherwise = do + let remaining = filter ((/= nameArg) . name) (targets cfg) + newDefault + | defaultTarget cfg == Just nameArg = Nothing + | otherwise = defaultTarget cfg + cfg' = cfg { targets = remaining, defaultTarget = newDefault } + setKnifeConfig "gitit" cfg' + putStrLn ("Deleted target " <> nameArg) + +-- | "sak gitit default NAME" — set which target other commands use +-- when no explicit target/kind is given. Requires the name to +-- already exist, so defaultTarget can never point at nothing. +setDefaultTarget :: GititConfig -> String -> IO () +setDefaultTarget cfg nameArg + | not (any ((== nameArg) . name) (targets cfg)) = + hPutStrLn stderr ("No target named " <> nameArg <> "; add it first") + | otherwise = do + let cfg' = cfg { defaultTarget = Just nameArg } + setKnifeConfig "gitit" cfg' + putStrLn ("Default target set to " <> nameArg) + + diff --git a/lib/Knives/Gitit/Yaml.hs b/lib/Knives/Gitit/Yaml.hs new file mode 100644 --- /dev/null +++ b/lib/Knives/Gitit/Yaml.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedRecordDot #-} + +{-| +Module : Knives.Gitit.Yaml +Description : Create remote for local git repo +Maintainer : fred.mitchell@atomlogik.de + +The data amd Yaml support. +-} + +module Knives.Gitit.Yaml where + +import System.Process () +import Data.Aeson + ( FromJSON(..) + , ToJSON(..) + , withObject + , withText + , object + , (.:) + , (.:?) + , (.!=) + , (.=) + ) +import GHC.Generics (Generic) +import Utils () + + +-- | What kind of Git host a target points to. Determines how +-- knifeGitit talks to it (bare-repo creation locally vs. API/URL +-- handling for a forge). +data TargetKind + = Local + | GitHub + | GitLab + | Bitbucket + deriving (Show, Eq, Generic) + +instance FromJSON TargetKind where + parseJSON = withText "TargetKind" $ \t -> case t of + "local" -> pure Local + "github" -> pure GitHub + "gitlab" -> pure GitLab + "bitbucket" -> pure Bitbucket + other -> fail ("Unknown target kind: " <> show other) + +instance ToJSON TargetKind where + toJSON Local = "local" + toJSON GitHub = "github" + toJSON GitLab = "gitlab" + toJSON Bitbucket = "bitbucket" + +-- | A single push destination: a name the user picks (mirroring +-- Git's own "origin"/"upstream" convention), what kind of host it +-- is, and either a local path or a remote URL. +data Target = Target + { name :: String -- ^ this should be remote, as in name of the remote + , kind :: TargetKind -- ^ name of the target, local, github, etc. + , path :: String -- ^ if kind is Local, this is a directory path. kind is anything else, this is a URL + } deriving (Show, Generic) + +instance FromJSON Target where + parseJSON = withObject "Target" $ \v -> Target + <$> v .: "name" + <*> v .: "kind" + <*> v .: "path" + +instance ToJSON Target where + toJSON t = object + [ "name" .= name t + , "kind" .= kind t + , "path" .= path t + ] + +data GititConfig = GititConfig + { targets :: [Target] + , defaultTarget :: Maybe String + } deriving (Show, Generic) + +instance FromJSON GititConfig where + parseJSON = withObject "GititConfig" $ \v -> + GititConfig + <$> v .:? "targets" .!= targets defaultGititConfig + <*> v .:? "defaultTarget" .!= defaultTarget defaultGititConfig + +instance ToJSON GititConfig where + toJSON cfg = object + [ "targets" .= targets cfg + , "defaultTarget" .= defaultTarget cfg + ] + +defaultGititConfig :: GititConfig +defaultGititConfig = GititConfig + { targets = [ Target { name = "origin" + , kind = Local + , path = "/repo" + } + ] + , defaultTarget = Nothing + } diff --git a/lib/Knives/SysNet.hs b/lib/Knives/SysNet.hs --- a/lib/Knives/SysNet.hs +++ b/lib/Knives/SysNet.hs @@ -9,7 +9,7 @@ , enableSN , deactivateSN , disableSN - , reactivateSN} + , reactivateSN } | isExclusiveOr [ activateSN , enableSN , deactivateSN diff --git a/lib/Knives/ZfsCheck.hs b/lib/Knives/ZfsCheck.hs --- a/lib/Knives/ZfsCheck.hs +++ b/lib/Knives/ZfsCheck.hs @@ -1,44 +1,120 @@ - -module Knives.ZfsCheck where +module Knives.ZfsCheck + ( knifeZfsCheck + ) where -import CommandLine +import CommandLine (ZfsCheckOptions(..)) +import Control.Applicative ((<|>)) +import Control.Exception (IOException, try) +import Data.Char (isDigit, isSpace) +import Data.List (dropWhileEnd, stripPrefix) import Data.List.Split (splitOn) -import Data.Char (isSpace) -import Data.List (isInfixOf) -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Lazy.Char8 as LBS8 -import System.Process - +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) +import System.Directory (doesFileExist) +import System.Exit (ExitCode(..)) +import System.Process (readProcessWithExitCode) +-- | Decide whether the kernel in the Arch repo can be installed without +-- losing ZFS. +-- +-- The kernel ceiling has to come from the OpenZFS release that archzfs +-- would actually install, not from OpenZFS master: master's META always +-- advertises the newest kernel the developers are targeting, which can be +-- far ahead of what any packaged release supports. knifeZfsCheck :: ZfsCheckOptions -> IO () -knifeZfsCheck _ = do - putStrLn $ "Check the version of archzfs with repo kernel version so you can determine if an upgrade is possible." +knifeZfsCheck opts = do + putStrLn "Check whether archzfs supports the repo kernel, so you can determine if an upgrade is possible." - let url_zfs = "https://raw.githubusercontent.com/openzfs/zfs/master/META" + repoKernel <- (>>= field "Version") <$> pkgInfo "linux" + running <- maybe "?" trim <$> run "uname" ["-r"] + installed <- maybe "?" (unwords . drop 1 . words) <$> run "pacman" ["-Q", "linux"] - repo_version <- readProcess "pacman" ["-Si", "linux"] "" -- | awk '/^Version/ { print $3 }'" "" - archzfs_version <- readProcess "curl" ["-sSL", url_zfs] "" - skernel <- readProcess "uname" ["-r"] "" - sinstalled <- readProcess "pacman" ["-Q", "linux"] "" + -- The ZFS release the repos would give you (DKMS route first, then utils). + dkmsInfo <- pkgInfo "zfs-dkms" + utilsInfo <- pkgInfo "zfs-utils" + let zfsVer = takeWhile (/= '-') <$> ((dkmsInfo <|> utilsInfo) >>= field "Version") - let repo = splitAndTrim - $ LBS8.unpack - $ head [v | v <- LBS8.lines (LBS8.pack repo_version), (LBS8.pack "Version") `LBS.isPrefixOf` v] - archzfs = splitAndTrim - $ LBS8.unpack - $ head [v | v <- LBS8.lines (LBS8.pack archzfs_version), (LBS8.pack "Linux-Maximum:") `LBS.isPrefixOf` v] - running = trim skernel - installed = unwords - $ filter (not . ("linux" `isInfixOf`)) - $ words - $ trim sinstalled + meta <- maybe (pure Nothing) zfsMeta zfsVer + let linuxMax = meta >>= field "Linux-Maximum" . snd - putStrLn $ "\n repo: " ++ repo - ++ "\n zfs: " ++ archzfs - ++ "\n running: " ++ running - ++ "\n installed: " ++ installed + -- Prebuilt modules are pinned to one exact kernel build. + prebuiltKernel <- (>>= linuxDep) <$> pkgInfo "zfs-linux" + let dkmsOk = (<=) <$> (repoKernel >>= majorMinor) <*> (linuxMax >>= majorMinor) + prebuiltOk = (==) <$> repoKernel <*> prebuiltKernel + + putStrLn $ "\n repo kernel: " ++ orQ repoKernel + ++ "\n running: " ++ running + ++ "\n installed: " ++ installed + ++ "\n zfs (repo/dkms): " ++ orQ zfsVer + ++ maybe "" (\m -> " (supports Linux up to " ++ m ++ ")") linuxMax + ++ "\nzfs-linux targets: " ++ fromMaybe "(not available)" prebuiltKernel + + putStrLn $ "\n DKMS route: " ++ verdict dkmsOk + ++ "\n Prebuilt route: " ++ verdict prebuiltOk + + case (dkmsOk, prebuiltOk) of + (Just True, _) -> putStrLn "\nUpgrade possible: install linux, linux-headers and the ZFS packages in one transaction." + (_, Just True) -> putStrLn "\nUpgrade possible via zfs-linux (exact kernel match)." + _ -> putStrLn "\nDo NOT upgrade the kernel: no available ZFS package supports it yet." + + if full opts + then putStrLn $ "\nKernel ceiling read from: " ++ maybe "(none)" fst meta + else pure () + where - splitAndTrim line = trim $ last $ splitOn ":" line - trim = f . f - where f = reverse . dropWhile isSpace + orQ = fromMaybe "?" + verdict (Just True) = "OK" + verdict (Just False) = "NO" + verdict Nothing = "unknown (missing data)" + +-- | @pacman -Si pkg@, or Nothing if the package isn't in any repo. +pkgInfo :: String -> IO (Maybe String) +pkgInfo pkg = run "pacman" ["-Si", pkg] + +-- | META of the given OpenZFS release, with where it came from. +-- Uses the locally installed DKMS source when it matches, otherwise the +-- release tag on GitHub. +zfsMeta :: String -> IO (Maybe (String, String)) +zfsMeta ver = do + let local = "/usr/src/zfs-" ++ ver ++ "/META" + url = "https://raw.githubusercontent.com/openzfs/zfs/zfs-" ++ ver ++ "/META" + haveLocal <- doesFileExist local + if haveLocal + then Just . (,) local <$> readFile local + else fmap ((,) url) <$> run "curl" ["-fsSL", url] + +-- | Run a command; Nothing on a non-zero exit or if it can't be started. +run :: String -> [String] -> IO (Maybe String) +run cmd args = do + r <- try @IOException (readProcessWithExitCode cmd args "") + pure $ case r of + Right (ExitSuccess, out, _) -> Just out + _ -> Nothing + +-- | Value of a @Name : value@ field (pacman -Si and META style), +-- joining pacman's indented continuation lines. +field :: String -> String -> Maybe String +field name = go . lines + where + go [] = Nothing + go (l:ls) = case stripPrefix name l of + Just rest + | (pre, ':':v) <- break (== ':') rest + , all isSpace pre -> + let cont = takeWhile (any isSpace . take 1) ls + in Just (trim (unwords (map trim (v : cont)))) + _ -> go ls + +-- | The @linux=VERSION@ constraint from a package's dependencies. +linuxDep :: String -> Maybe String +linuxDep info = field "Depends On" info + >>= listToMaybe . mapMaybe (stripPrefix "linux=") . words + +-- | Major and minor version: "7.2.11.arch1-1" -> (7, 2), "6.15" -> (6, 15). +majorMinor :: String -> Maybe (Int, Int) +majorMinor v = case splitOn "." (takeWhile (\c -> isDigit c || c == '.') v) of + (a:b:_) | not (null a), not (null b) -> Just (read a, read b) + _ -> Nothing + +trim :: String -> String +trim = dropWhileEnd isSpace . dropWhile isSpace diff --git a/lib/Utils.hs b/lib/Utils.hs --- a/lib/Utils.hs +++ b/lib/Utils.hs @@ -1,32 +1,50 @@ +{-| +Module : Utils +Description : Core utiities to interact with Linux +Maintainer : fred.mitchell@atomlogik.de + +For system commands, issue them using sudo as necessary +for priviledge esclation. User account must be set up accordingly +or will be prompted for the password on every invocation. +-} + module Utils where -import System.IO +import System.IO ( hGetContents ) import System.Process --- import System.Directory (getDirectoryContents) --- import System.FilePath (dropExtension, takeExtension) + ( createProcess + , proc + , CreateProcess(std_out) + , StdStream(CreatePipe) + ) +-- | does an exlusive or on the given list of bools. -- WARN: Cannot handle inflinite lists. isExclusiveOr :: [Bool] -> Bool isExclusiveOr bs = (length $ filter id bs) == 1 +-- | does an exlusive or on the given list of bools. +-- If none, allow for this. -- WARN: Cannot handle inflinite lists. isExclusiveOrNone :: [Bool] -> Bool isExclusiveOrNone bs = (length $ filter id bs) `elem` exorno where exorno = [0, 1] +-- | run systemctl command with parameters systemctl :: [String] -> IO [String] systemctl parms = systemG $ "sudo" : "systemctl" : parms - + +-- | run systemctl command with parameters and ignore the results systemctl_ :: [String] -> IO () systemctl_ parms = do _ <- systemG $ "sudo" : "systemctl" : parms return () +-- | execute the given list as a command. systemG :: [String] -> IO [String] systemG [] = return [] systemG (cmd:parms) = do (_, Just hout, _, _) <- createProcess (proc cmd parms) { std_out = CreatePipe } out <- hGetContents hout return $ lines out - diff --git a/playground/TConfig.hs b/playground/TConfig.hs new file mode 100644 --- /dev/null +++ b/playground/TConfig.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedRecordDot #-} + +import Config ( getKnifeConfig ) +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) + +data PlaygroundConfig = PlaygroundConfig + { list :: [String] + , name :: Maybe String + , switchit :: Bool + } deriving (Show, Generic) + +instance FromJSON PlaygroundConfig +instance ToJSON PlaygroundConfig + +defaultPlaygroundConfig :: PlaygroundConfig +defaultPlaygroundConfig = PlaygroundConfig { list = ["one", "two", "three"] + , switchit = False + , name = Just "pg-config" + } + +main :: IO () +main = do + cfg <- getKnifeConfig "playground" defaultPlaygroundConfig + putStrLn $ show cfg + pure () + +-- >>> c <- getKnifeConfig "playground" defaultPlaygroundConfig +-- >>> show $ list c +-- "[\"one\",\"two\",\"three\"]" diff --git a/swiss-army-knife.cabal b/swiss-army-knife.cabal --- a/swiss-army-knife.cabal +++ b/swiss-army-knife.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: swiss-army-knife -version: 1.1.0.5 +version: 1.2.0.0 synopsis: A collection of small tools to make life a bit easier for the command-line. category: System description: Please see the README on GitHub at @@ -27,9 +27,29 @@ type: git location: https://github.com/flajann2/swiss-army-knife +common deps + build-depends: + aeson >= 2.1 && < 2.4 + , base >= 4.18 && < 5 + , bytestring >= 0.11 && < 0.13 + , directory >= 1.3.8 && < 1.4 + , filepath >= 1.4.2 && < 1.6 + , http-conduit >= 2.3.8 && < 2.4 + , optparse-applicative >= 0.18 && < 0.20 + , process >= 1.6.18 && < 1.7 + , resolv >= 0.1.2 && < 0.3 + , split >= 0.2.5 && < 0.3 + , yaml >= 0.11 && < 0.12 + , text >= 2.0 && < 2.2 + , extra >= 1.7 && < 1.9 + default-language: GHC2021 + ghc-options: -Wall + library + import: deps exposed-modules: CommandLine + Config Utils Knives Knives.Version @@ -40,25 +60,16 @@ Knives.Kernel Knives.SysNet Knives.NetMan + Knives.Gitit + Knives.Gitit.Yaml + Knives.Gitit.Target + Knives.Gitit.Repo autogen-modules: Paths_swiss_army_knife other-modules: Paths_swiss_army_knife hs-source-dirs: lib - ghc-options: -Wall - build-depends: - aeson >= 2.1 && < 2.4 - , base >= 4.18 && < 5 - , bytestring >= 0.11 && < 0.13 - , directory >= 1.3.8 && < 1.4 - , filepath >= 1.4.2 && < 1.6 - , http-conduit >= 2.3.8 && < 2.4 - , optparse-applicative >= 0.18 && < 0.20 - , process >= 1.6.18 && < 1.7 - , resolv >= 0.1.2 && < 0.3 - , split >= 0.2.5 && < 0.3 - default-language: GHC2021 flag static description: Build a statically-linked executable (requires ghc-static, libgmp-static, and a static zlib) @@ -66,6 +77,7 @@ manual: True executable sak + import: deps main-is: SwissArmyKnife.hs autogen-modules: Paths_swiss_army_knife @@ -81,6 +93,22 @@ , optparse-applicative >= 0.18 && < 0.20 , swiss-army-knife default-language: GHC2021 + if flag(static) + ld-options: -static + +executable pg-config + import: deps + main-is: TConfig.hs + hs-source-dirs: + playground + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >= 4.18 && < 5 + , optparse-applicative >= 0.18 && < 0.20 + , swiss-army-knife + default-language: GHC2021 + if flag(static) + ld-options: -static test-suite swiss-army-knife-test type: exitcode-stdio-1.0