swiss-army-knife 1.1.0.5 → 1.2.0.0

raw patch · 15 files changed

+1412/−103 lines, 15 filesdep +extradep +textdep +yamlnew-component:exe:pg-configPVP ok

version bump matches the API change (PVP)

Dependencies added: extra, text, yaml

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• CHANGELOG.org +16/−0
• README.org +362/−42
• app/SwissArmyKnife.hs +33/−7
• lib/CommandLine.hs +81/−0
• lib/Config.hs +121/−0
• lib/Knives/Gitit.hs +36/−0
• lib/Knives/Gitit/Repo.hs +368/−0
• lib/Knives/Gitit/Target.hs +76/−0
• lib/Knives/Gitit/Yaml.hs +101/−0
• lib/Knives/SysNet.hs +1/−1
• lib/Knives/ZfsCheck.hs +110/−34
• lib/Utils.hs +23/−5
• playground/TConfig.hs +32/−0
• swiss-army-knife.cabal +42/−14

@@ -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.

@@ -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. 

@@ -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.                   |+   |                                |                                                                                                                    |+   |--------------------------------+--------------------------------------------------------------------------------------------------------------------|

@@ -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

@@ -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

@@ -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')

@@ -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}

@@ -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

@@ -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)++

@@ -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+  }

@@ -9,7 +9,7 @@                           , enableSN                           , deactivateSN                           , disableSN-                          , reactivateSN}+                          , reactivateSN }   | isExclusiveOr [ activateSN                   , enableSN                   , deactivateSN

@@ -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

@@ -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-      

@@ -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\"]"

@@ -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 <https://github.com/flajann2/swiss-army-knife#readme>@@ -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