fix typo (#1702)

* messaging for restart, shutdown, rebuild

* fix typo

* better messaging

.github/ISSUE_TEMPLATE/bug-report.yml

@@ -0,0 +1,104 @@
+name: 🐛 Bug Report
+description: Create a report to help us improve EmbassyOS
+title: '[bug]: '
+labels: [Bug, Needs Triage]
+assignees:
+  - MattDHill
+body:
+  - type: checkboxes
+    attributes:
+      label: Prerequisites
+      description: Please confirm you have completed the following.
+      options:
+        - label: I have searched for [existing issues](https://github.com/start9labs/embassy-os/issues) that already report this problem.
+          required: true
+  - type: input
+    attributes:
+      label: EmbassyOS Version
+      description: What version of EmbassyOS are you running?
+      placeholder: e.g. 0.3.0
+    validations:
+      required: true
+  - type: dropdown
+    attributes:
+      label: Device
+      description: What device are you using to connect to Embassy?
+      options:
+        - Phone/tablet
+        - Laptop/Desktop
+    validations:
+      required: true
+  - type: dropdown
+    attributes:
+      label: Device OS
+      description: What operating system is your device running?
+      options:
+        - MacOS
+        - Windows
+        - Linux
+        - iOS
+        - Android
+        - CalyxOS
+        - GrapheneOS
+        - Other
+    validations:
+      required: true
+  - type: input
+    attributes:
+      label: Device OS Version
+      description: What version is your device OS?
+    validations:
+      required: true
+  - type: dropdown
+    attributes:
+      label: Browser
+      description: What browser are you using to connect to Embassy?
+      options:
+        - Firefox
+        - Brave
+        - Tor Browser
+        - Safari
+        - Chrome
+        - Opera
+        - Edge
+        - Internet Explorer
+        - Other
+    validations:
+      required: true
+  - type: input
+    attributes:
+      label: Browser Version
+      description: What version is your browser?
+      placeholder: e.g. 94.0.2
+    validations:
+      required: true
+  - type: textarea
+    attributes:
+      label: Current Behavior
+      description: A clear description of the bug and how it manifests.
+    validations:
+      required: true
+  - type: textarea
+    attributes:
+      label: Expected Behavior
+      description: A clear description of what you expect to happen.
+    validations:
+      required: true
+  - type: textarea
+    attributes:
+      label: Steps to Reproduce
+      description: Step-by-step instructions to reproduce this behavior.
+      placeholder: |
+        1. On this page...
+        2. Click this button...
+        3. Enter this value...
+        4. See error...
+    validations:
+      required: true
+  - type: textarea
+    attributes:
+      label: Anything else?
+      description: |
+        Screenshots? Links? References? Anything that will give us more context about the issue you are encountering.
+
+        Tip: You can attach images or log files by clicking this area to highlight it and then dragging files in.

.github/ISSUE_TEMPLATE/config.yml

@@ -0,0 +1,7 @@
+contact_links:
+  - name: 📚 Documentation
+    url: https://github.com/start9labs/documentation
+    about: This issue tracker is not for documentation issues. Please file documentation issues on the Start9 Docs repo.
+  - name: 🤔 Support Question
+    url: https://t.me/start9_labs
+    about: This issue tracker is not for support questions. Please post your question in our Telegram community channel.

.github/ISSUE_TEMPLATE/feature-request.yml

@@ -0,0 +1,41 @@
+name: 💡 Feature Request
+description: Suggest an idea for EmbassyOS
+title: '[feat]: '
+labels: [Enhancement]
+assignees:
+  - MattDHill
+body:
+  - type: checkboxes
+    attributes:
+      label: Prerequisites
+      description: Please confirm you have completed the following.
+      options:
+        - label: I have searched for [existing issues](https://github.com/start9labs/embassy-os/issues) that already suggest this feature.
+          required: true
+  - type: textarea
+    attributes:
+      label: Describe the Feature Request
+      description: A clear and concise description of the feature.
+    validations:
+      required: true
+  - type: textarea
+    attributes:
+      label: Describe the Use Case
+      description: Why is this feature useful? What problem does it solve?
+    validations:
+      required: true
+  - type: textarea
+    attributes:
+      label: Describe Preferred Solution
+      description: How you want this feature added to EmbassyOS?
+  - type: textarea
+    attributes:
+      label: Describe Alternatives
+      description: Describe any alternative solutions or features you have considered.
+  - type: textarea
+    attributes:
+      label: Anything else?
+      description: |
+        Screenshots? Links? References? Anything that will give us more context about the feature you are suggesting.
+
+        Tip: You can attach images or log files by clicking this area to highlight it and then dragging files in.

.github/workflows/README.md

@@ -0,0 +1,24 @@
+# This folder contains GitHub Actions workflows for building the project
+
+## backend-pr
+Runs: when a pull request targets the master branch and changes the libs/ and/or backend/ folders
+
+This workflow uses the actions docker/setup-qemu-action@v1 and docker/setup-buildx-action@v1 to prepare the environment for aarch64 cross complilation using docker buildx.
+A matrix-strategy has been used for building the v8 snapshot instead of the makefile to allow parallel job execution.
+
+## frontend-pr
+Runs: when a pull request targets the master branch and changes the frontend/ folder
+
+This workflow builds the frontends.
+
+## product
+Runs: when a change to the master branch is made
+
+This workflow builds everything, re-using the backend-pr and frontend-pr workflows.
+The download and extraction order of artifacts is relevant to `make`, as it checks the file timestamps to decide which targets need to be executed.
+
+Result: eos.img
+
+## a note on uploading artifacts
+
+Artifacts are used to share data between jobs. File permissions are not maintained during artifact upload. Where file permissions are relevant, the workaround using tar has been used. See (here)[https://github.com/actions/upload-artifact#maintaining-file-permissions-and-case-sensitive-files].

.github/workflows/backend-pr.yaml

@@ -0,0 +1,98 @@
+name: Backend PR
+
+on:
+  workflow_call:
+  workflow_dispatch:
+
+jobs:
+  libs:
+    name: Build libs
+    strategy:
+      matrix:
+        target: [amd64, arm64]
+        include:
+          - target: amd64
+            snapshot_command: ./build-v8-snapshot.sh
+            artifact_name: js_snapshot
+            artifact_path: libs/js_engine/src/artifacts/JS_SNAPSHOT.bin
+          - target: arm64
+            snapshot_command: ./build-arm-v8-snapshot.sh
+            artifact_name: arm_js_snapshot
+            artifact_path: libs/js_engine/src/artifacts/ARM_JS_SNAPSHOT.bin
+    runs-on: ubuntu-latest
+    steps:
+    - uses: actions/checkout@v3
+      with:
+        submodules: recursive
+        
+    - name: Set up QEMU
+      uses: docker/setup-qemu-action@v1
+      
+    - name: Set up Docker Buildx        
+      uses: docker/setup-buildx-action@v1
+    
+    - uses: actions/cache@v3
+      with:
+        path: |
+          ~/.cargo/bin/
+          ~/.cargo/registry/index/
+          ~/.cargo/registry/cache/
+          ~/.cargo/git/db/
+          libs/target/
+        key: ${{ runner.os }}-cargo-libs-${{ matrix.target }}-${{ hashFiles('libs/Cargo.lock') }}
+
+    - name: Build v8 snapshot
+      run: ${{ matrix.snapshot_command }}
+      working-directory: libs
+
+    - uses: actions/upload-artifact@v3
+      with:
+        name: ${{ matrix.artifact_name }}
+        path: ${{ matrix.artifact_path }}
+
+  backend:
+    name: Build backend
+    runs-on: ubuntu-latest
+    needs: libs
+    steps:
+    - uses: actions/checkout@v3
+      with:
+        submodules: recursive
+    
+    - name: Download arm_js_snapshot artifact
+      uses: actions/download-artifact@v3
+      with:
+        name: arm_js_snapshot
+        path: libs/js_engine/src/artifacts/
+        
+    - name: Set up QEMU
+      uses: docker/setup-qemu-action@v1
+      
+    - name: Set up Docker Buildx        
+      uses: docker/setup-buildx-action@v1
+
+    - uses: actions-rs/toolchain@v1
+      with:
+        toolchain: stable
+        override: true
+    
+    - uses: actions/cache@v3
+      with:
+        path: |
+          ~/.cargo/bin/
+          ~/.cargo/registry/index/
+          ~/.cargo/registry/cache/
+          ~/.cargo/git/db/
+          backend/target/
+        key: ${{ runner.os }}-cargo-backend-${{ hashFiles('backend/Cargo.lock') }}
+
+    - name: Build backend
+      run: make backend
+
+    - name: 'Tar files to preserve file permissions'
+      run: tar -cvf backend.tar ENVIRONMENT.txt GIT_HASH.txt backend/target/aarch64-unknown-linux-gnu/release/embassy*
+
+    - uses: actions/upload-artifact@v3
+      with:
+        name: backend
+        path: backend.tar

.github/workflows/frontend-pr.yaml

@@ -0,0 +1,41 @@
+name: Frontend PR
+
+on:
+  workflow_call:
+  workflow_dispatch:
+
+jobs:
+  frontend:
+    name: Build frontend
+    runs-on: ubuntu-latest
+    steps:
+    - uses: actions/checkout@v3
+      with:
+        submodules: recursive
+
+    - uses: actions/setup-node@v3
+      with:
+        node-version: 16
+    
+    - name: Get npm cache directory
+      id: npm-cache-dir
+      run: |
+        echo "::set-output name=dir::$(npm config get cache)"
+    - uses: actions/cache@v3
+      id: npm-cache
+      with:
+        path: ${{ steps.npm-cache-dir.outputs.dir }}
+        key: ${{ runner.os }}-node-${{ hashFiles('**/package-lock.json') }}
+        restore-keys: |
+          ${{ runner.os }}-node-
+
+    - name: Build frontends
+      run: make frontends
+
+    - name: 'Tar files to preserve file permissions'
+      run: tar -cvf frontend.tar ENVIRONMENT.txt GIT_HASH.txt frontend/dist frontend/config.json
+
+    - uses: actions/upload-artifact@v3
+      with:
+        name: frontend
+        path: frontend.tar

.github/workflows/product.yaml

@@ -0,0 +1,155 @@
+name: Build Pipeline
+
+on:
+  workflow_dispatch:
+  push:
+    branches:
+    - master
+    - next
+  pull_request:
+    branches:
+    - master
+    - next
+
+jobs:
+  compat:
+    name: Build compat.tar
+    runs-on: ubuntu-latest
+    steps:
+    - uses: actions/checkout@v3
+      with:
+        submodules: recursive
+        
+    - name: Set up QEMU
+      uses: docker/setup-qemu-action@v1
+      
+    - name: Set up Docker Buildx        
+      uses: docker/setup-buildx-action@v1
+
+    - uses: actions-rs/toolchain@v1
+      with:
+        toolchain: stable
+        override: true
+
+    - uses: actions/cache@v3
+      with:
+        path: |
+          ~/.cargo/bin/
+          ~/.cargo/registry/index/
+          ~/.cargo/registry/cache/
+          ~/.cargo/git/db/
+          target/
+        key: ${{ runner.os }}-cargo-compat-${{ hashFiles('**/system-images/compat/Cargo.lock') }}
+
+    - name: Build image
+      run: make system-images/compat/compat.tar
+
+    - uses: actions/upload-artifact@v3
+      with:
+        name: compat.tar
+        path: system-images/compat/compat.tar
+
+  utils:
+    name: Build utils.tar
+    runs-on: ubuntu-latest
+    steps:
+    - uses: actions/checkout@v3
+      with:
+        submodules: recursive
+        
+    - name: Set up QEMU
+      uses: docker/setup-qemu-action@v1
+      
+    - name: Set up Docker Buildx        
+      uses: docker/setup-buildx-action@v1
+
+    - name: Build image
+      run: make system-images/utils/utils.tar
+
+    - uses: actions/upload-artifact@v3
+      with:
+        name: utils.tar
+        path: system-images/utils/utils.tar
+
+  backend:
+    uses: ./.github/workflows/backend-pr.yaml
+  
+  frontend:
+    uses: ./.github/workflows/frontend-pr.yaml
+    
+  image:
+    name: Build image
+    runs-on: ubuntu-latest
+    needs: [compat,utils,backend,frontend]
+    steps:
+    - uses: actions/checkout@v3
+      with:
+        submodules: recursive
+
+    - name: Download compat.tar artifact
+      uses: actions/download-artifact@v3
+      with:
+        name: compat.tar
+        path: system-images/compat
+    
+    - name: Download utils.tar artifact
+      uses: actions/download-artifact@v3
+      with:
+        name: utils.tar
+        path: system-images/utils
+
+    - name: Download js_snapshot artifact
+      uses: actions/download-artifact@v3
+      with:
+        name: js_snapshot
+        path: libs/js_engine/src/artifacts/
+  
+    - name: Download arm_js_snapshot artifact
+      uses: actions/download-artifact@v3
+      with:
+        name: arm_js_snapshot
+        path: libs/js_engine/src/artifacts/
+
+    - name: Download backend artifact
+      uses: actions/download-artifact@v3
+      with:
+        name: backend
+
+    - name: 'Extract backend'
+      run: 
+        tar -mxvf backend.tar
+
+    - name: Download frontend artifact
+      uses: actions/download-artifact@v3
+      with:
+        name: frontend
+
+    - name: Skip frontend build
+      run: |
+        mkdir frontend/node_modules
+        mkdir frontend/dist
+        mkdir patch-db/client/node_modules
+        mkdir patch-db/client/dist
+
+    - name: 'Extract frontend'
+      run: |
+        tar -mxvf frontend.tar frontend/config.json
+        tar -mxvf frontend.tar frontend/dist
+
+    - name: Cache raspiOS
+      id: cache-raspios
+      uses: actions/cache@v3
+      with:
+        path: raspios.img
+        key: cache-raspios
+    
+    - name: Build image
+      run: "make V=1 NO_KEY=1 eos.img --debug"
+      
+    - name: Compress image
+      run: "gzip eos.img"
+      
+    - uses: actions/upload-artifact@v3
+      with:
+        name: image
+        path: eos.img.gz

.gitignore

@@ -1,3 +1,17 @@
+.DS_Store
+.idea
 /*.img
-/buster.zip
-/product_key
+/*.img.gz
+/*.img.xz
+/*-raspios-bullseye-arm64-lite.img
+/*-raspios-bullseye-arm64-lite.zip
+/product_key.txt
+/*_product_key.txt
+.vscode/settings.json
+deploy_web.sh
+deploy_web.sh
+secrets.db
+.vscode/
+/cargo-deps/**/*
+ENVIRONMENT.txt
+GIT_HASH.txt

.gitmodules

@@ -0,0 +1,4 @@
+[submodule "patch-db"]
+	path = patch-db
+	url = https://github.com/Start9Labs/patch-db.git
+	branch = develop

CONTRIBUTING.md

@@ -19,6 +19,7 @@ All types of contributions are encouraged and valued. See the [Table of Contents
 - [I Want To Contribute](#i-want-to-contribute)
   - [Reporting Bugs](#reporting-bugs)
   - [Suggesting Enhancements](#suggesting-enhancements)
+  - [Project Structure](#project-structure)
   - [Your First Code Contribution](#your-first-code-contribution)
     - [Setting Up Your Development Environment](#setting-up-your-development-environment)
     - [Building The Image](#building-the-image)
@@ -76,8 +77,8 @@ Depending on how large the project is, you may want to outsource the questioning
 A good bug report shouldn't leave others needing to chase you up for more information. Therefore, we ask you to investigate carefully, collect information and describe the issue in detail in your report. Please complete the following steps in advance to help us fix any potential bug as fast as possible.
 
 - Make sure that you are using the latest version.
-- Determine if your bug is really a bug and not an error on your side e.g. using incompatible environment components/versions (Make sure that you have read the [documentation](https://docs.start9labs.com). If you are looking for support, you might want to check [this section](#i-have-a-question)).
-- To see if other users have experienced (and potentially already solved) the same issue you are having, check if there is not already a bug report existing for your bug or error in the [bug tracker](https://github.com/Start9Labs/embassy-osissues?q=label%3Abug).
+- Determine if your bug is really a bug and not an error on your side e.g. using incompatible environment components/versions (Make sure that you have read the [documentation](https://start9.com/latest/user-manual). If you are looking for support, you might want to check [this section](#i-have-a-question)).
+- To see if other users have experienced (and potentially already solved) the same issue you are having, check if there is not already a bug report existing for your bug or error in the [bug tracker](https://github.com/Start9Labs/embassy-os/issues?q=label%3Abug).
 - Also make sure to search the internet (including Stack Overflow) to see if users outside of the GitHub community have discussed the issue.
 - Collect information about the bug:
   - Stack trace (Traceback)
@@ -94,7 +95,7 @@ A good bug report shouldn't leave others needing to chase you up for more inform
 
 We use GitHub issues to track bugs and errors. If you run into an issue with the project:
 
-- Open an [Issue](https://github.com/Start9Labs/embassy-os/issues/new). (Since we can't be sure at this point whether it is a bug or not, we ask you not to talk about a bug yet and not to label the issue.)
+- Open an [Issue](https://github.com/Start9Labs/embassy-os/issues/new/choose) selecting the appropriate type.
 - Explain the behavior you would expect and the actual behavior.
 - Please provide as much context as possible and describe the *reproduction steps* that someone else can follow to recreate the issue on their own. This usually includes your code. For good bug reports you should isolate the problem and create a reduced test case.
 - Provide the information you collected in the previous section.
@@ -102,8 +103,8 @@ We use GitHub issues to track bugs and errors. If you run into an issue with the
 Once it's filed:
 
 - The project team will label the issue accordingly.
-- A team member will try to reproduce the issue with your provided steps. If there are no reproduction steps or no obvious way to reproduce the issue, the team will ask you for those steps and mark the issue as `needs-repro`. Bugs with the `needs-repro` tag will not be addressed until they are reproduced.
-- If the team is able to reproduce the issue, it will be marked `needs-fix`, as well as possibly other tags (such as `critical`), and the issue will be left to be [implemented by someone](#your-first-code-contribution).
+- A team member will try to reproduce the issue with your provided steps. If there are no reproduction steps or no obvious way to reproduce the issue, the team will ask you for those steps and mark the issue as `Question`. Bugs with the `Question` tag will not be addressed until they are answered.
+- If the team is able to reproduce the issue, it will be marked a scoping level tag, as well as possibly other tags (such as `Security`), and the issue will be left to be [implemented by someone](#your-first-code-contribution).
 
 <!-- You might want to create an issue template for bugs and errors that can be used as a guide and that defines the structure of the information to be included. If you do so, reference it here in the description. -->
 
@@ -116,7 +117,7 @@ This section guides you through submitting an enhancement suggestion for Embassy
 #### Before Submitting an Enhancement
 
 - Make sure that you are using the latest version.
-- Read the [documentation](https://docs.start9labs.com) carefully and find out if the functionality is already covered, maybe by an individual configuration.
+- Read the [documentation](https://start9.com/latest/user-manual) carefully and find out if the functionality is already covered, maybe by an individual configuration.
 - Perform a [search](https://github.com/Start9Labs/embassy-os/issues) to see if the enhancement has already been suggested. If it has, add a comment to the existing issue instead of opening a new one.
 - Find out whether your idea fits with the scope and aims of the project. It's up to you to make a strong case to convince the project's developers of the merits of this feature. Keep in mind that we want features that will be useful to the majority of our users and not just a small subset. If you're just targeting a minority of users, consider writing an add-on/plugin library.
 
@@ -134,100 +135,70 @@ Enhancement suggestions are tracked as [GitHub issues](https://github.com/Start9
 <!-- You might want to create an issue template for enhancement suggestions that can be used as a guide and that defines the structure of the information to be included. If you do so, reference it here in the description. -->
 
 ### Project Structure
-Embassy OS has 3 main components: `agent`, `appmgr`, and `ui`.
-- The `ui` (Typescript Ionic Angular) is the code that is deployed to the browser to provide the user interface for Embassy OS
-- The `agent` (Haskell) is a daemon that provides the interface for the `ui` to interact with the Embassy, as well as manage system state.
-- `appmgr` (Rust) is a command line utility and (soon to be) daemon that sets up and manages services and their environments.
+
+EmbassyOS is composed of the following components. Please visit the README for each component to understand the dependency requirements and installation instructions.
+- [`ui`](frontend/README.md) (Typescript Ionic Angular) is the code that is deployed to the browser to provide the user interface for EmbassyOS.
+- [`backend`](backend/README.md) (Rust) is a command line utility, daemon, and software development kit that sets up and manages services and their environments, provides the interface for the ui, manages system state, and provides utilities for packaging services for EmbassyOS.
+- `patch-db` - A diff based data store that is used to synchronize data between the front and backend.
+  - Notably, `patch-db` has a [client](https://github.com/Start9Labs/patch-db/tree/master/client) with its own dependency and installation requirements.
+- `rpc-toolkit` - A library for generating an rpc server with cli bindings from Rust functions.
+- `system-images` - (Docker, Rust) A suite of utility Docker images that are preloaded with EmbassyOS to assist with functions relating to services (eg. configuration, backups, health checks).
+- [`setup-wizard`](frontend/README.md)- Code for the user interface that is displayed during the setup and recovery process for EmbassyOS.
+- [`diagnostic-ui`](frontend/README.md) - Code for the user interface that is displayed when something has gone wrong with starting up EmbassyOS, which provides helpful debugging tools.
 
 ### Your First Code Contribution
 
-#### Setting up your development environment
-##### agent
-There are two main workflows to consider when developing on the agent. During the development process you will spend
-most of your time developing in an environment where you cannot actually run the agent. This is because we make heavy
-platform specific assumptions (by nature of the project) around what folders get used and what package management tools
-are used for the underlying system. If you are running this on a platform besides Linux you won't even be able to run
-the agent effectively on your dev machine. Even if you are on Linux you may not want to turn administrative control over
-to the software you are currently developing. So how do you know that anything you are doing is right? We make extensive
-use of Haskell's type system and surrounding tooling. For this you will want to make sure you are using the [haskell-language-server](https://github.com/haskell/haskell-language-server)
-and [stack](https://github.com/commercialhaskell/stack)
+#### Setting Up Your Development Environment
 
-At some point though you will want to build the agent for the target platform (Raspberry Pi 4). This is the second build
-flow that you will need to consider.
+First, clone the EmbassyOS repository and from the project root, pull in the submodules for dependent libraries.
 
-At Start9 we build the agent in two different ways. The primary way we have done it is on the Raspberry Pi itself. To do
-this you will need stack built for the Raspberry Pi. Unfortunately, however, FPComplete no longer
-distributes ARMv7 binaries for stack. Though hopefully soon we will be able to submit the binaries we've built for this
-project back to them and have them hosted more visibly. The way we bootstrap through this problem is by downloading version
-[2.1.3](https://github.com/commercialhaskell/stack/releases/download/v2.1.3/stack-2.1.3-linux-arm.tar.gz) and using that
-to compile v2.5.1. Before you can successfully compile anything with GHC on the Raspberry Pi. You will need to tweak the
-relevant GHC config. You will need to edit the file at `~/.stack/programs/arm-linux/ghc-8.10.2/lib/ghc-8.10.2/settings`
-and change the line `("C compiler flags", " -marm -fno-stack-protector -mcpu=cortex-a7")` to include `-mcpu=cortex-a7`.
-You will also need to make sure you've downloaded and installed LLVM 9.
+```sh
+git clone https://github.com/Start9Labs/embassy-os.git
+git submodule update --init --recursive
+```
 
-Once you have done these things, you simply need to `cd` into the embassy-os project and then run `make agent`.
-
-##### ui
-- Requirements
-  - [Install nodejs](https://nodejs.org/en/)
-  - [Install npm](https://www.npmjs.com/get-npm)
-  - [Install ionic cli](https://ionicframework.com/docs/intro/cli)
-- Scripts (run within ./ui directory)
-  - `npm i` installs ui node package dependencies
-  - `npm run build` compiles project, depositing build artifacts into ./ui/www
-  - `npm run build-prod` as above but customized for deployment to an Embassy
-  - `ionic serve` serves the ui on localhost:8100 for local development. Edit ./ui/use-mocks.json to 'true' to use mocks during local development
-  - `./build-send.sh <embassy .local address suffix>` builds the project and deploys it to the referenced Embassy
-    - Find your Embassy on the LAN using the Start9 Setup App or network tools. It's address will be of the form `start9-<suffix>.local`.
-    - For example `./build-send.sh abcdefgh` will deploy the ui to the Embassy with LAN address `start9-abcdefgh.local`.
-    - SSH keys must be installed on the Embassy prior to running this script.
-
-##### appmgr
-  - [Install Rust](https://rustup.rs)
-  - Recommended: [rust-analyzer](https://rust-analyzer.github.io/)
+Depending on which component of the ecosystem you are interested in contributing to, follow the installation requirements listed in that component's README (linked [above](#project-structure))
 
 #### Building The Image
+This step is for setting up an environment in which to test your code changes if you do not yet have a EmbassyOS.
+
 - Requirements
   - `ext4fs` (available if running on the Linux kernel)
   - [Docker](https://docs.docker.com/get-docker/)
   - GNU Make
 - Building
-  - build the [agent](#agent)
-    - make sure resulting artifact is agent/dist/agent
-  - run `make`
+  - see setup instructions [here](build/README.md)
+  - run `make` from the project root
 
 ### Improving The Documentation
-You can find the repository for Start9's documentation [here](https://github.com/Start9Labs/documentation). If there is something you would like to see added, let us know, or create an issue yourself. Welcome are contributions for lacking or incorrect information, broken links, requested additions, or general style improvements. 
+You can find the repository for Start9's documentation [here](https://github.com/Start9Labs/documentation). If there is something you would like to see added, let us know, or create an issue yourself. Welcome are contributions for lacking or incorrect information, broken links, requested additions, or general style improvements.
 
 Contributions in the form of setup guides for integrations with external applications are highly encouraged. If you struggled through a process and would like to share your steps with others, check out the docs for each [service](https://github.com/Start9Labs/documentation/blob/master/source/user-manuals/available-services/index.rst) we support. The wrapper repos contain sections for adding integration guides, such as this [one](https://github.com/Start9Labs/bitcoind-wrapper/tree/master/docs). These not only help out others in the community, but inform how we can create a more seamless and intuitive experience.
 
 ## Styleguides
 ### Formatting
-Code must be formatted with the formatter designated for each component:
-- `ui`: [tslint](https://palantir.github.io/tslint/)
-- `agent`: [brittany](https://github.com/lspitzner/brittany)
-- `appmgr`: [rustfmt](https://github.com/rust-lang/rustfmt)
+Each component of EmbassyOS contains its own style guide. Code must be formatted with the formatter designated for each component. These are outlined within each component folder's README.
 
 ### Atomic Commits
 Commits [should be atomic](https://en.wikipedia.org/wiki/Atomic_commit#Atomic_commit_convention) and diffs should be easy to read.
 Do not mix any formatting fixes or code moves with actual code changes.
 
 ### Commit Messages
-If a commit touches only 1 component, prefix the message with the affected component. i.e. `appmgr: update to tokio v0.3`.
+If a commit touches only 1 component, prefix the message with the affected component. i.e. `backend: update to tokio v0.3`.
 
 ### Pull Requests
 The body of a pull request should contain sufficient description of what the changes do, as well as a justification.
 You should include references to any relevant [issues](https://github.com/Start9Labs/embassy-os/issues).
 
 ### Rebasing Changes
-When a pull request conflicts with the target branch, you may be asked to rebase it on top of the current target branch. The git rebase command will take care of rebuilding your commits on top of the new base.
+When a pull request conflicts with the target branch, you may be asked to rebase it on top of the current target branch. The `git rebase` command will take care of rebuilding your commits on top of the new base.
 
 This project aims to have a clean git history, where code changes are only made in non-merge commits. This simplifies auditability because merge commits can be assumed to not contain arbitrary code changes.
 
 ## Join The Discussion
-Current or aspiring contributors? Join our community developer Matrix channel: `#community-dev:matrix.start9labs.com`.
+Current or aspiring contributors? Join our community developer [Matrix channel](https://matrix.to/#/#community-dev:matrix.start9labs.com).
 
-Just interested in or using the project? Join our community [Telegram](https://t.me/start9_labs) or Matrix channel: `#community:matrix.start9labs.com`.
+Just interested in or using the project? Join our community [Telegram](https://t.me/start9_labs) or [Matrix](https://matrix.to/#/#community:matrix.start9labs.com).
 
 ## Join The Project Team
 Interested in becoming a part of the Start9 Labs team? Send an email to <jobs@start9labs.com>

Makefile

@@ -1,53 +1,103 @@
-APPMGR_SRC := $(shell find appmgr/src) appmgr/Cargo.toml appmgr/Cargo.lock
-LIFELINE_SRC := $(shell find lifeline/src) lifeline/Cargo.toml lifeline/Cargo.lock
-AGENT_SRC := $(shell find agent/src) $(shell find agent/config) agent/stack.yaml agent/package.yaml agent/build.sh
-UI_SRC := $(shell find ui/src) \
-			ui/angular.json \
-			ui/browserslist \
-			ui/client-manifest.yaml \
-			ui/ionic.config.json \
-			ui/postprocess.ts \
-			ui/tsconfig.json \
-			ui/tslint.json \
-			ui/use-mocks.json
+ENVIRONMENT_FILE := $(shell ./check-environment.sh)
+GIT_HASH_FILE := $(shell ./check-git-hash.sh)
+EMBASSY_BINS := backend/target/aarch64-unknown-linux-gnu/release/embassyd backend/target/aarch64-unknown-linux-gnu/release/embassy-init backend/target/aarch64-unknown-linux-gnu/release/embassy-cli backend/target/aarch64-unknown-linux-gnu/release/embassy-sdk
+EMBASSY_UIS := frontend/dist/ui frontend/dist/setup-wizard frontend/dist/diagnostic-ui
+EMBASSY_SRC := raspios.img product_key.txt $(EMBASSY_BINS) backend/embassyd.service backend/embassy-init.service $(EMBASSY_UIS) $(shell find build)
+COMPAT_SRC := $(shell find system-images/compat/src)
+UTILS_SRC := $(shell find system-images/utils/Dockerfile)
+BACKEND_SRC := $(shell find backend/src) $(shell find patch-db/*/src) backend/Cargo.toml backend/Cargo.lock
+FRONTEND_SHARED_SRC := $(shell find frontend/projects/shared) $(shell find frontend/assets) $(shell ls -p frontend/ | grep -v / | sed 's/^/frontend\//g') frontend/node_modules frontend/config.json patch-db/client/dist
+FRONTEND_UI_SRC := $(shell find frontend/projects/ui)
+FRONTEND_SETUP_WIZARD_SRC := $(shell find frontend/projects/setup-wizard)
+FRONTEND_DIAGNOSTIC_UI_SRC := $(shell find frontend/projects/diagnostic-ui)
+PATCH_DB_CLIENT_SRC := $(shell find patch-db/client -not -path patch-db/client/dist)
+$(shell sudo true)
 
-all: embassy.img
+.DELETE_ON_ERROR:
 
-embassy.img: buster.img product_key appmgr/target/armv7-unknown-linux-gnueabihf/release/appmgr ui/www agent/dist/agent agent/config/agent.service lifeline/target/armv7-unknown-linux-gnueabihf/release/lifeline lifeline/lifeline.service setup.sh setup.service docker-daemon.json
-	sudo ./make_image.sh
+all: eos.img
 
-buster.img:
-	wget -O buster.zip https://downloads.raspberrypi.org/raspios_lite_armhf/images/raspios_lite_armhf-2020-08-24/2020-08-20-raspios-buster-armhf-lite.zip
-	unzip buster.zip
-	rm buster.zip
-	mv 2020-08-20-raspios-buster-armhf-lite.img buster.img
+gzip: eos.img
+	gzip -k eos.img
 
-product_key:
-	echo "X\c" > product_key
-	cat /dev/random | base32 | head -c11 | tr '[:upper:]' '[:lower:]' >> product_key
+clean:
+	rm -f eos.img
+	rm -f ubuntu.img
+	rm -f product_key.txt
+	rm -f system-images/**/*.tar
+	sudo rm -f $(EMBASSY_BINS)
+	rm -f frontend/config.json
+	rm -rf frontend/node_modules
+	rm -rf frontend/dist
+	rm -rf patch-db/client/node_modules
+	rm -rf patch-db/client/dist
+	sudo rm -rf cargo-deps
 
-appmgr/target/armv7-unknown-linux-gnueabihf/release/appmgr: $(APPMGR_SRC)
-	docker run --rm -it -v ~/.cargo/registry:/root/.cargo/registry -v "$(shell pwd)":/home/rust/src start9/rust-arm-cross:latest sh -c "(cd appmgr && cargo build --release --features=production)"
-	docker run --rm -it -v ~/.cargo/registry:/root/.cargo/registry -v "$(shell pwd)":/home/rust/src start9/rust-arm-cross:latest arm-linux-gnueabi-strip appmgr/target/armv7-unknown-linux-gnueabihf/release/appmgr
+sdk: 
+	cd backend/ && ./install-sdk.sh
 
-appmgr: appmgr/target/armv7-unknown-linux-gnueabihf/release/appmgr
+eos.img: $(EMBASSY_SRC) system-images/compat/compat.tar system-images/utils/utils.tar cargo-deps/aarch64-unknown-linux-gnu/release/nc-broadcast $(ENVIRONMENT_FILE) $(GIT_HASH_FILE)
+	! test -f eos.img || rm eos.img
+	if [ "$(NO_KEY)" = "1" ]; then NO_KEY=1 ./build/make-image.sh; else ./build/make-image.sh; fi
 
-agent/dist/agent: $(AGENT_SRC)
-	(cd agent && ./build.sh)
+system-images/compat/compat.tar: $(COMPAT_SRC)
+	cd system-images/compat && ./build.sh
+	cd system-images/compat && DOCKER_CLI_EXPERIMENTAL=enabled docker buildx build --tag start9/x_system/compat --platform=linux/arm64 -o type=docker,dest=compat.tar .
 
-agent: agent/dist/agent
+system-images/utils/utils.tar: $(UTILS_SRC)
+	cd system-images/utils && DOCKER_CLI_EXPERIMENTAL=enabled docker buildx build --tag start9/x_system/utils --platform=linux/arm64 -o type=docker,dest=utils.tar .
 
-ui/node_modules: ui/package.json
-	npm --prefix ui install
+raspios.img:
+	wget --continue https://downloads.raspberrypi.org/raspios_lite_arm64/images/raspios_lite_arm64-2022-01-28/2022-01-28-raspios-bullseye-arm64-lite.zip
+	unzip 2022-01-28-raspios-bullseye-arm64-lite.zip
+	mv 2022-01-28-raspios-bullseye-arm64-lite.img raspios.img
 
-ui/www: $(UI_SRC) ui/node_modules
-	npm --prefix ui run build-prod
+product_key.txt:
+	$(shell which echo) -n "X" > product_key.txt
+	cat /dev/urandom | base32 | head -c11 | tr '[:upper:]' '[:lower:]' >> product_key.txt
+	if [ "$(KEY)" != "" ]; then $(shell which echo) -n "$(KEY)" > product_key.txt; fi
+	echo >> product_key.txt
 
-ui: ui/www
+snapshots: libs/snapshot-creator/Cargo.toml
+	cd libs/  && ./build-v8-snapshot.sh
+	cd libs/  && ./build-arm-v8-snapshot.sh
 
-lifeline/target/armv7-unknown-linux-gnueabihf/release/lifeline: $(LIFELINE_SRC)
-	docker run --rm -it -v ~/.cargo/registry:/root/.cargo/registry -v "$(shell pwd)":/home/rust/src start9/rust-arm-cross:latest sh -c "(cd lifeline && cargo build --release)"
-	docker run --rm -it -v ~/.cargo/registry:/root/.cargo/registry -v "$(shell pwd)":/home/rust/src start9/rust-arm-cross:latest arm-linux-gnueabi-strip lifeline/target/armv7-unknown-linux-gnueabihf/release/lifeline
+$(EMBASSY_BINS): $(BACKEND_SRC) $(ENVIRONMENT_FILE) $(GIT_HASH_FILE)
+	cd backend && ./build-prod.sh
+	touch $(EMBASSY_BINS)
 
-lifeline: lifeline/target/armv7-unknown-linux-gnueabihf/release/lifeline
+frontend/node_modules: frontend/package.json
+	npm --prefix frontend ci
 
+frontend/dist/ui: $(FRONTEND_UI_SRC) $(FRONTEND_SHARED_SRC) $(ENVIRONMENT_FILE)
+	npm --prefix frontend run build:ui
+
+frontend/dist/setup-wizard: $(FRONTEND_SETUP_WIZARD_SRC) $(FRONTEND_SHARED_SRC) $(ENVIRONMENT_FILE)
+	npm --prefix frontend run build:setup-wizard
+
+frontend/dist/diagnostic-ui: $(FRONTEND_DIAGNOSTIC_UI_SRC) $(FRONTEND_SHARED_SRC) $(ENVIRONMENT_FILE)
+	npm --prefix frontend run build:diagnostic-ui
+
+frontend/config.json: $(GIT_HASH_FILE) frontend/config-sample.json
+	jq '.useMocks = false' frontend/config-sample.json > frontend/config.json
+	npm --prefix frontend run-script build-config
+
+patch-db/client/node_modules: patch-db/client/package.json
+	npm --prefix patch-db/client ci
+
+patch-db/client/dist: $(PATCH_DB_CLIENT_SRC) patch-db/client/node_modules
+	! test -d patch-db/client/dist || rm -rf patch-db/client/dist
+	rm -rf frontend/.angular/cache
+	npm --prefix patch-db/client run build
+
+# this is a convenience step to build all frontends - it is not referenced elsewhere in this file
+frontends: $(EMBASSY_UIS) 
+
+# this is a convenience step to build the UI
+ui: frontend/dist/ui
+
+# this is a convenience step to build the backend
+backend: $(EMBASSY_BINS)
+
+cargo-deps/aarch64-unknown-linux-gnu/release/nc-broadcast:
+	./build-cargo-dep.sh nc-broadcast

README.md

@@ -1,35 +1,49 @@
 # EmbassyOS
 [![Version](https://img.shields.io/github/v/tag/Start9Labs/embassy-os?color=success)](https://github.com/Start9Labs/embassy-os/releases)
+[![community](https://img.shields.io/badge/community-matrix-yellow)](https://matrix.to/#/#community:matrix.start9labs.com)
 [![community](https://img.shields.io/badge/community-telegram-informational)](https://t.me/start9_labs)
 [![support](https://img.shields.io/badge/support-docs-important)](https://docs.start9labs.com)
 [![developer](https://img.shields.io/badge/developer-matrix-blueviolet)](https://matrix.to/#/#community-dev:matrix.start9labs.com)
-[![website](https://img.shields.io/website?down_color=lightgrey&down_message=offline&up_color=success&up_message=online&url=https%3A%2F%2Fstart9labs.com)](https://start9labs.com)
+[![website](https://img.shields.io/website?down_color=lightgrey&down_message=offline&up_color=green&up_message=online&url=https%3A%2F%2Fstart9labs.com)](https://start9labs.com)
 
+[![mastodon](https://img.shields.io/mastodon/follow/000000001?domain=https%3A%2F%2Fmastodon.start9labs.com&label=Follow&style=social)](http://mastodon.start9labs.com)
 [![twitter](https://img.shields.io/twitter/follow/start9labs?label=Follow)](https://twitter.com/start9labs)
 
-### _Anyone can do it. No one can stop it._ ###
+### _Welcome to the era of Sovereign Computing_ ###
 
-EmbassyOS is a mass-market, graphical operating system designed to facilitate the discovery, installation, configuration, private self-hosting, and reliable operation of open-source software services and applications. It aims to eliminate trust and custodianship from personal computing.
-
-![EmbassyOS image](eos.png?w=600)
-
-## ⚠️ Caution
-Some technologies supported by this software, such as [Lightning](https://lightning.network/), are considered in active development and might experience issues. Do not commit any funds you are not willing to loose. Be #reckless at your own risk. 
+EmbassyOS is a browser-based, graphical operating system for a personal server. EmbassyOS facilitates the discovery, installation, network configuration, service configuration, data backup, dependency management, and health monitoring of self-hosted software services. It is the most advanced, secure, reliable, and user friendly personal server OS in the world.
 
 ## Running EmbassyOS
-There are multiple ways to obtain and begin using EmbassyOS.
+There are multiple ways to get your hands on EmbassyOS.
 
-### Buy an Embassy
-This is the most convenient option. Simply [buy an Embassy](https://start9labs.com) from Start9 Labs and plug it in. Depending on where you live, shipping costs and import duties may vary.
+### :moneybag: Buy an Embassy
+This is the most convenient option. Simply [buy an Embassy](https://start9.com) from Start9 and plug it in. Depending on where you live, shipping costs and import duties will vary.
 
-### Build your own Embassy
+### :construction_worker: Build your own Embassy
 While not as convenient as buying an Embassy, this option is easier than you might imagine, and there are 4 reasons why you might prefer it:
 1. You already have a Raspberry Pi and would like to re-purpose it.
 1. You want to save on shipping costs.
-1. You prefer not to divulge your physical shipping address.
+1. You prefer not to divulge your physical address.
 1. You just like building things.
 
-To pursue this option, follow this [guide](https://docs.start9labs.com/getting-started/diy.html).
+To pursue this option, follow this [guide](https://start9.com/latest/diy).
 
-## Contributing
-To build EmbassyOS from source, or to contribute to its development, see [here](https://github.com/Start9Labs/embassy-os/blob/master/CONTRIBUTING.md#building-the-image).
+### :hammer_and_wrench: Build EmbassyOS from Source
+
+EmbassyOS can be built from source, for personal use, for free.
+A detailed guide for doing so can be found [here](https://github.com/Start9Labs/embassy-os/blob/master/build/README.md).
+
+## :heart: Contributing
+There are multiple ways to contribute: work directly on EmbassyOS, package a service for the marketplace, or help with documentation and guides. To learn more about contributing, see [here](https://github.com/Start9Labs/embassy-os/blob/master/CONTRIBUTING.md).
+
+## UI Screenshots
+<p align="center">
+<img src="assets/EmbassyOS.png" alt="EmbassyOS" width="65%">
+</p>
+<p align="center">
+<img src="assets/eos-services.png" alt="Embassy Services" width="45%">
+<img src="assets/eos-preferences.png" alt="Embassy Preferences" width="45%">
+</p>
+<p align="center">
+<img src="assets/eos-bitcoind-health-check.png" alt="Embassy Bitcoin Health Checks" width="45%"> <img src="assets/eos-logs.png" alt="Embassy Logs" width="45%">
+</p>

agent/.gitignore

@@ -1,42 +0,0 @@
-dist*
-static/tmp/
-static/combined/
-config/client_session_key.aes
-*.hi
-*.o
-*.sqlite3
-*.sqlite3-shm
-*.sqlite3-wal
-.hsenv*
-cabal-dev/
-.stack-work/
-.stack-work-devel/
-yesod-devel/
-.cabal-sandbox
-cabal.sandbox.config
-.DS_Store
-*.swp
-*.keter
-*~
-.vscode
-*.cabal
-\#*
-start9-companion-server.cabal
-stack.yaml.lock
-*.env
-agent_*
-agent.*
-agent*
-!agent.service
-executables/*
-hidden/*
-cabal.project.local
-dump/*
-*.tar.gz
-assets/
-911.txt
-model
-product_key
-build-send.sh
-*.aes
-*.hie

agent/.stylish-haskell.yaml

@@ -1,252 +0,0 @@
-# stylish-haskell configuration file
-# ==================================
-
-# The stylish-haskell tool is mainly configured by specifying steps. These steps
-# are a list, so they have an order, and one specific step may appear more than
-# once (if needed). Each file is processed by these steps in the given order.
-steps:
-  # Convert some ASCII sequences to their Unicode equivalents. This is disabled
-  # by default.
-  # - unicode_syntax:
-  #     # In order to make this work, we also need to insert the UnicodeSyntax
-  #     # language pragma. If this flag is set to true, we insert it when it's
-  #     # not already present. You may want to disable it if you configure
-  #     # language extensions using some other method than pragmas. Default:
-  #     # true.
-  #     add_language_pragma: true
-
-  # Align the right hand side of some elements.  This is quite conservative
-  # and only applies to statements where each element occupies a single
-  # line. All default to true.
-  - simple_align:
-      cases: true
-      top_level_patterns: true
-      records: true
-
-  # Import cleanup
-  - imports:
-      # There are different ways we can align names and lists.
-      #
-      # - global: Align the import names and import list throughout the entire
-      #   file.
-      #
-      # - file: Like global, but don't add padding when there are no qualified
-      #   imports in the file.
-      #
-      # - group: Only align the imports per group (a group is formed by adjacent
-      #   import lines).
-      #
-      # - none: Do not perform any alignment.
-      #
-      # Default: global.
-      align: global
-
-      # The following options affect only import list alignment.
-      #
-      # List align has following options:
-      #
-      # - after_alias: Import list is aligned with end of import including
-      #   'as' and 'hiding' keywords.
-      #
-      #   > import qualified Data.List      as List (concat, foldl, foldr, head,
-      #   >                                          init, last, length)
-      #
-      # - with_alias: Import list is aligned with start of alias or hiding.
-      #
-      #   > import qualified Data.List      as List (concat, foldl, foldr, head,
-      #   >                                 init, last, length)
-      #
-      # - with_module_name: Import list is aligned `list_padding` spaces after
-      #   the module name.
-      #
-      #   > import qualified Data.List      as List (concat, foldl, foldr, head,
-      #                          init, last, length)
-      #
-      #   This is mainly intended for use with `pad_module_names: false`.
-      #
-      #   > import qualified Data.List as List (concat, foldl, foldr, head,
-      #                          init, last, length, scanl, scanr, take, drop,
-      #                          sort, nub)
-      #
-      # - new_line: Import list starts always on new line.
-      #
-      #   > import qualified Data.List      as List
-      #   >     (concat, foldl, foldr, head, init, last, length)
-      #
-      # Default: after_alias
-      list_align: after_alias
-
-      # Right-pad the module names to align imports in a group:
-      #
-      # - true: a little more readable
-      #
-      #   > import qualified Data.List       as List (concat, foldl, foldr,
-      #   >                                           init, last, length)
-      #   > import qualified Data.List.Extra as List (concat, foldl, foldr,
-      #   >                                           init, last, length)
-      #
-      # - false: diff-safe
-      #
-      #   > import qualified Data.List as List (concat, foldl, foldr, init,
-      #   >                                     last, length)
-      #   > import qualified Data.List.Extra as List (concat, foldl, foldr,
-      #   >                                           init, last, length)
-      #
-      # Default: true
-      pad_module_names: true
-
-      # Long list align style takes effect when import is too long. This is
-      # determined by 'columns' setting.
-      #
-      # - inline: This option will put as much specs on same line as possible.
-      #
-      # - new_line: Import list will start on new line.
-      #
-      # - new_line_multiline: Import list will start on new line when it's
-      #   short enough to fit to single line. Otherwise it'll be multiline.
-      #
-      # - multiline: One line per import list entry.
-      #   Type with constructor list acts like single import.
-      #
-      #   > import qualified Data.Map as M
-      #   >     ( empty
-      #   >     , singleton
-      #   >     , ...
-      #   >     , delete
-      #   >     )
-      #
-      # Default: inline
-      long_list_align: inline
-
-      # Align empty list (importing instances)
-      #
-      # Empty list align has following options
-      #
-      # - inherit: inherit list_align setting
-      #
-      # - right_after: () is right after the module name:
-      #
-      #   > import Vector.Instances ()
-      #
-      # Default: inherit
-      empty_list_align: inherit
-
-      # List padding determines indentation of import list on lines after import.
-      # This option affects 'long_list_align'.
-      #
-      # - <integer>: constant value
-      #
-      # - module_name: align under start of module name.
-      #   Useful for 'file' and 'group' align settings.
-      #
-      # Default: 4
-      list_padding: 4
-
-      # Separate lists option affects formatting of import list for type
-      # or class. The only difference is single space between type and list
-      # of constructors, selectors and class functions.
-      #
-      # - true: There is single space between Foldable type and list of it's
-      #   functions.
-      #
-      #   > import Data.Foldable (Foldable (fold, foldl, foldMap))
-      #
-      # - false: There is no space between Foldable type and list of it's
-      #   functions.
-      #
-      #   > import Data.Foldable (Foldable(fold, foldl, foldMap))
-      #
-      # Default: true
-      separate_lists: true
-
-      # Space surround option affects formatting of import lists on a single
-      # line. The only difference is single space after the initial
-      # parenthesis and a single space before the terminal parenthesis.
-      #
-      # - true: There is single space associated with the enclosing
-      #   parenthesis.
-      #
-      #   > import Data.Foo ( foo )
-      #
-      # - false: There is no space associated with the enclosing parenthesis
-      #
-      #   > import Data.Foo (foo)
-      #
-      # Default: false
-      space_surround: false
-
-  # Language pragmas
-  - language_pragmas:
-
-      # We can generate different styles of language pragma lists.
-      #
-      # - vertical: Vertical-spaced language pragmas, one per line.
-      #
-      # - compact: A more compact style.
-      #
-      # - compact_line: Similar to compact, but wrap each line with
-      #   `{-#LANGUAGE #-}'.
-      #
-      # Default: vertical.
-      style: vertical
-
-      # Align affects alignment of closing pragma brackets.
-      #
-      # - true: Brackets are aligned in same column.
-      #
-      # - false: Brackets are not aligned together. There is only one space
-      #   between actual import and closing bracket.
-      #
-      # Default: true
-      align: true
-
-      # stylish-haskell can detect redundancy of some language pragmas. If this
-      # is set to true, it will remove those redundant pragmas. Default: true.
-      remove_redundant: false
-
-  # Replace tabs by spaces. This is disabled by default.
-  - tabs:
-      # Number of spaces to use for each tab. Default: 8, as specified by the
-      # Haskell report.
-      spaces: 4
-
-  # Remove trailing whitespace
-  - trailing_whitespace: {}
-
-  # Squash multiple spaces between the left and right hand sides of some
-  # elements into single spaces. Basically, this undoes the effect of
-  # simple_align but is a bit less conservative.
-  # - squash: {}
-
-# A common setting is the number of columns (parts of) code will be wrapped
-# to. Different steps take this into account. Default: 80.
-columns: 120
-
-# By default, line endings are converted according to the OS. You can override
-# preferred format here.
-#
-# - native: Native newline format. CRLF on Windows, LF on other OSes.
-#
-# - lf: Convert to LF ("\n").
-#
-# - crlf: Convert to CRLF ("\r\n").
-#
-# Default: native.
-newline: native
-
-# Sometimes, language extensions are specified in a cabal file or from the
-# command line instead of using language pragmas in the file. stylish-haskell
-# needs to be aware of these, so it can parse the file correctly.
-#
-# No language extensions are enabled by default.
-language_extensions:
-    - NoImplicitPrelude
-    - FlexibleContexts
-    - FlexibleInstances
-    - GeneralizedNewtypeDeriving
-    - LambdaCase
-    - MultiWayIf
-    - NamedFieldPuns
-    - NumericUnderscores
-    - OverloadedStrings
-    - TypeApplications

agent/Changelog.md

@@ -1,12 +0,0 @@
-# 0.2.5
-
-- Upgrade to GHC 8.10.2 / Stackage nightly-2020-09-29
-- Remove internet connectivity check from startup sequence
-- Move ssh setup to synchronizers
-- Adds new dependency management structure
-- Changes version implementation from semver to new "emver" implementation
-- Adds autoconfigure feature
-- Remaps "Restarting" container status to "Crashed" for better UX
-- Persists logs after restart
-- Rewrites nginx ssl conf during UI upgrade
-- Implements better caching strategy for static assets

agent/README.md

@@ -1,7 +0,0 @@
-# Design Decision Log
-
-* 1/4/20 - Switching from HTTPS to HTTP over local LAN. Due to eventual Tor support/default, this gives
-us the neatest slot for the Tor support
-	* This means it is possible to snoop on traffic between the companion app and the server if you
-	have a LAN presence.
-	* This also makes it possible to masquerade as the server if you have a LAN presence

agent/TODO.md

@@ -1,3 +0,0 @@
-* When adding ssh keys, don't add if identical one exists
-* When adding ssh keys, check for newline at the end of the file. if not exists, add it.
-* If `appmgr stop <ID>` throws no error, but completes without the app being stopped, we need to restart dockerd.

agent/app/main.hs

@@ -1,5 +0,0 @@
-import           Application                    ( appMain )
-import           Startlude
-
-main :: IO ()
-main = appMain

agent/brittany.yaml

@@ -1,60 +0,0 @@
-conf_debug:
-  dconf_roundtrip_exactprint_only: false
-  dconf_dump_bridoc_simpl_par: false
-  dconf_dump_ast_unknown: false
-  dconf_dump_bridoc_simpl_floating: false
-  dconf_dump_config: false
-  dconf_dump_bridoc_raw: false
-  dconf_dump_bridoc_final: false
-  dconf_dump_bridoc_simpl_alt: false
-  dconf_dump_bridoc_simpl_indent: false
-  dconf_dump_annotations: false
-  dconf_dump_bridoc_simpl_columns: false
-  dconf_dump_ast_full: false
-conf_forward:
-  options_ghc:
-    - -XNoImplicitPrelude
-    - -XBlockArguments
-    - -XFlexibleContexts
-    - -XFlexibleInstances
-    - -XGeneralizedNewtypeDeriving
-    - -XKindSignatures
-    - -XLambdaCase
-    - -XMultiWayIf
-    - -XNamedFieldPuns
-    - -XNumericUnderscores
-    - -XOverloadedStrings
-    - -XTemplateHaskell
-    - -XTypeApplications
-conf_errorHandling:
-  econf_ExactPrintFallback: ExactPrintFallbackModeInline
-  econf_Werror: false
-  econf_omit_output_valid_check: false
-  econf_produceOutputOnErrors: false
-conf_preprocessor:
-  ppconf_CPPMode: CPPModeWarn
-  ppconf_hackAroundIncludes: false
-conf_obfuscate: false
-conf_roundtrip_exactprint_only: false
-conf_version: 1
-conf_layout:
-  lconfig_reformatModulePreamble: true
-  lconfig_altChooser:
-    tag: AltChooserBoundedSearch
-    contents: 3
-  lconfig_allowSingleLineExportList: false
-  lconfig_importColumn: 50
-  lconfig_hangingTypeSignature: true
-  lconfig_importAsColumn: 50
-  lconfig_alignmentLimit: 30
-  lconfig_allowHangingQuasiQuotes: true
-  lconfig_indentListSpecial: true
-  lconfig_indentAmount: 4
-  lconfig_alignmentBreakOnMultiline: true
-  lconfig_experimentalSemicolonNewlines: false
-  lconfig_cols: 120
-  lconfig_indentPolicy: IndentPolicyFree
-  lconfig_indentWhereSpecial: false
-  lconfig_columnAlignMode:
-    tag: ColumnAlignModeMajority
-    contents: 0.7

agent/build.sh

@@ -1,6 +0,0 @@
-#!/bin/bash
-
-cat config/settings.yml | grep app-mgr-version-spec
-cat package.yaml | grep version
-
-stack --local-bin-path ./dist build --copy-bins #--flag start9-agent:disable-auth

agent/config/agent.service

@@ -1,14 +0,0 @@
-[Unit]
-Description=Boot process for system reset.
-After=network.target lifeline.service avahi-daemon.service systemd-time-wait-sync.service
-Requires=network.target
-Wants=avahi-daemon.service
-
-[Service]
-Type=simple
-ExecStart=/usr/local/bin/agent
-Restart=always
-RestartSec=3
-
-[Install]
-WantedBy=multi-user.target

agent/config/journald.conf

@@ -1,6 +0,0 @@
-[Journal]
-Storage=persistent
-SystemMaxUse=100M
-SystemMaxFileSize=10M
-MaxRetentionSec=1month
-MaxFileSec=1week

agent/config/nginx.conf

@@ -1,29 +0,0 @@
-user www-data;
-worker_processes 1;
-pid /run/nginx.pid;
-include /etc/nginx/modules-enabled/*.conf;
-
-events {
-	worker_connections 768;
-	multi_accept on;
-}
-
-http {
-	sendfile on;
-	tcp_nopush on;
-	tcp_nodelay on;
-	keepalive_timeout 65;
-	types_hash_max_size 2048;
-
-	include /etc/nginx/mime.types;
-	default_type application/octet-stream;
-
-	access_log /var/log/nginx/access.log;
-	error_log /var/log/nginx/error.log;
-
-	gzip on;
-
-	server_names_hash_bucket_size 128;
-	include /etc/nginx/conf.d/*.conf;
-	include /etc/nginx/sites-enabled/*;
-}

agent/config/restarter.service

@@ -1,7 +0,0 @@
-[Unit]
-Description=restarts dead containers
-Requires=docker.service
-
-[Service]
-Type=oneshot
-ExecStart=/usr/local/bin/appmgr repair-app-status

agent/config/restarter.timer

@@ -1,9 +0,0 @@
-[Unit]
-Description=restarter
-
-[Timer]
-OnUnitActiveSec=60s
-OnBootSec=60s
-
-[Install]
-WantedBy=timers.target

agent/config/routes

@@ -1,61 +0,0 @@
-/auth                                 AuthR                    Auth               getAuth !noAuth
-
-/git                                  GitR                     GET
-/authenticate                         AuthenticateR            GET
-/version                              VersionR                 GET                !noAuth
-/versionLatest                        VersionLatestR           GET                !noAuth
-/v0                                   ServerR                  GET PATCH
-
-/v0/name                              NameR                    PATCH
-/v0/autoCheckUpdates                  AutoCheckUpdatesR        PATCH
-
-/v0/welcome/#Version                  WelcomeR                 POST
-/v0/specs                             SpecsR                   GET
-/v0/metrics                           MetricsR                 GET
-
-/v0/logs                              LogsR                    GET
-/v0/sshKeys                           SshKeysR                 GET POST
-/v0/sshKeys/#Text                     SshKeyByFingerprintR     DELETE
-/v0/password                          PasswordR                PATCH
-
-/v0/apps/store                        AvailableAppsR           GET                        -- reg reliant
-/v0/apps/installed                    InstalledAppsR           GET
-/v0/apps/#AppId/store                 AvailableAppByIdR        GET                        -- reg reliant
-
-/v0/apps/#AppId/store/#VersionRange   AvailableAppVersionInfoR GET                        -- reg reliant
-/v0/apps/#AppId/installed             InstalledAppByIdR        GET
-/v0/apps/#AppId/logs                  AppLogsByIdR             GET
-/v0/apps/#AppId/install               InstallNewAppR           POST                       -- reg reliant
-/v0/apps/#AppId/config                AppConfigR               GET PATCH
-/v0/apps/#AppId/start                 StartServerAppR          POST
-/v0/apps/#AppId/restart               RestartServerAppR        POST
-/v0/apps/#AppId/stop                  StopServerAppR           POST
-/v0/apps/#AppId/uninstall             UninstallAppR            POST
-/v0/apps/#AppId/notifications         AppNotificationsR        GET
-/v0/apps/#AppId/metrics               AppMetricsR              GET
-/v0/apps/#AppId/icon                  AppIconR                 GET                !noAuth !cached
-/v0/apps/#AppId/icon/store            AvailableAppIconR        GET                !noAuth !cached -- reg reliant
-/v0/apps/#AppId/backup                CreateBackupR            POST
-/v0/apps/#AppId/backup/stop           StopBackupR              POST
-/v0/apps/#AppId/backup/restore        RestoreBackupR           POST
-/v0/apps/#AppId/autoconfig/#AppId     AutoconfigureR           POST
-/v0/apps/#AppId/actions               ActionR                  POST
-
-/v0/network/lan/reset                 ResetLanR                POST
-
-/v0/disks                             DisksR                   GET
-/v0/disks/eject                       EjectR                   POST
-
-/v0/update                            UpdateAgentR             POST
-/v0/wifi                              WifiR                    GET POST
-/v0/wifi/#Text                        WifiBySsidR              POST DELETE
-
-/v0/notifications                     NotificationsR           GET
-/v0/notifications/#UUID               NotificationR            DELETE
-
-/v0/shutdown                          ShutdownR                POST
-/v0/restart                           RestartR                 POST
-
-/v0/register                          RegisterR                POST               !noAuth
-/v0/hosts                             HostsR                   GET                !noAuth
-/v0/certificate                       CertificateR             GET

agent/config/settings.yml

@@ -1,38 +0,0 @@
-# Values formatted like "_env:YESOD_ENV_VAR_NAME:default_value" can be overridden by the specified environment variable.
-# See https://github.com/yesodweb/yesod/wiki/Configuration#overriding-configuration-values-with-environment-variables
-
-static-dir:     "_env:YESOD_STATIC_DIR:static"
-host:           "_env:YESOD_HOST:*4" # any IPv4 host
-port:           5959 # NB: The port `yesod devel` uses is distinct from this value. Set the `yesod devel` port from the command line.
-ip-from-header: "_env:YESOD_IP_FROM_HEADER:false"
-detailed-logging: "_env:DETAILED_LOGGING:false"
-
-# Default behavior: determine the application root from the request headers.
-# Uncomment to set an explicit approot
-#approot:        "_env:YESOD_APPROOT:http://localhost:3000"
-
-# By default, `yesod devel` runs in development, and built executables use
-# production settings (see below). To override this, use the following:
-#
-# development: false
-
-# Optional values with the following production defaults.
-# In development, they default to the inverse.
-#
-# detailed-logging: false
-# should-log-all: false
-# reload-templates: false
-# mutable-static: false
-# skip-combining: false
-# auth-dummy-login : false
-
-# NB: If you need a numeric value (e.g. 123) to parse as a String, wrap it in single quotes (e.g. "_env:YESOD_PGPASS:'123'")
-# See https://github.com/yesodweb/yesod/wiki/Configuration#parsing-numeric-values-as-strings
-filesystem-base: "_env:FILESYSTEM_BASE:/"
-database:
-  database: "start9_agent.sqlite3"
-  poolsize: "_env:YESOD_SQLITE_POOLSIZE:10"
-
-app-mgr-version-spec: "=0.2.9"
-
-#analytics: UA-YOURCODE

agent/config/torrc

@@ -1,5 +0,0 @@
-SOCKSPort 0.0.0.0:9050 # Default: Bind to localhost:9050 for local connections.
-HiddenServiceDir /var/lib/tor/agent/
-HiddenServicePort 5959 127.0.0.1:5959
-HiddenServicePort 80 127.0.0.1:80
-HiddenServicePort 443 127.0.0.1:443

agent/hie.yaml

@@ -1,13 +0,0 @@
-cradle:
-  stack:
-    - path: "./src"
-      component: "ambassador-agent:lib"
-
-    - path: "./app/main.hs"
-      component: "ambassador-agent:exe:agent"
-
-    - path: "./test"
-      component: "ambassador-agent:test:agent-test"
-
-    - path: "./"
-      component: "ambassador-agent:lib"

agent/migrations/0.1.0::0.1.0

@@ -1 +0,0 @@
-SELECT TRUE;

agent/migrations/0.1.0::0.1.1

@@ -1 +0,0 @@
-CREATE TABLE "replay_nonce"("id" VARCHAR PRIMARY KEY,"created_at" TIMESTAMP NOT NULL);

agent/migrations/0.1.1::0.1.2

@@ -1 +0,0 @@
-SELECT TRUE;

agent/migrations/0.1.2::0.1.3

@@ -1 +0,0 @@
-SELECT TRUE;

agent/migrations/0.1.3::0.1.4

@@ -1 +0,0 @@
-SELECT TRUE;

agent/migrations/0.1.4::0.1.5

@@ -1 +0,0 @@
-SELECT TRUE;

agent/migrations/0.1.5::0.2.0

@@ -1,2 +0,0 @@
-DROP TABLE authorized_key;
-DROP TABLE replay_nonce;

agent/migrations/0.2.0::0.2.1

@@ -1 +0,0 @@
-SELECT TRUE;

agent/migrations/0.2.1::0.2.2

@@ -1 +0,0 @@
-SELECT TRUE;

agent/migrations/0.2.2::0.2.3

@@ -1 +0,0 @@
-SELECT TRUE;

agent/migrations/0.2.3::0.2.4

@@ -1 +0,0 @@
-SELECT TRUE;

agent/migrations/0.2.4::0.2.5

@@ -1 +0,0 @@
-SELECT TRUE;

agent/migrations/0.2.5::0.2.6

@@ -1 +0,0 @@
-SELECT TRUE;

agent/migrations/0.2.6::0.2.7

@@ -1 +0,0 @@
-SELECT TRUE;

agent/migrations/0.2.7::0.2.8

@@ -1 +0,0 @@
-SELECT TRUE;

agent/migrations/0.2.8::0.2.9

@@ -1 +0,0 @@
-SELECT TRUE;

agent/package.yaml

@@ -1,184 +0,0 @@
-name: ambassador-agent
-version: 0.2.9
-
-default-extensions:
-- NoImplicitPrelude
-- BlockArguments
-- ConstraintKinds
-- DataKinds
-- DeriveAnyClass
-- DeriveFunctor
-- DeriveGeneric
-- DerivingStrategies
-- EmptyCase
-- FlexibleContexts
-- FlexibleInstances
-- GADTs
-- GeneralizedNewtypeDeriving
-- InstanceSigs
-- KindSignatures
-- LambdaCase
-- MultiParamTypeClasses
-- MultiWayIf
-- NamedFieldPuns
-- NumericUnderscores
-- OverloadedStrings
-- PolyKinds
-- RankNTypes
-- StandaloneDeriving
-- StandaloneKindSignatures
-- TupleSections
-- TypeApplications
-- TypeFamilies
-- TypeOperators
-
-dependencies:
-- base >=4.9.1.0 && <5
-- aeson
-- aeson-flatten
-- attoparsec
-- bytestring
-- casing
-- comonad
-- conduit
-- conduit-extra
-- connection
-- containers
-- cryptonite
-- cryptonite-conduit
-- data-default
-- directory
-- errors
-- exceptions
-- exinst
-- fast-logger
-- file-embed
-- filelock
-- filepath
-- fused-effects
-- fused-effects-th
-- git-embed
-- http-api-data
-- http-client
-- http-client-tls
-- http-conduit
-- http-types
-- interpolate
-- iso8601-time
-- json-rpc
-- lens
-- lens-aeson
-- lifted-async
-- lifted-base
-- memory
-- mime-types
-- monad-control
-- monad-logger
-- network
-- persistent
-- persistent-sqlite
-- persistent-template
-- process
-- process-extras
-- protolude
-- resourcet
-- regex-compat # TODO: trim this dep
-- shell-conduit
-- singletons
-- stm
-- streaming
-- streaming-bytestring
-- streaming-conduit
-- streaming-utils
-- tar-conduit
-- template-haskell
-- text >=0.11 && <2.0
-- time
-- transformers
-- transformers-base
-- typed-process
-- unix
-- unliftio # TODO: trim this dep
-- unliftio-core # TODO: trim this dep
-- unordered-containers
-- uuid
-- wai
-- wai-cors
-- wai-extra
-- warp
-- yaml
-- yesod
-- yesod-auth
-- yesod-core
-- yesod-form
-- yesod-persistent
-
-flags:
-  library-only:
-    manual: false
-    default: false
-    description: Build for use with "yesod devel"
-  dev:
-    manual: false
-    default: false
-    description: Turn on development settings, like auto-reload templates.
-  disable-auth:
-    manual: false
-    default: false
-    description: disable authorization checks
-library:
-  source-dirs: src
-  when:
-  - condition: (flag(dev)) || (flag(library-only))
-    then:
-      cpp-options: -DDEVELOPMENT
-      ghc-options:
-      - -Wall
-      - -Wunused-packages
-      - -fwarn-tabs
-      - -O0
-      - -fdefer-typed-holes
-    else:
-      ghc-options:
-      - -Wall
-      - -Wunused-packages
-      - -fwarn-tabs
-      - -O2
-      - -fdefer-typed-holes
-  - condition: (flag(disable-auth))
-    cpp-options: -DDISABLE_AUTH
-tests:
-  agent-test:
-    source-dirs: test
-    main: Main.hs
-    ghc-options:
-    - -Wall
-    - -fdefer-typed-holes
-    dependencies:
-    - ambassador-agent
-    - hspec >=2.0.0
-    - hspec-expectations
-    - hedgehog
-    - yesod-test
-    - random
-    when:
-    - condition: false
-      other-modules: Paths_ambassador_agent
-
-executables:
-  agent:
-    source-dirs: app
-    main: main.hs
-    ghc-options:
-    - -Wall
-    - -threaded
-    - -rtsopts
-    - -with-rtsopts=-N
-    - -fdefer-typed-holes
-    dependencies:
-    - ambassador-agent
-    when:
-    - buildable: false
-      condition: flag(library-only)
-    - condition: false
-      other-modules: Paths_ambassador_agent

agent/src/Application.hs

@@ -1,247 +0,0 @@
-{-# LANGUAGE CPP                   #-}
-{-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE RecordWildCards       #-}
-{-# LANGUAGE ScopedTypeVariables   #-}
-{-# LANGUAGE TemplateHaskell       #-}
-{-# LANGUAGE TypeFamilies          #-}
-module Application
-    ( appMain
-    , makeFoundation
-    , makeLogWare
-    -- * for DevelMain
-    , getApplicationRepl
-    , getAppSettings
-    , shutdownAll
-    , shutdownWeb
-    , startWeb
-    -- * for GHCI
-    , handler
-    , runDb
-    , getAgentCtx
-    , sleep
-    )
-where
-
-import           Startlude               hiding (runReader)
-
-import           Control.Concurrent.STM.TVar    ( newTVarIO )
-import           Control.Monad.Logger
-import           Control.Effect.Labelled        ( Labelled, runLabelled )
-import qualified Data.HashMap.Strict           as HM
-import           Data.IORef
-
-import           Database.Persist.Sql
-import           Database.Persist.Sqlite        ( createSqlitePool
-                                                , runSqlite
-                                                , sqlPoolSize
-                                                , sqlDatabase
-                                                )
-import           Git.Embed
-import           Network.HTTP.Client.TLS        ( getGlobalManager )
-import           Network.Wai
-import           Network.Wai.Handler.Warp       ( getPort )
-import           System.Directory               ( createDirectoryIfMissing )
-import           System.Environment             ( setEnv )
-import           System.IO               hiding ( putStrLn, writeFile )
-import           System.Log.FastLogger          ( defaultBufSize
-                                                , newStdoutLoggerSet
-                                                )
-import           Yesod.Core
-import           Yesod.Default.Config2
-import           Yesod.Persist.Core
-
-import           Constants
-import qualified Daemon.AppNotifications       as AppNotifications
-import           Daemon.RefreshProcDev
-import qualified Daemon.SslRenew as SSLRenew
-import           Daemon.TorHealth
-import           Daemon.ZeroConf
-import           Foundation
-import           Lib.Algebra.State.RegistryUrl
-import           Lib.Background
-import           Lib.Database
-import           Lib.External.Metrics.ProcDev
-import           Lib.SelfUpdate
-import           Lib.Sound
-import           Lib.SystemPaths
-import           Lib.Tor                        ( newTorManager )
-import           Lib.WebServer
-import           Model
-import           Settings
-
-appMain :: IO ()
-appMain = do
-    hSetBuffering stdout LineBuffering
-    args <- getArgs
-
-    -- Get the settings from all relevant sources
-    settings <- loadYamlSettings [] [configSettingsYmlValue] useEnv
-
-    settings' <- case args of
-        ["--port", n] -> case readMaybe @Word16 $ toS n of
-            Just n' -> pure $ settings { appPort = n' }
-            Nothing -> do
-                die . toS $ "Invalid Port: " <> n
-        ["--git-hash"] -> do
-            putStrLn @Text $embedGitRevision
-            exitSuccess
-        ["--version"] -> do
-            putStrLn @Text (show agentVersion)
-            exitSuccess
-        _ -> pure settings
-    createDirectoryIfMissing False (toS $ agentDataDirectory `relativeTo` appFilesystemBase settings')
-
-    -- Generate the foundation from the settings
-    foundation <- makeFoundation settings'
-
-    startupSequence foundation
-
--- | This function allocates resources (such as a database connection pool),
--- performs initialization and returns a foundation datatype value. This is also
--- the place to put your migrate statements to have automatic database
--- migrations handled by Yesod.
-makeFoundation :: AppSettings -> IO AgentCtx
-makeFoundation appSettings = do
-    now                         <- getCurrentTime
-    -- Some basic initializations: HTTP connection manager, logger, and static
-    -- subsite.
-    appLogger                   <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
-    appHttpManager              <- getGlobalManager
-    appTorManager               <- newTorManager (appTorSocksPort appSettings)
-    appWebServerThreadId        <- newIORef Nothing
-    appSelfUpdateSpecification  <- newEmptyMVar
-    appIsUpdating               <- newIORef Nothing
-    appIsUpdateFailed           <- newIORef Nothing
-    appOsVersionLatest          <- newIORef Nothing
-    appBackgroundJobs           <- newTVarIO (JobCache HM.empty)
-    def                         <- getDefaultProcDevMetrics
-    appProcDevMomentCache       <- newIORef (now, mempty, def)
-    appLastTorRestart           <- newIORef now
-    appLanThread                <- forkIO (sleep 10) >>= newMVar
-
-    -- We need a log function to create a connection pool. We need a connection
-    -- pool to create our foundation. And we need our foundation to get a
-    -- logging function. To get out of this loop, we initially create a
-    -- temporary foundation without a real connection pool, get a log function
-    -- from there, and then create the real foundation.
-    let mkFoundation appConnPool appIconTags = AgentCtx { .. }
-    -- The AgentCtx {..} syntax is an example of record wild cards. For more
-    -- information, see:
-    -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
-        tempFoundation = mkFoundation
-            (panic "connPool forced in tempFoundation")
-            (panic "iconTags forced in tempFoundation")
-        logFunc        = messageLoggerSource tempFoundation appLogger
-
-    db <- interpDb dbPath
-
-    -- Create the database connection pool, will create sqlite file if doesn't already exist
-    pool <- flip runLoggingT logFunc $ createSqlitePool (toS db) (sqlPoolSize . appDatabaseConf $ appSettings)
-
-    -- run migrations only if agent in charge
-    when (appPort appSettings == 5959) $ do
-        runSqlite db $ runMigration migrateAll
-        void . interpDb $ ensureCoherentDbVersion pool logFunc
-
-    iconTags <- if appPort appSettings == 5959
-        then do
-            iconDigests <- runSqlPool (selectList [] []) pool
-            newTVarIO . HM.fromList $ (unIconDigestKey . entityKey &&& iconDigestTag . entityVal) <$> iconDigests
-        else newTVarIO HM.empty
-
-    -- Return the foundation
-    pure $ mkFoundation pool iconTags
-    where
-        interpDb :: (Labelled "sqlDatabase" (ReaderT Text)) (Labelled "filesystemBase" (ReaderT Text) IO) a -> IO a
-        interpDb = injectFilesystemBaseFromContext appSettings
-                . flip runReaderT (sqlDatabase . appDatabaseConf $ appSettings)
-                . runLabelled @"sqlDatabase"
-
-getAppSettings :: IO AppSettings
-getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv
-
-
-startupSequence :: AgentCtx -> IO ()
-startupSequence foundation = do
-
-#ifdef DISABLE_AUTH
-    withAgentVersionLog_ "[WARNING] Agent auth disabled!"
-#endif
-
-    injectFilesystemBaseFromContext (appSettings foundation) . runRegistryUrlIOC $ getRegistryUrl >>= \case
-        Nothing -> pure ()
-        Just x -> liftIO $ do
-            withAgentVersionLog "Detected Alternate Registry URL" x
-            -- this is so that appmgr inherits the alternate registry url when it is called.
-            setEnv "REGISTRY_URL" (show x)
-
-    -- proc dev metrics refresh loop
-    withAgentVersionLog_ "Initializing proc dev refresh loop"
-    void . forkIO . forever $ forkIO (refreshProcDev foundation) >> threadDelay 5_000_000
-    withAgentVersionLog_ "Proc dev metrics refreshing"
-
-    -- web
-    withAgentVersionLog_ "Starting web server"
-    void . forkIO . startWeb $ foundation
-    withAgentVersionLog_ "Web server running"
-
-    -- all these actions are destructive in some way, and only webserver is needed for self-update
-    when (appPort (appSettings foundation) == 5959) $ do
-        synchronizeSystemState foundation agentVersion
-
-        -- app notifications refresh loop
-        withAgentVersionLog_ "Initializing app notifications refresh loop"
-        void . forkIO . forever $ forkIO (runReaderT AppNotifications.fetchAndSave foundation) >> threadDelay 5_000_000
-        withAgentVersionLog_ "App notifications refreshing"
-
-        withAgentVersionLog_ "Initializing SSL certificate renewal loop"
-        void . forkIO . forever $ forkIO (SSLRenew.renewSslLeafCert foundation) *> sleep 86_400
-        withAgentVersionLog_ "SSL Renewal daemon started"
-
-        withAgentVersionLog_ "Initializing Tor health check loop"
-        void . forkIO . forever $ forkIO (runReaderT torHealth foundation) *> sleep 300
-        withAgentVersionLog_ "Tor health check loop running"
-
-        -- reloading avahi daemon
-        -- DRAGONS! make sure this step happens AFTER system synchronization
-        withAgentVersionLog_ "Publishing Agent to Avahi Daemon"
-        runReaderT publishAgentToAvahi foundation
-        withAgentVersionLog_ "Avahi Daemon reloaded with Agent service"
-
-        when (appPort (appSettings foundation) == 5959) $ do
-            playSong 400 marioCoin
-
-    withAgentVersionLog_ "Listening for Self-Update Signal"
-    waitForUpdateSignal foundation
-
-sleep :: Integer -> IO ()
-sleep n = let (full, r) = (n * 1_000_000) `divMod` fromIntegral (maxBound :: Int) in
-    replicateM_ (fromIntegral full) (threadDelay maxBound) *> threadDelay (fromIntegral r)
-
---------------------------------------------------------------
--- Functions for DevelMain.hs (a way to run the AgentCtx from GHCi)
---------------------------------------------------------------
-
-getApplicationRepl :: IO (Int, AgentCtx, Application)
-getApplicationRepl = do
-    foundation <- getAppSettings >>= makeFoundation
-    wsettings  <- getDevSettings $ warpSettings foundation
-    app1       <- makeApplication foundation
-    return (getPort wsettings, foundation, app1)
-
-getAgentCtx :: IO AgentCtx
-getAgentCtx = getAppSettings >>= makeFoundation
-
----------------------------------------------
--- Functions for use in development with GHCi
----------------------------------------------
-
--- | Run a handler
-handler :: Handler a -> IO a
-handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h
-
--- | Run DB queries
-runDb :: ReaderT SqlBackend Handler a -> IO a
-runDb = handler . runDB
-

agent/src/Auth.hs

@@ -1,19 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE QuasiQuotes #-}
-module Auth where
-
-import           Startlude
-
-import           Yesod.Core
-
-data Auth = Auth
-
-getAuth :: a -> Auth
-getAuth = const Auth
-
-mkYesodSubData "Auth" [parseRoutes|
-/login LoginR POST
-/logout LogoutR POST
-|]

agent/src/Constants.hs

@@ -1,16 +0,0 @@
-module Constants where
-
-import           Startlude
-
-import           Data.Version                   ( showVersion )
-import           Lib.Types.Emver                ( Version )
-import           Paths_ambassador_agent         ( version )
-
-agentVersion :: Version
-agentVersion = fromString $ showVersion version
-
-withAgentVersionLog :: (Show a, MonadIO m) => Text -> a -> m ()
-withAgentVersionLog t a = liftIO $ putStrLn @Text $ show agentVersion <> "-- " <> t <> ": " <> show a
-
-withAgentVersionLog_ :: Text -> IO ()
-withAgentVersionLog_ t = putStrLn @Text $ show agentVersion <> "-- " <> t

agent/src/Daemon/AppNotifications.hs

@@ -1,48 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE RecordWildCards #-}
-module Daemon.AppNotifications where
-
-import           Startlude
-
-import qualified Data.HashMap.Strict           as HM
-import           Data.UUID.V4
-import           Data.Time.Clock.POSIX
-import           Database.Persist.Sql
-
-import           Foundation
-import           Lib.Error
-import           Lib.Algebra.Domain.AppMgr     as AppMgr2
-import           Lib.External.AppMgr           as AppMgr
-import           Lib.Types.Core
-import           Lib.Types.Emver
-import           Model
-
-toModelNotif :: (AppId, Version) -> AppMgrNotif -> Notification
-toModelNotif (appId, appVersion) AppMgrNotif {..} =
-    let prefix = (<> "1") $ case appMgrNotifLevel of
-            INFO    -> "0"
-            SUCCESS -> "1"
-            WARN    -> "2"
-            ERROR   -> "3"
-    in  Notification (posixSecondsToUTCTime . fromRational $ appMgrNotifTime)
-                     Nothing
-                     appId
-                     appVersion
-                     (prefix <> show appMgrNotifCode)
-                     appMgrNotifTitle
-                     appMgrNotifMessage
-
-fetchAndSave :: ReaderT AgentCtx IO ()
-fetchAndSave = handleErr $ do
-    pool <- asks appConnPool
-    apps <- HM.toList <$> AppMgr2.runAppMgrCliC (AppMgr2.list [AppMgr2.flags| |])
-    for_ apps $ \(appId, AppMgr2.InfoRes { infoResVersion }) -> do
-        notifs <- AppMgr.notifications appId
-        let mods = toModelNotif (appId, infoResVersion) <$> notifs
-        keys <- liftIO $ replicateM (length mods) (NotificationKey <$> nextRandom)
-        let ents = zipWith Entity keys mods
-        lift $ flip runSqlPool pool $ insertEntityMany ents
-    where
-        handleErr m = runExceptT m >>= \case
-            Left  e -> putStrLn (errorMessage $ toError e)
-            Right _ -> pure ()

agent/src/Daemon/RefreshProcDev.hs

@@ -1,20 +0,0 @@
-module Daemon.RefreshProcDev where
-
-import           Startlude
-
-import           Data.IORef
-
-import           Foundation
-import           Lib.Error
-import           Lib.External.Metrics.ProcDev
-
-refreshProcDev :: AgentCtx -> IO ()
-refreshProcDev agentCtx = do
-    let procDevCache = appProcDevMomentCache agentCtx
-    (oldTime, oldMoment, _) <- liftIO . readIORef . appProcDevMomentCache $ agentCtx
-
-    eProcDev                <- runS9ErrT $ getProcDevMetrics (oldTime, oldMoment)
-    case eProcDev of
-        Left  e -> putStrLn @Text . show $ e
-        Right (newTime, newMoment, newMetrics) -> liftIO $ writeIORef procDevCache (newTime, newMoment, newMetrics)
-

agent/src/Daemon/SslRenew.hs

@@ -1,83 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-module Daemon.SslRenew where
-
-import           Startlude               hiding ( err )
-
-import           Data.String.Interpolate        ( i )
-import           System.Process                 ( system )
-
-import           Foundation
-import           Lib.SystemPaths
-import           Settings
-import           Lib.Ssl
-import           Daemon.ZeroConf                ( getStart9AgentHostname )
-import           Lib.Tor
-import           Control.Carrier.Lift
-import           System.Directory               ( doesPathExist
-                                                , removePathForcibly
-                                                , renameDirectory
-                                                )
-import           Lib.SystemCtl
-import qualified Lib.Notifications             as Notifications
-import           Database.Persist.Sql           ( runSqlPool )
-import           Lib.Types.Core
-import           Constants
-
-renewSslLeafCert :: AgentCtx -> IO ()
-renewSslLeafCert ctx = do
-    let base = appFilesystemBase . appSettings $ ctx
-    sid <- injectFilesystemBase base getStart9AgentHostname
-    let hostname = sid <> ".local"
-    tor <- injectFilesystemBase base getAgentHiddenServiceUrl
-    putStr @Text "SSL Renewal Required? "
-    needsRenew <- doesSslNeedRenew (toS $ entityCertPath sid `relativeTo` base)
-    print needsRenew
-    when needsRenew $ runM . injectFilesystemBase base $ do
-        intCaKeyPath   <- toS <$> getAbsoluteLocationFor intermediateCaKeyPath
-        intCaConfPath  <- toS <$> getAbsoluteLocationFor intermediateCaOpenSslConfPath
-        intCaCertPath  <- toS <$> getAbsoluteLocationFor intermediateCaCertPath
-
-        sslDirTmp      <- toS <$> getAbsoluteLocationFor (agentTmpDirectory <> sslDirectory)
-        entKeyPathTmp  <- toS <$> getAbsoluteLocationFor (agentTmpDirectory <> entityKeyPath sid)
-        entConfPathTmp <- toS <$> getAbsoluteLocationFor (agentTmpDirectory <> entityConfPath sid)
-        entCertPathTmp <- toS <$> getAbsoluteLocationFor (agentTmpDirectory <> entityCertPath sid)
-
-        (ec, out, err) <- writeLeafCert
-            DeriveCertificate { applicantConfPath = entConfPathTmp
-                              , applicantKeyPath  = entKeyPathTmp
-                              , applicantCertPath = entCertPathTmp
-                              , signingConfPath   = intCaConfPath
-                              , signingKeyPath    = intCaKeyPath
-                              , signingCertPath   = intCaCertPath
-                              , duration          = 365
-                              }
-            hostname
-            tor
-        liftIO $ do
-            putStrLn @Text "openssl logs"
-            putStrLn @Text "exit code: "
-            print ec
-            putStrLn @String $ "stdout: " <> out
-            putStrLn @String $ "stderr: " <> err
-        case ec of
-            ExitSuccess -> pure ()
-            ExitFailure n ->
-                liftIO
-                    . void
-                    $ flip runSqlPool (appConnPool ctx)
-                    $ Notifications.emit (AppId "EmbassyOS") agentVersion
-                    $ Notifications.CertRenewFailed (ExitFailure n) out err
-        let sslDir = toS $ sslDirectory `relativeTo` base
-        liftIO $ removePathForcibly sslDir
-        liftIO $ renameDirectory sslDirTmp sslDir
-        liftIO $ systemCtl RestartService "nginx" $> ()
-
-
-doesSslNeedRenew :: FilePath -> IO Bool
-doesSslNeedRenew cert = do
-    exists <- doesPathExist cert
-    if exists
-        then do
-            ec <- liftIO $ system [i|openssl x509 -checkend 2592000 -noout -in #{cert}|]
-            pure $ ec /= ExitSuccess
-        else pure False

agent/src/Daemon/TorHealth.hs

@@ -1,50 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-module Daemon.TorHealth where
-
-import           Startlude
-
-import           Data.String.Interpolate.IsString
-
-import           Foundation
-import           Lib.SystemPaths
-import           Lib.Tor
-import           Yesod                          ( RenderRoute(renderRoute) )
-import           Network.HTTP.Simple            ( getResponseBody )
-import           Network.HTTP.Client            ( parseRequest )
-import           Network.HTTP.Client            ( httpLbs )
-import           Data.ByteString.Lazy           ( toStrict )
-import qualified UnliftIO.Exception            as UnliftIO
-import           Settings
-import           Data.IORef                     ( writeIORef
-                                                , readIORef
-                                                )
-import           Lib.SystemCtl
-
-torHealth :: ReaderT AgentCtx IO ()
-torHealth = do
-    settings <- asks appSettings
-    host     <- injectFilesystemBaseFromContext settings getAgentHiddenServiceUrl
-    let url = mappend [i|http://#{host}:5959|] . fold $ mappend "/" <$> fst (renderRoute VersionR)
-    response <- UnliftIO.try @_ @SomeException $ torGet (toS url)
-    case response of
-        Left _ -> do
-            putStrLn @Text "Failed Tor health check"
-            lastRestart <- asks appLastTorRestart >>= liftIO . readIORef
-            cooldown    <- asks $ appTorRestartCooldown . appSettings
-            now         <- liftIO getCurrentTime
-            if now > addUTCTime cooldown lastRestart
-                then do
-                    ec <- liftIO $ systemCtl RestartService "tor"
-                    case ec of
-                        ExitSuccess   -> asks appLastTorRestart >>= liftIO . flip writeIORef now
-                        ExitFailure _ -> do
-                            putStrLn @Text "Failed to restart tor daemon after failed tor health check"
-                else do
-                    putStrLn @Text "Failed tor healthcheck inside of cooldown window, tor will not be restarted"
-        Right _ -> pure ()
-
-torGet :: String -> ReaderT AgentCtx IO ByteString
-torGet url = do
-    manager <- asks appTorManager
-    req     <- parseRequest url
-    liftIO $ toStrict . getResponseBody <$> httpLbs req manager

agent/src/Daemon/ZeroConf.hs

@@ -1,65 +0,0 @@
-{-# LANGUAGE TypeApplications #-}
-module Daemon.ZeroConf where
-
-import           Startlude               hiding ( ask )
-
-import           Control.Lens
-import           Control.Effect.Reader.Labelled ( ask )
-import           Control.Monad.Trans.Reader     ( withReaderT )
-import           Crypto.Hash
-import           Data.ByteArray                 ( convert )
-import           Data.ByteArray.Encoding
-import qualified Data.ByteString               as BS
-import           System.FilePath.Lens
-
-import           Foundation
-import qualified Lib.Avahi                     as Avahi
-import           Lib.ProductKey
-import           Lib.SystemPaths
-
-import           Settings
-import qualified Lib.Algebra.Domain.AppMgr     as AppMgr2
-import           Control.Carrier.Lift
-import           Lib.Error
-
-start9AgentServicePrefix :: IsString a => a
-start9AgentServicePrefix = "start9-"
-
-getStart9AgentHostname :: (HasFilesystemBase sig m, MonadIO m, ConvertText Text a) => m a
-getStart9AgentHostname = do
-    base   <- ask @"filesystemBase"
-    suffix <-
-        liftIO
-        $   decodeUtf8
-        .   convertToBase Base16
-        .   BS.take 4
-        .   convert
-        .   hashWith SHA256
-        .   encodeUtf8
-        <$> getProductKey base
-    pure . toS $ start9AgentServicePrefix <> suffix
-
-getStart9AgentHostnameLocal :: (HasFilesystemBase sig m, MonadIO m) => m Text
-getStart9AgentHostnameLocal = getStart9AgentHostname <&> (<> ".local")
-
-publishAgentToAvahi :: ReaderT AgentCtx IO ()
-publishAgentToAvahi = do
-    filesystemBase     <- asks $ appFilesystemBase . appSettings
-    start9AgentService <- injectFilesystemBase filesystemBase getStart9AgentHostname
-    lift $ Avahi.createDaemonConf $ toS start9AgentService
-    agentPort <- asks $ appPort . appSettings
-    services  <- lift Avahi.listServices
-    let serviceNames = view basename <$> services
-    unless (start9AgentService `elem` serviceNames) $ withReaderT appSettings $ Avahi.createService
-        (toS start9AgentService)
-        (Avahi.WildcardsEnabled, "%h")
-        "_http._tcp"
-        agentPort
-    lift Avahi.reload
-    lift $ threadDelay 10_000_000
-    tid <- asks appLanThread >>= liftIO . takeMVar
-    liftIO $ killThread tid
-    tid' <- liftIO $ forkIO (runM . void . runExceptT @S9Error $ AppMgr2.runAppMgrCliC AppMgr2.lanEnable)
-    asks appLanThread >>= liftIO . flip putMVar tid'
-
-

agent/src/Foundation.hs

@@ -1,224 +0,0 @@
-{-# LANGUAGE CPP                   #-}
-{-# LANGUAGE InstanceSigs          #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE QuasiQuotes           #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE RankNTypes            #-}
-{-# LANGUAGE TemplateHaskell       #-}
-{-# LANGUAGE TypeFamilies          #-}
-{-# LANGUAGE ViewPatterns          #-}
-
-module Foundation where
-
-import           Startlude
-
-import qualified Control.Effect.Labelled       as FE
-import qualified Control.Carrier.Lift          as FE
-import           Control.Concurrent.STM
-import           Control.Monad.Base
-import           Control.Monad.Logger           ( LogSource )
-import           Control.Monad.Trans.Control
-import           Crypto.Hash                    ( MD5, Digest )
-import qualified Data.HashMap.Strict           as HM
-import           Data.IORef
-import           Data.Set
-import           Data.UUID
-import           Database.Persist              as Persist
-import           Database.Persist.Sql
-import           Network.HTTP.Client            (Manager)
-import           Network.HTTP.Types             (status200)
-import           Network.Wai
-import           Yesod.Core
-import           Yesod.Core.Types
-import           Yesod.Auth                     ( AuthenticationResult(..)
-                                                , Creds(..)
-                                                , YesodAuth(..)
-                                                , YesodAuthPersist
-                                                , maybeAuth
-                                                )
-import qualified Yesod.Auth.Message            as Msg
-import           Yesod.Form
-import qualified Yesod.Core.Unsafe             as Unsafe
-import           Yesod.Persist.Core
-
-import           Auth
-import           Constants
-import           Lib.Algebra.State.RegistryUrl
-import           Lib.Background
-import           Lib.Error
-import           Lib.External.Metrics.ProcDev
-import           Lib.SystemPaths
-import           Lib.Types.Core
-import           Lib.Types.Emver
-import           Model
-import           Settings
-
-
--- | The foundation datatype for your application. This can be a good place to
--- keep settings and values requiring initialization before your application
--- starts running, such as database connections. Every handler will have
--- access to the data present here.
-data OsVersionCache = OsVersionCache { osVersion :: Version, lastChecked :: UTCTime }
-
-data AgentCtx = AgentCtx
-    { appSettings                 :: AppSettings
-    , appHttpManager              :: Manager
-    , appTorManager               :: Manager
-    , appConnPool                 :: ConnectionPool -- ^ Database connection pool.
-    , appLogger                   :: Logger
-    , appWebServerThreadId        :: IORef (Maybe ThreadId)
-    , appIsUpdating               :: IORef (Maybe Version)
-    , appIsUpdateFailed           :: IORef (Maybe S9Error)
-    , appOsVersionLatest          :: IORef (Maybe OsVersionCache)
-    , appProcDevMomentCache       :: IORef (UTCTime, ProcDevMomentStats, ProcDevMetrics)
-    , appSelfUpdateSpecification  :: MVar VersionRange
-    , appBackgroundJobs           :: TVar JobCache
-    , appIconTags                 :: TVar (HM.HashMap AppId (Digest MD5))
-    , appLastTorRestart           :: IORef UTCTime
-    , appLanThread                :: MVar ThreadId
-    }
-
-setWebProcessThreadId :: ThreadId -> AgentCtx -> IO ()
-setWebProcessThreadId tid a = writeIORef (appWebServerThreadId a) . Just $ tid
-
--- This is where we define all of the routes in our application. For a full
--- explanation of the syntax, please see:
--- http://www.yesodweb.com/book/routing-and-handlers
---
--- Note that this is really half the story; in Application.hs, mkYesodDispatch
--- generates the rest of the code. Please see the following documentation
--- for an explanation for this split:
--- http://www.yesodweb.com/book/scaffolding-and-the-site-template#scaffolding-and-the-site-template_foundation_and_application_modules
---
--- This function also generates the following type synonyms:
--- type Handler = HandlerT AgentCtx IO
-mkYesodData "AgentCtx" $(parseRoutesFile "config/routes")
-
-noCacheUnlessSpecified :: Handler a -> Handler a
-noCacheUnlessSpecified action = do
-    getCurrentRoute >>= \case
-        Nothing -> action
-        Just r -> if "cached" `member` routeAttrs r
-            then action
-            else addHeader "Cache-Control" "no-store" >> action
--- Please see the documentation for the Yesod typeclass. There are a number
--- of settings which can be configured by overriding methods here.
-instance Yesod AgentCtx where
-    approot = ApprootRelative
-    authRoute _ = Nothing
-
-    isAuthorized route _ | "noAuth" `member` routeAttrs route = pure Authorized
-                         -- HACK! So that updating from 0.1.5 to 0.2.x doesn't leave you unreachable during system sync
-                         -- in the old companion
-                         | (fst $ renderRoute route) == ["v0"] = do
-                             isUpdating <- fmap isJust $ getsYesod appIsUpdating >>= liftIO . readIORef
-                             fresh <- fmap Startlude.null . runDB $ selectList ([] :: [Filter Account]) []
-                             if isUpdating && fresh
-                                 then sendResponseStatus status200 (object ["status" .= ("UPDATING" :: Text)])
-                                 else requireSessionAuth
-                         | otherwise                          = requireSessionAuth
-
--- Yesod Middleware allows you to run code before and after each handler function.
--- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks.
--- Some users may also want to add the defaultCsrfMiddleware, which:
---   a) Sets a cookie with a CSRF token in it.
---   b) Validates that incoming write requests include that token in either a header or POST parameter.
--- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
--- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
-    yesodMiddleware :: ToTypedContent res => Handler res -> Handler res
-    yesodMiddleware = defaultYesodMiddleware . cutoffDuringUpdate . noCacheUnlessSpecified
-
--- What messages should be logged. The following includes all messages when
--- in development, and warnings and errors in production.
-    shouldLogIO :: AgentCtx -> LogSource -> LogLevel -> IO Bool
-    shouldLogIO app _source level =
-        return $ appShouldLogAll (appSettings app) || level == LevelInfo || level == LevelWarn || level == LevelError
-
-    makeLogger :: AgentCtx -> IO Logger
-    makeLogger = return . appLogger
-
-    makeSessionBackend :: AgentCtx -> IO (Maybe SessionBackend)
-    makeSessionBackend ctx = strictSameSiteSessions $ do
-        filepath <- injectFilesystemBaseFromContext settings $ getAbsoluteLocationFor sessionSigningKeyPath
-        fmap Just $ defaultClientSessionBackend minutes $ toS filepath
-        where
-            settings = appSettings ctx
-            minutes = 7 * 24 * 60 -- 7 days
-
-instance RenderMessage AgentCtx FormMessage where
-    renderMessage _ _ = defaultFormMessage
-instance YesodAuth AgentCtx where
-    type AuthId AgentCtx = AccountId
-    loginDest _ = AuthenticateR
-    logoutDest _ = AuthenticateR
-    authPlugins _ = []
-
-    -- This gets called on login, but after HashDB's postLoginR handler is called.  This validates the username and password, so creds here are legit.
-    authenticate creds = liftHandler $ runDB $ do
-        x <- getBy $ UniqueAccount $ credsIdent creds
-        pure $ case x of
-            Just (Entity uid _) -> Authenticated uid
-            Nothing -> UserError Msg.NoIdentifierProvided
-
-instance YesodAuthPersist AgentCtx
-
--- How to run database actions.
-instance YesodPersist AgentCtx where
-    type YesodPersistBackend AgentCtx = SqlBackend
-    runDB :: SqlPersistT Handler a -> Handler a
-    runDB action = runSqlPool action . appConnPool =<< getYesod
-
-instance YesodPersistRunner AgentCtx where
-    getDBRunner :: Handler (DBRunner AgentCtx, Handler ())
-    getDBRunner = defaultGetDBRunner appConnPool
-
-unsafeHandler :: AgentCtx -> Handler a -> IO a
-unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
-
-appLogFunc :: AgentCtx -> LogFunc
-appLogFunc = appLogger >>= flip messageLoggerSource
-
-cutoffDuringUpdate :: Handler a -> Handler a
-cutoffDuringUpdate m = do
-    appIsUpdating <- getsYesod appIsUpdating >>= liftIO . readIORef
-    case appIsUpdating of
-        Just _ -> do
-            path <- asks $ pathInfo . reqWaiRequest . handlerRequest
-            case path of
-                [v] | v == "v" <> (show . major $ agentVersion) -> m
-                _ -> handleS9ErrT $ throwE UpdateInProgressE
-        Nothing -> m
-
--- Returns authorized iff there is a valid (non-expired, signed + encrypted) session containing an account.
--- The only way for such a session to exist is if a previous login succeeded
-requireSessionAuth :: Handler AuthResult
-requireSessionAuth = do
-#ifdef DISABLE_AUTH
-    pure Authorized
-#else
-    maybeAuth >>= \case
-        Nothing -> pure AuthenticationRequired
-        Just _  -> pure Authorized
-#endif
-
-type AgentRunner m =
-    RegistryUrlIOC (FE.Labelled "filesystemBase" (ReaderT Text) (FE.Labelled "httpManager" (ReaderT Manager) (FE.LiftC (ReaderT AgentCtx m))))
-
-runInContext :: MonadResource m => AgentRunner m a -> ReaderT AgentCtx m a
-runInContext action = do
-    ctx <- ask
-    let s = appSettings ctx
-    action
-        & runRegistryUrlIOC
-        & FE.runLabelled @"filesystemBase"
-        & flip runReaderT (appFilesystemBase s)
-        & FE.runLabelled @"httpManager"
-        & flip runReaderT (appHttpManager ctx)
-        & FE.runM
-
-instance MonadBase IO Handler where
-    liftBase m = HandlerFor $ const m
-instance MonadBaseControl IO Handler where
-    type StM Handler a = a
-    liftBaseWith f = HandlerFor $ \handlerData -> f (($ handlerData) . unHandlerFor)
-    restoreM = pure

agent/src/Handler/Apps.hs

@@ -1,825 +0,0 @@
-{-# LANGUAGE NamedFieldPuns   #-}
-{-# LANGUAGE QuasiQuotes      #-}
-{-# LANGUAGE RecordWildCards  #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell  #-}
-{-# LANGUAGE TupleSections    #-}
-{-# LANGUAGE TypeApplications #-}
-module Handler.Apps where
-
-import           Startlude               hiding ( Reader
-                                                , asks
-                                                , catchError
-                                                , empty
-                                                , execState
-                                                , forkFinally
-                                                , modify
-                                                , runReader
-                                                )
-
-import           Control.Carrier.Error.Church
-import           Control.Carrier.Lift
-import           Control.Carrier.Reader
-import qualified Control.Concurrent.Async.Lifted
-                                               as LAsync
-import qualified Control.Concurrent.Lifted     as Lifted
-import           Control.Concurrent.STM.TVar
-import           Control.Effect.Empty    hiding ( guard )
-import           Control.Effect.Labelled        ( HasLabelled
-                                                , Labelled
-                                                , runLabelled
-                                                )
-import qualified Control.Exception.Lifted      as Lifted
-import           Control.Lens            hiding ( (??) )
-import           Control.Monad.Logger
-import           Control.Monad.Trans.Control    ( MonadBaseControl )
-import           Crypto.Hash
-import           Data.Aeson
-import           Data.Aeson.Lens
-import           Data.Aeson.Types               ( parseMaybe )
-import qualified Data.ByteString.Lazy          as LBS
-import qualified Data.HashMap.Lazy             as HML
-import qualified Data.HashMap.Strict           as HM
-import           Data.IORef
-import qualified Data.List.NonEmpty            as NE
-import           Data.Singletons
-import           Data.Singletons.Prelude.Bool   ( If
-                                                , SBool(..)
-                                                )
-import           Data.Singletons.Prelude.List   ( Elem )
-import qualified Data.Text                     as Text
-import           Database.Persist
-import           Database.Persist.Sql           ( ConnectionPool )
-import           Database.Persist.Sqlite        ( runSqlPool )
-import           Exinst
-import           Network.HTTP.Types
-import qualified Network.JSONRPC               as JSONRPC
-import           Yesod.Core.Content
-import           Yesod.Core.Handler      hiding ( cached )
-import           Yesod.Core.Json
-import           Yesod.Core.Types               ( JSONResponse(..) )
-import           Yesod.Persist.Core
-
-import           Foundation
-import           Handler.Backups
-import           Handler.Icons
-import           Handler.Network
-import           Handler.Types.Apps
-import           Handler.Util
-import qualified Lib.Algebra.Domain.AppMgr     as AppMgr2
-import           Lib.Algebra.State.RegistryUrl
-import           Lib.Background
-import           Lib.Error
-import qualified Lib.External.AppManifest      as AppManifest
-import qualified Lib.External.AppMgr           as AppMgr
-import qualified Lib.External.Registry         as Reg
-import           Lib.IconCache
-import qualified Lib.Notifications             as Notifications
-import           Lib.SystemPaths
-import           Lib.TyFam.ConditionalData
-import           Lib.Types.Core
-import           Lib.Types.Emver
-import           Lib.Types.NetAddress
-import           Lib.Types.ServerApp
-import           Model
-import           Settings
-
-pureLog :: Show a => a -> Handler a
-pureLog = liftA2 (*>) ($logInfo . show) pure
-
-logRet :: ToJSON a => Handler a -> Handler a
-logRet = (>>= liftA2 (*>) ($logInfo . decodeUtf8 . LBS.toStrict . encode) pure)
-
-mkAppStatus :: HM.HashMap AppId (BackupJobType, a) -> AppId -> AppContainerStatus -> AppStatus
-mkAppStatus hm appId status = case HM.lookup appId hm of
-    Nothing                 -> AppStatusAppMgr status
-    Just (CreateBackup , _) -> AppStatusTmp CreatingBackup
-    Just (RestoreBackup, _) -> AppStatusTmp RestoringBackup
-
-
-type AllEffects m
-    = AppMgr2.AppMgrCliC
-          ( RegistryUrlIOC
-                ( Labelled
-                      "iconTagCache"
-                      (ReaderT (TVar (HM.HashMap AppId (Digest MD5))))
-                      ( Labelled
-                            "filesystemBase"
-                            (ReaderT Text)
-                            ( Labelled
-                                  "databaseConnection"
-                                  (ReaderT ConnectionPool)
-                                  (ReaderT AgentCtx (ErrorC S9Error (LiftC m)))
-                            )
-                      )
-                )
-          )
-
-intoHandler :: AllEffects Handler x -> Handler x
-intoHandler m = do
-    ctx <- getYesod
-    let fsbase = appFilesystemBase . appSettings $ ctx
-    runM
-        . handleS9ErrC
-        . flip runReaderT ctx
-        . flip runReaderT (appConnPool ctx)
-        . runLabelled @"databaseConnection"
-        . flip runReaderT fsbase
-        . runLabelled @"filesystemBase"
-        . flip runReaderT (appIconTags ctx)
-        . runLabelled @"iconTagCache"
-        . runRegistryUrlIOC
-        . AppMgr2.runAppMgrCliC
-        $ m
-{-# INLINE intoHandler #-}
-
--- TODO nasty. Also, note that if AppMgr.getInstalledApp fails for any app we will not return available apps res.
-getAvailableAppsR :: Handler (JSONResponse [AppAvailablePreview])
-getAvailableAppsR = disableEndpointOnFailedUpdate . intoHandler $ JSONResponse <$> getAvailableAppsLogic
-
-getAvailableAppsLogic :: ( Has (Reader AgentCtx) sig m
-                         , Has (Error S9Error) sig m
-                         , Has RegistryUrl sig m
-                         , Has AppMgr2.AppMgr sig m
-                         , MonadIO m
-                         , MonadBaseControl IO m
-                         )
-                      => m [AppAvailablePreview]
-getAvailableAppsLogic = do
-    jobCache <- asks appBackgroundJobs >>= liftIO . readTVarIO
-    let installCache = inspect SInstalling jobCache
-    (Reg.AppManifestRes apps, serverApps) <- LAsync.concurrently Reg.getAppManifest
-                                                                 (AppMgr2.list [AppMgr2.flags|-s -d|])
-    let remapped = remapAppMgrInfo jobCache serverApps
-    pure $ foreach apps $ \app@StoreApp { storeAppId } ->
-        let installing =
-                (   (storeAppVersionInfoVersion . snd . installInfo &&& const (AppStatusTmp Installing))
-                .   fst
-                <$> HM.lookup storeAppId installCache
-                )
-            installed = ((view _2 &&& view _1) <$> HM.lookup storeAppId remapped)
-        in  storeAppToAvailablePreview app $ installing <|> installed
-
-getAvailableAppByIdR :: AppId -> Handler (JSONResponse AppAvailableFull)
-getAvailableAppByIdR appId =
-    disableEndpointOnFailedUpdate . intoHandler $ JSONResponse <$> getAvailableAppByIdLogic appId
-
-getAvailableAppByIdLogic :: ( Has (Reader AgentCtx) sig m
-                            , Has (Error S9Error) sig m
-                            , Has RegistryUrl sig m
-                            , Has AppMgr2.AppMgr sig m
-                            , MonadIO m
-                            , MonadBaseControl IO m
-                            )
-                         => AppId
-                         -> m AppAvailableFull
-getAvailableAppByIdLogic appId = do
-    let storeAppId' = storeAppId
-    jobCache <- asks appBackgroundJobs >>= liftIO . readTVarIO
-    let installCache = inspect SInstalling jobCache
-    (Reg.AppManifestRes storeApps, serverApps) <- LAsync.concurrently Reg.getAppManifest
-                                                                      (AppMgr2.list [AppMgr2.flags|-s -d|])
-    StoreApp {..} <- pure (find ((== appId) . storeAppId) storeApps) `orThrowM` NotFoundE "appId" (show appId)
-    let remapped = remapAppMgrInfo jobCache serverApps
-    let installingInfo =
-            (   (storeAppVersionInfoVersion . snd . installInfo &&& const (AppStatusTmp Installing))
-                .   fst
-                <$> HM.lookup appId installCache
-                )
-                <|> ((view _2 &&& view _1) <$> HM.lookup appId remapped)
-    let latest = extract storeAppVersions
-    dependencies <- AppMgr2.checkDependencies (AppMgr2.LocalOnly False)
-                                              appId
-                                              (Just . exactly $ storeAppVersionInfoVersion latest)
-    enrichedDeps <- maybe (throwError (NotFoundE "dependencyId for" (show appId))) pure $ flip
-        HML.traverseWithKey
-        dependencies
-        \depId depInfo ->
-            let
-                base = storeAppToAppBase <$> find ((== depId) . storeAppId') storeApps
-                status =
-                    (HM.lookup depId installCache $> AppStatusTmp Installing) <|> (view _1 <$> HM.lookup depId remapped)
-            in
-                (, status, depInfo) <$> base
-    let dependencyRequirements = fmap (dependencyInfoToDependencyRequirement (AsInstalled SFalse)) enrichedDeps
-    pure AppAvailableFull
-        { appAvailableFullBase                   = AppBase
-                                                       appId
-                                                       storeAppTitle
-                                                       (storeIconUrl appId (storeAppVersionInfoVersion $ extract storeAppVersions))
-        , appAvailableFullInstallInfo            = installingInfo
-        , appAvailableFullVersionLatest          = storeAppVersionInfoVersion latest
-        , appAvailableFullDescriptionShort       = storeAppDescriptionShort
-        , appAvailableFullDescriptionLong        = storeAppDescriptionLong
-        , appAvailableFullReleaseNotes           = storeAppVersionInfoReleaseNotes latest
-        , appAvailableFullDependencyRequirements = HM.elems dependencyRequirements
-        , appAvailableFullVersions               = storeAppVersionInfoVersion <$> storeAppVersions
-        , appAvailableFullInstallAlert           = storeAppVersionInfoInstallAlert latest
-        }
-
-getAppLogsByIdR :: AppId -> Handler (JSONResponse [Text])
-getAppLogsByIdR appId = disableEndpointOnFailedUpdate $ handleS9ErrT $ do
-    logs <- AppMgr.getAppLogs appId
-    pure . JSONResponse . lines $ logs
-
-getInstalledAppsR :: Handler (JSONResponse [AppInstalledPreview])
-getInstalledAppsR = disableEndpointOnFailedUpdate . intoHandler $ JSONResponse <$> getInstalledAppsLogic
-
-cached :: MonadIO m => m a -> m (m a)
-cached action = do
-    ref <- liftIO $ newIORef Nothing
-    pure $ liftIO (readIORef ref) >>= \case
-        Nothing -> action >>= liftA2 (*>) (liftIO . writeIORef ref . Just) pure
-        Just x  -> pure x
-
-getInstalledAppsLogic :: (Has (Reader AgentCtx) sig m, Has AppMgr2.AppMgr sig m, MonadIO m) => m [AppInstalledPreview]
-getInstalledAppsLogic = do
-    jobCache <- asks appBackgroundJobs >>= liftIO . readTVarIO
-    let installCache = installInfo . fst <$> inspect SInstalling jobCache
-    serverApps <- AppMgr2.list [AppMgr2.flags|-s -d -m|]
-    let remapped           = remapAppMgrInfo jobCache serverApps
-        installingPreviews = flip
-            HM.mapWithKey
-            installCache
-            \installingId (StoreApp {..}, StoreAppVersionInfo {..}) -> AppInstalledPreview
-                { appInstalledPreviewBase             = AppBase installingId
-                                                                storeAppTitle
-                                                                (iconUrl installingId storeAppVersionInfoVersion)
-                , appInstalledPreviewStatus           = AppStatusTmp Installing
-                , appInstalledPreviewVersionInstalled = storeAppVersionInfoVersion
-                , appInstalledPreviewTorAddress       = Nothing
-                , appInstalledPreviewLanAddress       = Nothing
-                , appInstalledPreviewTorUi            = False
-                , appInstalledPreviewLanUi            = False
-                }
-        installedPreviews = flip
-            HML.mapWithKey
-            remapped
-            \appId (s, v, AppMgr2.InfoRes {..}) ->
-                let
-                    mLanAddress = do -- Maybe
-                        addrBase <- infoResTorAddress
-                        let
-                            lanConfs = mapMaybe AppManifest.portMapEntryLan
-                                $ AppManifest.appManifestPortMapping infoResManifest
-                        guard (not . null $ lanConfs)
-                        pure $ LanAddress . (".onion" `Text.replace` ".local") . unTorAddress $ addrBase
-                in  AppInstalledPreview { appInstalledPreviewBase = AppBase appId infoResTitle (iconUrl appId v)
-                                        , appInstalledPreviewStatus = s
-                                        , appInstalledPreviewVersionInstalled = v
-                                        , appInstalledPreviewTorAddress = infoResTorAddress
-                                        , appInstalledPreviewLanAddress = mLanAddress
-                                        , appInstalledPreviewTorUi = AppManifest.torUiAvailable infoResManifest
-                                        , appInstalledPreviewLanUi = AppManifest.lanUiAvailable infoResManifest
-                                        }
-
-    pure $ HML.elems $ HML.union installingPreviews installedPreviews
-
-getInstalledAppByIdR :: AppId -> Handler (JSONResponse AppInstalledFull)
-getInstalledAppByIdR appId =
-    disableEndpointOnFailedUpdate . intoHandler $ JSONResponse <$> getInstalledAppByIdLogic appId
-
-getInstalledAppByIdLogic :: ( Has (Reader AgentCtx) sig m
-                            , Has RegistryUrl sig m
-                            , Has (Error S9Error) sig m
-                            , Has AppMgr2.AppMgr sig m
-                            , MonadIO m
-                            , MonadBaseControl IO m
-                            )
-                         => AppId
-                         -> m AppInstalledFull
-getInstalledAppByIdLogic appId = do
-    jobCache <- asks appBackgroundJobs >>= liftIO . readTVarIO
-    let installCache = installInfo . fst <$> inspect SInstalling jobCache
-    db          <- asks appConnPool
-    backupTime' <- LAsync.async $ liftIO $ flip runSqlPool db $ getLastSuccessfulBackup appId
-    let installing = do
-            backupTime <- lift $ LAsync.wait backupTime'
-            hoistMaybe $ HM.lookup appId installCache <&> \(StoreApp {..}, StoreAppVersionInfo {..}) -> AppInstalledFull
-                { appInstalledFullBase = AppBase appId storeAppTitle (iconUrl appId storeAppVersionInfoVersion)
-                , appInstalledFullStatus                 = AppStatusTmp Installing
-                , appInstalledFullVersionInstalled       = storeAppVersionInfoVersion
-                , appInstalledFullInstructions           = Nothing
-                , appInstalledFullLastBackup             = backupTime
-                , appInstalledFullTorAddress             = Nothing
-                , appInstalledFullLanAddress             = Nothing
-                , appInstalledFullTorUi                  = False
-                , appInstalledFullLanUi                  = False
-                , appInstalledFullConfiguredRequirements = []
-                , appInstalledFullUninstallAlert         = Nothing
-                , appInstalledFullRestoreAlert           = Nothing
-                , appInstalledFullStartAlert             = Nothing
-                , appInstalledFullActions                = []
-                }
-    serverApps <- AppMgr2.list [AppMgr2.flags|-s -d|]
-    let remapped = remapAppMgrInfo jobCache serverApps
-    appManifestFetchCached <- cached Reg.getAppManifest
-    let
-        installed = do
-            (status, version, AppMgr2.InfoRes {..}) <- hoistMaybe (HM.lookup appId remapped)
-            manifest' <- lift $ LAsync.async $ AppMgr2.infoResManifest <<$>> AppMgr2.info [AppMgr2.flags|-M|] appId
-            instructions'                           <- lift $ LAsync.async $ AppMgr2.instructions appId
-            requirements                            <- LAsync.runConcurrently $ flip
-                HML.traverseWithKey
-                (HML.filter AppMgr2.dependencyInfoRequired infoResDependencies)
-                \depId depInfo -> LAsync.Concurrently $ do
-                    let
-                        fromInstalled = (AppMgr2.infoResTitle &&& AppMgr2.infoResVersion)
-                            <$> hoistMaybe (HM.lookup depId serverApps)
-                    let fromStore = do
-                            Reg.AppManifestRes res <- lift appManifestFetchCached
-                            (storeAppTitle &&& storeAppVersionInfoVersion . extract . storeAppVersions)
-                                <$> hoistMaybe (find ((== depId) . storeAppId) res)
-                    (title, v) <- fromInstalled <|> fromStore
-                    let base = AppBase depId title (iconUrl depId v)
-                    let
-                        depStatus =
-                            (HM.lookup depId installCache $> AppStatusTmp Installing)
-                                <|> (view _1 <$> HM.lookup depId remapped)
-                    pure $ dependencyInfoToDependencyRequirement (AsInstalled STrue) (base, depStatus, depInfo)
-            manifest <- (lift $ LAsync.wait manifest') >>= \case
-                Nothing -> throwError $ NotFoundE "manifest" (show appId)
-                Just x  -> pure x
-            instructions <- lift $ LAsync.wait instructions'
-            backupTime   <- lift $ LAsync.wait backupTime'
-            let lanAddress = do
-                    addrBase <- infoResTorAddress
-                    let lanConfs = mapMaybe AppManifest.portMapEntryLan $ AppManifest.appManifestPortMapping manifest
-                    guard (not . null $ lanConfs)
-                    pure $ LanAddress . (".onion" `Text.replace` ".local") . unTorAddress $ addrBase
-            pure AppInstalledFull { appInstalledFullBase = AppBase appId infoResTitle (iconUrl appId version)
-                                  , appInstalledFullStatus                 = status
-                                  , appInstalledFullVersionInstalled       = version
-                                  , appInstalledFullInstructions           = instructions
-                                  , appInstalledFullLastBackup             = backupTime
-                                  , appInstalledFullTorAddress             = infoResTorAddress
-                                  , appInstalledFullLanAddress             = lanAddress
-                                  , appInstalledFullTorUi                  = AppManifest.torUiAvailable manifest
-                                  , appInstalledFullLanUi                  = AppManifest.lanUiAvailable manifest
-                                  , appInstalledFullConfiguredRequirements = HM.elems requirements
-                                  , appInstalledFullUninstallAlert = AppManifest.appManifestUninstallAlert manifest
-                                  , appInstalledFullRestoreAlert = AppManifest.appManifestRestoreAlert manifest
-                                  , appInstalledFullStartAlert             = AppManifest.appManifestStartAlert manifest
-                                  , appInstalledFullActions                = AppManifest.appManifestActions manifest
-                                  }
-    runMaybeT (installing <|> installed) `orThrowM` NotFoundE "appId" (show appId)
-
-postUninstallAppR :: AppId -> Handler (JSONResponse (WithBreakages ()))
-postUninstallAppR appId = do
-    dry <- AppMgr2.DryRun . isJust <$> lookupGetParam "dryrun"
-    disableEndpointOnFailedUpdate . intoHandler $ JSONResponse <$> postUninstallAppLogic appId dry
-
-postUninstallAppLogic :: ( HasFilesystemBase sig m
-                         , Has (Reader AgentCtx) sig m
-                         , Has (Error S9Error) sig m
-                         , Has AppMgr2.AppMgr sig m
-                         , MonadIO m
-                         , HasLabelled "databaseConnection" (Reader ConnectionPool) sig m
-                         , HasLabelled "iconTagCache" (Reader (TVar (HM.HashMap AppId (Digest MD5)))) sig m
-                         )
-                      => AppId
-                      -> AppMgr2.DryRun
-                      -> m (WithBreakages ())
-postUninstallAppLogic appId dryrun = do
-    jobCache <- asks appBackgroundJobs >>= liftIO . readTVarIO
-    let tmpStatuses = statuses jobCache
-    serverApps <- AppMgr2.list [AppMgr2.flags| |]
-    when (not $ HM.member appId serverApps) $ throwError (AppNotInstalledE appId)
-    case HM.lookup appId tmpStatuses of
-        Just Installing      -> throwError (TemporarilyForbiddenE appId "uninstall" (show Installing))
-        Just CreatingBackup  -> throwError (TemporarilyForbiddenE appId "uninstall" (show CreatingBackup))
-        Just RestoringBackup -> throwError (TemporarilyForbiddenE appId "uninstall" (show RestoringBackup))
-        _                    -> pure ()
-    let flags = if coerce dryrun then Left dryrun else Right (AppMgr2.Purge True)
-    breakageIds <- HM.keys . AppMgr2.unBreakageMap <$> AppMgr2.remove flags appId
-    bs <- pure (traverse (hydrate $ (AppMgr2.infoResTitle &&& AppMgr2.infoResVersion) <$> serverApps) breakageIds)
-        `orThrowM` InternalE "Reported app breakage for app that isn't installed, contact support"
-    when (not $ coerce dryrun) $ do
-        clearIcon appId
-        postResetLanLogic
-    pure $ WithBreakages bs ()
-
-type InstallResponse :: Bool -> Type
-data InstallResponse a = InstallResponse (If a (WithBreakages ()) AppInstalledFull)
-instance ToJSON (Some1 InstallResponse) where
-    toJSON (Some1 STrue  (InstallResponse a)) = toJSON a
-    toJSON (Some1 SFalse (InstallResponse a)) = toJSON a
-postInstallNewAppR :: AppId -> Handler (JSONResponse (Some1 InstallResponse))
-postInstallNewAppR appId = do
-    dryrun <- isJust <$> lookupGetParam "dryrun"
-    InstallNewAppReq { installNewAppVersion } <- requireCheckJsonBody
-    disableEndpointOnFailedUpdate . intoHandler $ JSONResponse <$> do
-        withSomeSing dryrun $ \sb -> Some1 sb . InstallResponse <$> postInstallNewAppLogic appId installNewAppVersion sb
-
-postInstallNewAppLogic :: forall sig m a
-                        . ( Has (Reader AgentCtx) sig m
-                          , HasLabelled "databaseConnection" (Reader ConnectionPool) sig m
-                          , HasLabelled "iconTagCache" (Reader (TVar (HM.HashMap AppId (Digest MD5)))) sig m
-                          , Has (Error S9Error) sig m
-                          , Has RegistryUrl sig m
-                          , Has AppMgr2.AppMgr sig m
-                          , HasFilesystemBase sig m
-                          , MonadIO m
-                          , MonadBaseControl IO m
-                          )
-                       => AppId
-                       -> Version
-                       -> SBool a
-                       -> m (If a (WithBreakages ()) AppInstalledFull)
-postInstallNewAppLogic appId appVersion dryrun = do
-    db   <- asks appConnPool
-    full <- (Just <$> getInstalledAppByIdLogic appId) `catchError` \case
-        NotFoundE "appId" appId' ->
-            if AppId appId' == appId then pure Nothing else throwError (NotFoundE "appId" appId')
-        other -> throwError other
-    case full of
-        Just aif@AppInstalledFull{} -> if appInstalledFullVersionInstalled aif == appVersion
-            then pure $ case dryrun of
-                STrue  -> WithBreakages [] ()
-                SFalse -> aif
-            else installIt db True
-        Nothing -> installIt db False
-    where
-        installIt :: ConnectionPool -> Bool -> m (If a (WithBreakages ()) AppInstalledFull)
-        installIt db isUpdate = do
-            jobCacheTVar                <- asks appBackgroundJobs
-            store@StoreApp {..}         <- Reg.getStoreAppInfo appId `orThrowM` NotFoundE "appId" (show appId)
-            vinfo@StoreAppVersionInfo{} <-
-                find ((== appVersion) . storeAppVersionInfoVersion) storeAppVersions
-                    `orThrowPure` NotFoundE "version" (show appVersion)
-            -- if it is a dry run of an update we don't want to modify the cache
-            case dryrun of
-                STrue -> if not isUpdate
-                    then pure $ WithBreakages [] ()
-                    else do
-                        serverApps' <- LAsync.async $ AppMgr2.list [AppMgr2.flags| |]
-                        hm          <- AppMgr2.update (AppMgr2.DryRun True) appId (Just $ exactly appVersion)
-                        (serverApps :: HM.HashMap AppId (AppMgr2.InfoRes ( 'Right '[]))) <- LAsync.wait serverApps'
-                        breakages   <-
-                            traverse (hydrate ((AppMgr2.infoResTitle &&& AppMgr2.infoResVersion) <$> serverApps))
-                                     (HM.keys $ AppMgr2.unBreakageMap hm)
-                                `orThrowPure` InternalE
-                                                  "Breakage reported for app that isn't installed, contact support"
-                        pure $ WithBreakages breakages ()
-                SFalse -> do
-                    let
-                        action = do
-                            iconAction <- LAsync.async $ saveIcon (toS storeAppIconUrl)
-                            let install = if isUpdate
-                                    then void $ AppMgr2.update (AppMgr2.DryRun False) appId (Just $ exactly appVersion)
-                                    else AppMgr2.install (AppMgr2.NoCache True) appId (Just $ exactly appVersion)
-                            let
-                                success = liftIO $ void $ flip runSqlPool db $ Notifications.emit
-                                    appId
-                                    appVersion
-                                    Notifications.InstallSuccess
-                            let failure e = liftIO $ do
-                                    let notif = case e of
-                                            AppMgrE _ ec -> Notifications.InstallFailedAppMgrExitCode ec
-                                            _            -> Notifications.InstallFailedS9Error e
-                                    void $ flip runSqlPool db $ Notifications.emit appId appVersion notif
-                                    putStrLn @Text (show e)
-                            let todo = do
-                                    install
-                                    () <- LAsync.wait iconAction
-                                    success
-                            todo `catchError` failure
-                    tid <- action `Lifted.forkFinally` const postInstall
-                    liftIO $ atomically $ modifyTVar' jobCacheTVar (insertJob appId (Install store vinfo) tid)
-                    getInstalledAppByIdLogic appId
-        postInstall :: m ()
-        postInstall = do
-            jobCache <- asks appBackgroundJobs
-            pool     <- asks appConnPool
-            liftIO . atomically $ modifyTVar jobCache (deleteJob appId)
-            ls <- AppMgr2.list [AppMgr2.flags| |]
-            LAsync.forConcurrently_ (HM.toList ls) $ \(k, AppMgr2.InfoRes {..}) -> when
-                infoResNeedsRestart
-                (            postRestartServerAppLogic k
-                `catchError` \e -> liftIO $ runSqlPool
-                                 (void $ Notifications.emit k infoResVersion (Notifications.RestartFailed e))
-                                 pool
-                )
-            postResetLanLogic
-
-
-postStartServerAppR :: AppId -> Handler ()
-postStartServerAppR appId = disableEndpointOnFailedUpdate . intoHandler $ postStartServerAppLogic appId
-
-postStartServerAppLogic :: (Has (Error S9Error) sig m, Has AppMgr2.AppMgr sig m, Has (Reader AgentCtx) sig m, MonadIO m)
-                        => AppId
-                        -> m ()
-postStartServerAppLogic appId = do
-    jobCache       <- asks appBackgroundJobs >>= liftIO . readTVarIO
-    info           <- AppMgr2.info [AppMgr2.flags|-s -d|] appId `orThrowM` AppNotInstalledE appId
-    (status, _, _) <- (HM.lookup appId $ remapAppMgrInfo jobCache (HM.singleton appId info))
-        `orThrowPure` InternalE "Remapping magically deleted keys between source and target structures"
-    case status of
-        AppStatusAppMgr Stopped -> AppMgr2.start appId
-        other                   -> throwError $ AppStateActionIncompatibleE appId other Start
-
-postRestartServerAppR :: AppId -> Handler ()
-postRestartServerAppR appId = disableEndpointOnFailedUpdate . intoHandler $ postRestartServerAppLogic appId
-
-postRestartServerAppLogic :: ( Has (Reader AgentCtx) sig m
-                             , Has AppMgr2.AppMgr sig m
-                             , Has (Error S9Error) sig m
-                             , MonadBaseControl IO m
-                             , MonadIO m
-                             )
-                          => AppId
-                          -> m ()
-postRestartServerAppLogic appId = do
-    jobCache <- asks appBackgroundJobs
-    answer   <- Lifted.newEmptyMVar
-    void . Lifted.fork $ do
-        tid     <- Lifted.myThreadId
-        problem <- liftIO . atomically $ do
-            JobCache jobs <- readTVar jobCache
-            case HM.lookup appId jobs of
-                Just (Some1 s _, _) -> pure (Just . throwError $ TemporarilyForbiddenE appId "restart" (show s))
-                Nothing             -> do
-                    modifyTVar jobCache (insertJob appId RestartApp tid)
-                    pure Nothing
-        case problem of
-            Nothing -> do
-                AppMgr2.restart appId `Lifted.finally` (liftIO . atomically) (modifyTVar jobCache (deleteJob appId))
-                Lifted.putMVar answer Nothing
-            Just p -> Lifted.putMVar answer (Just p)
-    Lifted.takeMVar answer >>= \case
-        Nothing -> pure ()
-        Just p  -> p
-
-
-postStopServerAppR :: AppId -> Handler (JSONResponse (WithBreakages ()))
-postStopServerAppR appId = disableEndpointOnFailedUpdate do
-    dryrun <- isJust <$> lookupGetParam "dryrun"
-    mRes   <- intoHandler $ runMaybeT (JSONResponse <$> postStopServerAppLogic appId (AppMgr2.DryRun dryrun))
-    case mRes of
-        Nothing -> sendResponseStatus status200 ()
-        Just x  -> pure x
-
-postStopServerAppLogic :: ( Has Empty sig m
-                          , Has (Reader AgentCtx) sig m
-                          , Has (Error S9Error) sig m
-                          , Has AppMgr2.AppMgr sig m
-                          , MonadIO m
-                          , MonadBaseControl IO m
-                          )
-                       => AppId
-                       -> AppMgr2.DryRun
-                       -> m (WithBreakages ())
-postStopServerAppLogic appId dryrun = do
-    jobCache <- asks appBackgroundJobs
-    titles   <- (AppMgr2.infoResTitle &&& AppMgr2.infoResVersion) <<$>> AppMgr2.list [AppMgr2.flags| |]
-    let stopIt = do
-            breakages <- AppMgr2.stop dryrun appId
-            bases     <- traverse (hydrate titles) (HM.keys $ AppMgr2.unBreakageMap breakages)
-                `orThrowPure` InternalE "Breakages reported for app that isn't installed, contact support"
-            pure $ WithBreakages bases ()
-    status <- AppMgr2.infoResStatus <<$>> AppMgr2.info [AppMgr2.flags|-S|] appId
-    case (dryrun, status) of
-        (_                   , Nothing     ) -> throwError $ NotFoundE "appId" (show appId)
-        (AppMgr2.DryRun False, Just Running) -> do
-            tid <- (void stopIt)
-                `Lifted.forkFinally` const ((liftIO . atomically) (modifyTVar jobCache (deleteJob appId)))
-            liftIO . atomically $ modifyTVar jobCache (insertJob appId StopApp tid)
-            empty
-        (AppMgr2.DryRun True , Just Running   ) -> stopIt
-        (AppMgr2.DryRun False, Just Restarting) -> do
-            tid <- (void stopIt)
-                `Lifted.forkFinally` const ((liftIO . atomically) (modifyTVar jobCache (deleteJob appId)))
-            liftIO . atomically $ modifyTVar jobCache (insertJob appId StopApp tid)
-            empty
-        (AppMgr2.DryRun True, Just Restarting) -> stopIt
-        (_, Just other) -> throwError $ AppStateActionIncompatibleE appId (AppStatusAppMgr other) Stop
-
-getAppConfigR :: AppId -> Handler TypedContent
-getAppConfigR =
-    disableEndpointOnFailedUpdate
-        . handleS9ErrT
-        . fmap (TypedContent typeJson . toContent)
-        . AppMgr.getConfigurationAndSpec
-
-patchAppConfigR :: AppId -> Handler (JSONResponse (WithBreakages ()))
-patchAppConfigR appId = disableEndpointOnFailedUpdate $ do
-    dryrun  <- isJust <$> lookupGetParam "dryrun"
-    value   <- requireCheckJsonBody @_ @Value
-    realVal <-
-        runM . handleS9ErrC $ ((value ^? key "config") `orThrowPure` (InvalidRequestE value "Missing 'config' key"))
-    intoHandler $ JSONResponse <$> patchAppConfigLogic appId (AppMgr2.DryRun dryrun) realVal
-
-patchAppConfigLogic :: ( Has (Reader AgentCtx) sig m
-                       , Has (Error S9Error) sig m
-                       , Has AppMgr2.AppMgr sig m
-                       , MonadBaseControl IO m
-                       , MonadIO m
-                       )
-                    => AppId
-                    -> AppMgr2.DryRun
-                    -> Value
-                    -> m (WithBreakages ())
-patchAppConfigLogic appId dryrun cfg = do
-    serverApps                <- AppMgr2.list [AppMgr2.flags| |]
-    AppMgr2.ConfigureRes {..} <- AppMgr2.configure dryrun appId (Just cfg)
-    when (not $ coerce dryrun) $ for_ configureResNeedsRestart postRestartServerAppLogic
-    breakages <-
-        traverse (hydrate ((AppMgr2.infoResTitle &&& AppMgr2.infoResVersion) <$> serverApps))
-                 (HM.keys configureResStopped)
-            `orThrowPure` InternalE "Breakage reported for app that is not installed, contact support"
-    pure $ WithBreakages breakages ()
-
-
-getAppNotificationsR :: AppId -> Handler (JSONResponse [Entity Notification])
-getAppNotificationsR appId = disableEndpointOnFailedUpdate $ runDB $ do
-    page     <- lookupGetParam "page" `orDefaultTo` 1
-    pageSize <- lookupGetParam "perPage" `orDefaultTo` 20
-    evs      <- selectList [NotificationAppId ==. appId]
-                           [Desc NotificationCreatedAt, LimitTo pageSize, OffsetBy ((page - 1) * pageSize)]
-    let toArchive = fmap entityKey $ filter ((== Nothing) . notificationArchivedAt . entityVal) evs
-    void $ Notifications.archive toArchive
-    pure $ JSONResponse evs
-    where
-        orDefaultTo :: (Monad m, Read a) => m (Maybe Text) -> a -> m a
-        orDefaultTo m a = do
-            m' <- m
-            case m' >>= readMaybe . toS of
-                Nothing -> pure a
-                Just x  -> pure x
-
-getAppMetricsR :: AppId -> Handler TypedContent
-getAppMetricsR appId =
-    disableEndpointOnFailedUpdate . handleS9ErrT $ fmap (TypedContent typeJson . toContent) $ AppMgr.stats appId
-
-getAvailableAppVersionInfoR :: AppId -> VersionRange -> Handler (JSONResponse AppVersionInfo)
-getAvailableAppVersionInfoR appId version =
-    disableEndpointOnFailedUpdate . intoHandler $ JSONResponse <$> getAvailableAppVersionInfoLogic appId version
-
-getAvailableAppVersionInfoLogic :: ( Has (Reader AgentCtx) sig m
-                                   , Has (Error S9Error) sig m
-                                   , Has RegistryUrl sig m
-                                   , Has AppMgr2.AppMgr sig m
-                                   , MonadIO m
-                                   , MonadBaseControl IO m
-                                   )
-                                => AppId
-                                -> VersionRange
-                                -> m AppVersionInfo
-getAvailableAppVersionInfoLogic appId appVersionSpec = do
-    jobCache                     <- asks appBackgroundJobs >>= liftIO . readTVarIO
-    Reg.AppManifestRes storeApps <- Reg.getAppManifest
-    let titles =
-            (storeAppTitle &&& storeAppVersionInfoVersion . extract . storeAppVersions) <$> indexBy storeAppId storeApps
-    StoreApp {..} <- find ((== appId) . storeAppId) storeApps `orThrowPure` NotFoundE "appId" (show appId)
-    serverApps    <- AppMgr2.list [AppMgr2.flags|-s -d|]
-    let remapped = remapAppMgrInfo jobCache serverApps
-    StoreAppVersionInfo {..} <-
-        maximumMay (NE.filter ((<|| appVersionSpec) . storeAppVersionInfoVersion) storeAppVersions)
-            `orThrowPure` NotFoundE "version spec " (show appVersionSpec)
-    dependencies <- AppMgr2.checkDependencies (AppMgr2.LocalOnly False)
-                                              appId
-                                              (Just $ exactly storeAppVersionInfoVersion)
-    requirements <- flip HML.traverseWithKey dependencies $ \depId depInfo -> do
-        base <- hydrate titles depId `orThrowPure` NotFoundE "metadata for" (show depId)
-        let status =
-                (HM.lookup depId (inspect SInstalling jobCache) $> AppStatusTmp Installing)
-                    <|> (view _1 <$> HM.lookup depId remapped)
-        pure $ dependencyInfoToDependencyRequirement (AsInstalled SFalse) (base, status, depInfo)
-    pure AppVersionInfo { appVersionInfoVersion                = storeAppVersionInfoVersion
-                        , appVersionInfoReleaseNotes           = storeAppVersionInfoReleaseNotes
-                        , appVersionInfoDependencyRequirements = HM.elems requirements
-                        , appVersionInfoInstallAlert           = storeAppVersionInfoInstallAlert
-                        }
-
-postAutoconfigureR :: AppId -> AppId -> Handler (JSONResponse (WithBreakages AutoconfigureChangesRes))
-postAutoconfigureR dependency dependent = do
-    dry <- AppMgr2.DryRun . isJust <$> lookupGetParam "dryrun"
-    disableEndpointOnFailedUpdate . intoHandler $ JSONResponse <$> postAutoconfigureLogic dependency dependent dry
-
-postAutoconfigureLogic :: ( Has (Reader AgentCtx) sig m
-                          , Has AppMgr2.AppMgr sig m
-                          , Has (Error S9Error) sig m
-                          , MonadBaseControl IO m
-                          , MonadIO m
-                          )
-                       => AppId
-                       -> AppId
-                       -> AppMgr2.DryRun
-                       -> m (WithBreakages AutoconfigureChangesRes)
-postAutoconfigureLogic dependency dependent dry = do
-    -- IMPORTANT! AppMgr reverses arguments from the endpoint
-    appData <- AppMgr2.list [AppMgr2.flags| |]
-    let apps = HM.keys appData
-    case (dependency `elem` apps, dependent `elem` apps) of
-        (False, _    ) -> throwError $ NotFoundE "appId" (show dependency)
-        (_    , False) -> throwError $ NotFoundE "appId" (show dependent)
-        _              -> pure ()
-    AppMgr2.AutoconfigureRes {..} <- AppMgr2.autoconfigure dry dependent dependency
-    when (not $ coerce dry) $ for_ (AppMgr2.configureResNeedsRestart autoconfigureConfigRes) postRestartServerAppLogic
-    let titles = (AppMgr2.infoResTitle &&& AppMgr2.infoResVersion) <$> appData
-    bases <- traverse (hydrate titles) (HM.keys (AppMgr2.configureResStopped autoconfigureConfigRes))
-        `orThrowPure` InternalE "Breakages reported for app that isn't installed, contact support"
-    pure $ WithBreakages bases (AutoconfigureChangesRes $ HM.lookup dependency autoconfigureChanged)
-
-indexBy :: (Eq k, Hashable k) => (v -> k) -> [v] -> HM.HashMap k v
-indexBy = flip foldr HM.empty . (>>= HM.insertWith const)
-{-# INLINE indexBy #-}
-
-hydrate :: HM.HashMap AppId (Text, Version) -> AppId -> Maybe AppBase
-hydrate titles appId = HM.lookup appId titles <&> \(t, v) -> AppBase appId t (iconUrl appId v)
-
-remapAppMgrInfo :: (Elem 'AppMgr2.IncludeDependencies ls ~ 'True, Elem 'AppMgr2.IncludeStatus ls ~ 'True)
-                => JobCache
-                -> HM.HashMap AppId (AppMgr2.InfoRes ( 'Right ls)) -- ^ AppMgr response
-                -> HM.HashMap AppId (AppStatus, Version, AppMgr2.InfoRes ( 'Right ls))
-remapAppMgrInfo jobCache serverApps = flip
-    HML.mapWithKey
-    serverApps
-    \appId infoRes@AppMgr2.InfoRes {..} ->
-        let refinedDepInfo = flip
-                HML.mapWithKey
-                infoResDependencies
-                \depId depInfo ->
-                    case
-                            ( HM.lookup depId tmpStatuses
-                            , AppMgr2.infoResStatus <$> HM.lookup depId serverApps
-                            , AppMgr2.dependencyInfoError depInfo
-                            )
-                        of
-                            -- mute all of the not-running violations that are currently backing up and container is paused
-                            (Just CreatingBackup, Just Paused, Just AppMgr2.NotRunning) ->
-                                depInfo { AppMgr2.dependencyInfoError = Nothing }
-                            (_, _, _) -> depInfo
-            realViolations =
-                any (isJust . AppMgr2.dependencyInfoError <&&> AppMgr2.dependencyInfoRequired) refinedDepInfo
-            (status, version) =
-                maybe (AppStatusAppMgr infoResStatus, infoResVersion) (first AppStatusTmp)
-                    $   ((, infoResVersion) <$> HM.lookup appId tmpStatuses)
-                    <|> (guard (not infoResIsConfigured || infoResIsRecoverable) $> (NeedsConfig, infoResVersion))
-                    <|> (guard realViolations $> (BrokenDependencies, infoResVersion))
-        in  ( status
-            , version
-            , infoRes
-                { AppMgr2.infoResDependencies = case status of
-                                                    AppStatusTmp NeedsConfig -> HM.empty
-                                                    _                        -> refinedDepInfo
-                }
-            )
-    where tmpStatuses = statuses jobCache
-
-storeAppToAppBase :: StoreApp -> AppBase
-storeAppToAppBase StoreApp {..} =
-    AppBase storeAppId storeAppTitle (storeIconUrl storeAppId (storeAppVersionInfoVersion $ extract storeAppVersions))
-
-storeAppToAvailablePreview :: StoreApp -> Maybe (Version, AppStatus) -> AppAvailablePreview
-storeAppToAvailablePreview s@StoreApp {..} installed = AppAvailablePreview
-    (storeAppToAppBase s)
-    (storeAppVersionInfoVersion $ extract storeAppVersions)
-    storeAppDescriptionShort
-    installed
-    storeAppTimestamp
-
-type AsInstalled :: Bool -> Type
-newtype AsInstalled a = AsInstalled { unAsInstalled :: SBool a }
-dependencyInfoToDependencyRequirement :: AsInstalled a
-                                      -> (AppBase, Maybe AppStatus, AppMgr2.DependencyInfo)
-                                      -> (AppDependencyRequirement (If a Strip Keep))
-dependencyInfoToDependencyRequirement asInstalled (base, status, AppMgr2.DependencyInfo {..}) = do
-    let appDependencyRequirementBase        = base
-    let appDependencyRequirementDescription = dependencyInfoDescription
-    let appDependencyRequirementVersionSpec = dependencyInfoVersionSpec
-    let appDependencyRequirementViolation = case (status, dependencyInfoError) of
-            (Just s@(AppStatusTmp Installing), _) -> Just $ IncompatibleStatus s
-            (Nothing, _                        ) -> Just Missing
-            (_      , Just AppMgr2.NotInstalled) -> Just Missing
-            (_, Just (AppMgr2.InvalidVersion _ _)) -> Just IncompatibleVersion
-            (_, Just (AppMgr2.UnsatisfiedConfig reasons)) -> Just . IncompatibleConfig $ reasons
-            (Just s , Just AppMgr2.NotRunning  ) -> Just $ IncompatibleStatus s
-            (_      , Nothing                  ) -> Nothing
-    case asInstalled of
-        AsInstalled STrue ->
-            let appDependencyRequirementReasonOptional = ()
-                appDependencyRequirementDefault        = ()
-            in  AppDependencyRequirement { .. }
-        AsInstalled SFalse ->
-            let appDependencyRequirementReasonOptional = dependencyInfoReasonOptional
-                appDependencyRequirementDefault        = dependencyInfoRequired
-            in  AppDependencyRequirement { .. }
-
-postActionR :: AppId -> Handler (JSONResponse JSONRPC.Response)
-postActionR appId = do
-    req <- requireCheckJsonBody
-    fmap JSONResponse . intoHandler $ postActionLogic appId req
-
-postActionLogic :: (Has (Error S9Error) sig m, Has AppMgr2.AppMgr sig m)
-                => AppId
-                -> JSONRPC.Request
-                -> m JSONRPC.Response
-postActionLogic appId (JSONRPC.Request { getReqMethod, getReqId }) = do
-    hm <- AppMgr2.action appId getReqMethod
-    case (HM.lookup "result" hm, HM.lookup "error" hm >>= parseMaybe parseJSON) of
-        (Just v , _      ) -> pure (JSONRPC.Response JSONRPC.V2 v getReqId)
-        (_      , Just e ) -> pure (JSONRPC.ResponseError JSONRPC.V2 e getReqId)
-        (Nothing, Nothing) -> throwError
-            $ AppMgrParseE "action" (decodeUtf8 . LBS.toStrict $ encode (Object hm)) "Invalid JSONRPC Response"
-postActionLogic _ r = throwError $ InvalidRequestE (toJSON r) "Invalid JSONRPC Request"

agent/src/Handler/Authenticate.hs

@@ -1,9 +0,0 @@
-module Handler.Authenticate where
-
-import           Startlude
-
-import           Foundation
-
--- handled by auth switch in Foundation
-getAuthenticateR :: Handler ()
-getAuthenticateR = pure ()

agent/src/Handler/Backups.hs

@@ -1,235 +0,0 @@
-{-# LANGUAGE QuasiQuotes     #-}
-{-# LANGUAGE RecordWildCards #-}
-module Handler.Backups where
-
-import           Startlude               hiding ( Reader
-                                                , ask
-                                                , runReader
-                                                )
-
-import           Control.Effect.Labelled hiding ( Handler )
-import           Control.Effect.Reader.Labelled
-import           Control.Carrier.Error.Church
-import           Control.Carrier.Lift
-import           Control.Carrier.Reader         ( runReader )
-import           Data.Aeson
-import qualified Data.HashMap.Strict           as HM
-import           Data.UUID.V4
-import           Database.Persist.Sql
-import           Yesod.Auth
-import           Yesod.Core
-import           Yesod.Core.Types
-
-import           Foundation
-import           Handler.Util
-import           Lib.Error
-import qualified Lib.External.AppMgr           as AppMgr
-import qualified Lib.Notifications             as Notifications
-import           Lib.Password
-import           Lib.Types.Core
-import           Lib.Types.Emver
-import           Model
-import qualified Lib.Algebra.Domain.AppMgr     as AppMgr2
-import           Lib.Background
-import           Control.Concurrent.STM
-import           Exinst
-
-
-data CreateBackupReq = CreateBackupReq
-    { createBackupLogicalName :: FilePath
-    , createBackupPassword    :: Maybe Text
-    }
-    deriving (Eq, Show)
-instance FromJSON CreateBackupReq where
-    parseJSON = withObject "Create Backup Req" $ \o -> do
-        createBackupLogicalName <- o .: "logicalname"
-        createBackupPassword    <- o .:? "password" .!= Nothing
-        pure CreateBackupReq { .. }
-
-data RestoreBackupReq = RestoreBackupReq
-    { restoreBackupLogicalName :: FilePath
-    , restoreBackupPassword    :: Maybe Text
-    }
-    deriving (Eq, Show)
-instance FromJSON RestoreBackupReq where
-    parseJSON = withObject "Restore Backup Req" $ \o -> do
-        restoreBackupLogicalName <- o .: "logicalname"
-        restoreBackupPassword    <- o .:? "password" .!= Nothing
-        pure RestoreBackupReq { .. }
-
-data EjectDiskReq = EjectDiskReq
-    { ejectDiskLogicalName :: Text 
-    } deriving (Eq, Show)
-instance FromJSON EjectDiskReq where
-    parseJSON = withObject "Eject Disk Req" $ \o -> do
-        ejectDiskLogicalName <- o .: "logicalName"
-        pure EjectDiskReq { .. }
-
--- Handlers
-
-postCreateBackupR :: AppId -> Handler ()
-postCreateBackupR appId = disableEndpointOnFailedUpdate $ do
-    req           <- requireCheckJsonBody
-    AgentCtx {..} <- getYesod
-    account       <- entityVal <$> requireAuth
-    case validatePass account <$> (createBackupPassword req) of
-        Just False -> runM . handleS9ErrC $ throwError BackupPassInvalidE
-        _ ->
-            createBackupLogic appId req
-                & AppMgr2.runAppMgrCliC
-                & runLabelled @"databaseConnection"
-                & runReader appConnPool
-                & runLabelled @"backgroundJobCache"
-                & runReader appBackgroundJobs
-                & handleS9ErrC
-                & runM
-
-
-postStopBackupR :: AppId -> Handler ()
-postStopBackupR appId = disableEndpointOnFailedUpdate $ do
-    cache <- getsYesod appBackgroundJobs
-    stopBackupLogic appId & runLabelled @"backgroundJobCache" & runReader cache & handleS9ErrC & runM
-
-postRestoreBackupR :: AppId -> Handler ()
-postRestoreBackupR appId = disableEndpointOnFailedUpdate $ do
-    req           <- requireCheckJsonBody
-    AgentCtx {..} <- getYesod
-    restoreBackupLogic appId req
-        & AppMgr2.runAppMgrCliC
-        & runLabelled @"databaseConnection"
-        & runReader appConnPool
-        & runLabelled @"backgroundJobCache"
-        & runReader appBackgroundJobs
-        & handleS9ErrC
-        & runM
-
-getDisksR :: Handler (JSONResponse [AppMgr.DiskInfo])
-getDisksR = fmap JSONResponse . runM . handleS9ErrC $ listDisksLogic
-
-postEjectR :: Handler ()
-postEjectR = runM . handleS9ErrC $ requireCheckJsonBody >>= ejectDiskLogic . ejectDiskLogicalName
-
--- Logic
-
-createBackupLogic :: ( HasLabelled "backgroundJobCache" (Reader (TVar JobCache)) sig m
-                     , HasLabelled "databaseConnection" (Reader ConnectionPool) sig m
-                     , Has (Error S9Error) sig m
-                     , Has AppMgr2.AppMgr sig m
-                     , MonadIO m
-                     )
-                  => AppId
-                  -> CreateBackupReq
-                  -> m ()
-createBackupLogic appId CreateBackupReq {..} = do
-    jobCache <- ask @"backgroundJobCache"
-    db       <- ask @"databaseConnection"
-    version  <- fmap AppMgr2.infoResVersion $ AppMgr2.info [AppMgr2.flags| |] appId `orThrowM` NotFoundE "appId"
-                                                                                                         (show appId)
-    res <- liftIO . atomically $ do
-        (JobCache jobs) <- readTVar jobCache
-        case HM.lookup appId jobs of
-            Just (Some1 SCreatingBackup  _, _) -> pure (Left $ BackupE appId "Already creating backup")
-            Just (Some1 SRestoringBackup _, _) -> pure (Left $ BackupE appId "Cannot backup during restore")
-            Just (Some1 _                _, _) -> pure (Left $ BackupE appId "Cannot backup: incompatible status")
-            Nothing                            -> do
-                -- this panic is here because we don't have the threadID yet, and it is required. We want to write the
-                -- TVar anyway though so that we don't accidentally launch multiple backup jobs
-                -- TODO: consider switching to MVar's for this
-                modifyTVar jobCache (insertJob appId Backup $ panic "ThreadID prematurely forced")
-                pure $ Right ()
-    case res of
-        Left  e  -> throwError e
-        Right () -> do
-            tid <- liftIO . forkIO $ do
-                appmgrRes <- runExceptT (AppMgr.backupCreate createBackupPassword appId createBackupLogicalName)
-                atomically $ modifyTVar' jobCache (deleteJob appId)
-                let notif = case appmgrRes of
-                        Left  e -> Notifications.BackupFailed e
-                        Right _ -> Notifications.BackupSucceeded
-                flip runSqlPool db $ do
-                    void $ insertBackupResult appId version (isRight appmgrRes)
-                    void $ Notifications.emit appId version notif
-            liftIO . atomically $ modifyTVar jobCache (insertJob appId Backup tid)
-
-stopBackupLogic :: ( HasLabelled "backgroundJobCache" (Reader (TVar JobCache)) sig m
-                   , Has (Error S9Error) sig m
-                   , MonadIO m
-                   )
-                => AppId
-                -> m ()
-stopBackupLogic appId = do
-    jobCache <- ask @"backgroundJobCache"
-    res      <- liftIO . atomically $ do
-        (JobCache jobs) <- readTVar jobCache
-        case HM.lookup appId jobs of
-            Just (Some1 SCreatingBackup _, tid) -> do
-                modifyTVar jobCache (deleteJob appId)
-                pure (Right tid)
-            Just (Some1 SRestoringBackup _, _) -> pure (Left $ BackupE appId "Cannot interrupt restore")
-            _ -> pure (Left $ NotFoundE "backup job" (show appId))
-    case res of
-        Left  e   -> throwError e
-        Right tid -> liftIO $ killThread tid
-
-restoreBackupLogic :: ( HasLabelled "backgroundJobCache" (Reader (TVar JobCache)) sig m
-                      , HasLabelled "databaseConnection" (Reader ConnectionPool) sig m
-                      , Has (Error S9Error) sig m
-                      , Has AppMgr2.AppMgr sig m
-                      , MonadIO m
-                      )
-                   => AppId
-                   -> RestoreBackupReq
-                   -> m ()
-restoreBackupLogic appId RestoreBackupReq {..} = do
-    jobCache <- ask @"backgroundJobCache"
-    db       <- ask @"databaseConnection"
-    version  <- fmap AppMgr2.infoResVersion $ AppMgr2.info [AppMgr2.flags| |] appId `orThrowM` NotFoundE "appId"
-                                                                                                         (show appId)
-    res <- liftIO . atomically $ do
-        (JobCache jobs) <- readTVar jobCache
-        case HM.lookup appId jobs of
-            Just (Some1 SCreatingBackup  _, _) -> pure (Left $ BackupE appId "Cannot restore during backup")
-            Just (Some1 SRestoringBackup _, _) -> pure (Left $ BackupE appId "Already restoring backup")
-            Just (Some1 _                _, _) -> pure (Left $ BackupE appId "Cannot backup: incompatible status")
-            Nothing                            -> do
-                -- this panic is here because we don't have the threadID yet, and it is required. We want to write the
-                -- TVar anyway though so that we don't accidentally launch multiple backup jobs
-                -- TODO: consider switching to MVar's for this
-                modifyTVar jobCache (insertJob appId Restore $ panic "ThreadID prematurely forced")
-                pure $ Right ()
-    case res of
-        Left  e -> throwError e
-        Right _ -> do
-            tid <- liftIO . forkIO $ do
-                appmgrRes <- runExceptT (AppMgr.backupRestore restoreBackupPassword appId restoreBackupLogicalName)
-                atomically $ modifyTVar jobCache (deleteJob appId)
-                let notif = case appmgrRes of
-                        Left  e -> Notifications.RestoreFailed e
-                        Right _ -> Notifications.RestoreSucceeded
-                flip runSqlPool db $ void $ Notifications.emit appId version notif
-            liftIO . atomically $ modifyTVar jobCache (insertJob appId Restore tid)
-
-
-listDisksLogic :: (Has (Error S9Error) sig m, MonadIO m) => m [AppMgr.DiskInfo]
-listDisksLogic = runExceptT AppMgr.diskShow >>= liftEither
-
-ejectDiskLogic :: (Has (Error S9Error) sig m, MonadIO m) => Text -> m ()
-ejectDiskLogic t = do
-    (ec, _) <- AppMgr.readProcessInheritStderr "eject" [toS t] ""
-    case ec of
-        ExitSuccess   -> pure ()
-        ExitFailure n -> throwError $ EjectE n
-
-insertBackupResult :: MonadIO m => AppId -> Version -> Bool -> SqlPersistT m (Entity BackupRecord)
-insertBackupResult appId appVersion succeeded = do
-    uuid <- liftIO nextRandom
-    now  <- liftIO getCurrentTime
-    let k = (BackupRecordKey uuid)
-    let v = (BackupRecord now appId appVersion succeeded)
-    insertKey k v
-    pure $ Entity k v
-
-getLastSuccessfulBackup :: MonadIO m => AppId -> SqlPersistT m (Maybe UTCTime)
-getLastSuccessfulBackup appId = backupRecordCreatedAt . entityVal <<$>> selectFirst
-    [BackupRecordAppId ==. appId, BackupRecordSucceeded ==. True]
-    [Desc BackupRecordCreatedAt]

agent/src/Handler/Hosts.hs

@@ -1,56 +0,0 @@
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE RecordWildCards #-}
-module Handler.Hosts where
-
-import           Startlude               hiding ( ask )
-
-import           Control.Carrier.Lift           ( runM )
-import           Data.Conduit
-import qualified Data.Conduit.Binary           as CB
-import           Yesod.Core              hiding ( expiresAt )
-
-import           Foundation
-import           Handler.Register               ( checkExistingPasswordRegistration
-                                                , getRegistration
-                                                )
-import           Handler.Types.Hosts
-import           Lib.Crypto
-import           Lib.Error
-import           Lib.Password                   ( rootAccountName )
-import           Lib.ProductKey
-import           Lib.SystemPaths                ( injectFilesystemBaseFromContext
-                                                , rootCaCertPath
-                                                , SystemPath(relativeTo)
-                                                )
-import           Settings
-
-getHostsR :: Handler HostsRes
-getHostsR = handleS9ErrT $ do
-    settings   <- getsYesod appSettings
-    productKey <- liftIO . getProductKey . appFilesystemBase $ settings
-    hostParams <- extractHostsQueryParams
-
-    verifyHmac productKey hostParams
-
-    mClaimedAt <- checkExistingPasswordRegistration rootAccountName
-    case mClaimedAt of
-        Nothing        -> pure $ NullReply
-        Just claimedAt -> do
-            fmap HostsRes . mapExceptT (liftIO . runM . injectFilesystemBaseFromContext settings) $ getRegistration
-                productKey
-                claimedAt
-
-verifyHmac :: MonadIO m => Text -> HostsParams -> S9ErrT m ()
-verifyHmac productKey params = do
-    let computedHmacDigest = computeHmac productKey hostsParamsExpiration hostsParamsSalt
-    unless (hostsParamsHmac == computedHmacDigest) $ throwE unauthorizedHmac
-    where
-        HostsParams { hostsParamsHmac, hostsParamsExpiration, hostsParamsSalt } = params
-        unauthorizedHmac = ClientCryptographyE "Unauthorized hmac"
-
-getCertificateR :: Handler TypedContent
-getCertificateR = do
-    base <- getsYesod $ appFilesystemBase . appSettings
-    respondSource "application/x-x509-ca-cert"
-        $  CB.sourceFile (toS $ rootCaCertPath `relativeTo` base)
-        .| awaitForever sendChunkBS

agent/src/Handler/Icons.hs

@@ -1,106 +0,0 @@
-{-# LANGUAGE PartialTypeSignatures #-}
-module Handler.Icons where
-
-import           Startlude               hiding ( Reader
-                                                , runReader
-                                                )
-
-import           Control.Carrier.Error.Either
-import           Control.Carrier.Lift
-import           Data.Conduit
-import           Data.Conduit.Binary           as CB
-import qualified Data.Text                     as T
-import           Network.HTTP.Simple
-import           System.FilePath.Posix
-import           Yesod.Core
-
-import           Foundation
-import           Lib.Algebra.State.RegistryUrl
-import           Lib.Error
-import qualified Lib.External.Registry         as Reg
-import           Lib.IconCache
-import           Lib.SystemPaths         hiding ( (</>) )
-import           Lib.Types.Core
-import           Lib.Types.ServerApp
-import           Settings
-import           Control.Carrier.Reader  hiding ( asks )
-import           Control.Effect.Labelled        ( runLabelled )
-import qualified Data.HashMap.Strict           as HM
-import           Control.Concurrent.STM         ( modifyTVar
-                                                , readTVarIO
-                                                )
-import           Crypto.Hash.Conduit            ( hashFile )
-import           Lib.Types.Emver
-
-iconUrl :: AppId -> Version -> Text
-iconUrl appId version = (foldMap (T.cons '/') . fst . renderRoute . AppIconR $ appId) <> "?" <> show version
-
-storeIconUrl :: AppId -> Version -> Text
-storeIconUrl appId version =
-    (foldMap (T.cons '/') . fst . renderRoute . AvailableAppIconR $ appId) <> "?" <> show version
-
-getAppIconR :: AppId -> Handler TypedContent
-getAppIconR appId = handleS9ErrT $ do
-    ctx <- getYesod
-    let iconTags = appIconTags ctx
-    storedTag <- liftIO $ readTVarIO iconTags >>= pure . HM.lookup appId
-    path      <- case storedTag of
-        Nothing -> interp ctx $ do
-            findIcon appId >>= \case
-                Nothing -> fetchIcon
-                Just fp -> do
-                    tag <- hashFile fp
-                    saveTag appId tag
-                    pure fp
-        Just x -> do
-            setWeakEtag (show x)
-            interp ctx $ findIcon appId >>= \case
-                Nothing -> do
-                    liftIO $ atomically $ modifyTVar iconTags (HM.delete appId)
-                    fetchIcon
-                Just fp -> pure fp
-    cacheSeconds 86_400
-    lift $ respondSource (parseContentType path) $ CB.sourceFile path .| awaitForever sendChunkBS
-    where
-        fetchIcon = do
-            url <- find ((== appId) . storeAppId) . Reg.storeApps <$> Reg.getAppManifest >>= \case
-                Nothing -> throwError $ NotFoundE "icon" (show appId)
-                Just x  -> pure . toS $ storeAppIconUrl x
-            bp <- getAbsoluteLocationFor iconBasePath
-            saveIcon url
-            pure (toS bp </> takeFileName url)
-        interp ctx =
-            mapExceptT (liftIO . runM)
-                . runReader (appConnPool ctx)
-                . runLabelled @"databaseConnection"
-                . runReader (appFilesystemBase $ appSettings ctx)
-                . runLabelled @"filesystemBase"
-                . runReader (appIconTags ctx)
-                . runLabelled @"iconTagCache"
-                . runRegistryUrlIOC
-
-
-getAvailableAppIconR :: AppId -> Handler TypedContent
-getAvailableAppIconR appId = handleS9ErrT $ do
-    s   <- getsYesod appSettings
-    url <- do
-        find ((== appId) . storeAppId) . Reg.storeApps <$> interp s Reg.getAppManifest >>= \case
-            Nothing -> throwE $ NotFoundE "icon" (show appId)
-            Just x  -> pure . toS $ storeAppIconUrl x
-    req <- case parseRequest url of
-        Nothing -> throwE $ RegistryParseE (toS url) "invalid url"
-        Just x  -> pure x
-    cacheSeconds 86_400
-    lift $ respondSource (parseContentType url) $ httpSource req getResponseBody .| awaitForever sendChunkBS
-    where interp s = ExceptT . liftIO . runError . injectFilesystemBaseFromContext s . runRegistryUrlIOC
-
-parseContentType :: FilePath -> ContentType
-parseContentType = contentTypeMapping . takeExtension
-    where
-        contentTypeMapping ext = case ext of
-            ".png"  -> typePng
-            ".jpeg" -> typeJpeg
-            ".jpg"  -> typeJpeg
-            ".gif"  -> typeGif
-            ".svg"  -> typeSvg
-            _       -> typePlain

agent/src/Handler/Login.hs

@@ -1,75 +0,0 @@
-{-# LANGUAGE CPP                        #-}
-{-# LANGUAGE QuasiQuotes                #-}
-{-# LANGUAGE ConstraintKinds            #-}
-{-# LANGUAGE FlexibleContexts           #-}
-{-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE RankNTypes                 #-}
-{-# LANGUAGE ScopedTypeVariables        #-}
-{-# LANGUAGE OverloadedStrings          #-}
-{-# LANGUAGE RecordWildCards            #-}
-
-module Handler.Login
-    ( HasPasswordHash(..)
-    , defaultStrength
-    , setPasswordStrength
-    , setPassword
-    , validatePass
-      -- * Interface to database and Yesod.Auth
-    , validateUserWithPasswordHash
-    -- Login Route Handler
-    , postLoginR
-    -- Logout Route Handler
-    , postLogoutR
-    )
-where
-
-import           Startlude
-import           Data.Aeson                     ( withObject )
-import           Yesod.Auth                     ( setCredsRedirect
-                                                , clearCreds
-                                                , Creds(..)
-                                                )
-import           Yesod.Core
-import           Yesod.Persist
-
-import           Auth
-import           Foundation
-import           Lib.Password
-import           Model
-
--- Internal data type for receiving JSON encoded accountIdentifier and password
-data LoginReq = LoginReq
-    { loginReqName     :: Text
-    , loginReqPassword :: Text
-    }
-
-instance FromJSON LoginReq where
-    parseJSON = withObject "Login Request" $ \o -> do
-        -- future version can pass an accountIdentifier
-        let loginReqName = rootAccountName
-        loginReqPassword <- o .: "password"
-        pure LoginReq { .. }
-
--- the redirect in the 'then' block gets picked up by the 'authenticate'
--- function in the YesodAuth instance for AgentCtx
-postLoginR :: SubHandlerFor Auth AgentCtx TypedContent
-postLoginR = do
-    LoginReq name password <- requireCheckJsonBody
-    isValid                <- liftHandler $ validateUserWithPasswordHash (UniqueAccount name) password
-    if isValid then liftHandler $ setCredsRedirect $ Creds "hashdb" name [] else notAuthenticated
-
--- the redirect in the 'then' block gets picked up by the 'authenticate'
--- function in the YesodAuth instance for AgentCtx
-postLogoutR :: SubHandlerFor Auth AgentCtx ()
-postLogoutR = liftHandler $ clearCreds False
-
--- | Given a user unique identifier and password in plaintext, validate them against
---   the database values.  This function simply looks up the user id in the
---   database and calls 'validatePass' to do the work.
-validateUserWithPasswordHash :: Unique Account -> Text -> Handler Bool
-validateUserWithPasswordHash name password = do
-    account <- runDB $ getBy name
-    pure case account of
-        Nothing       -> False
-        Just account' -> flip validatePass password . entityVal $ account'
-

agent/src/Handler/Network.hs

@@ -1,32 +0,0 @@
-module Handler.Network where
-
-import           Startlude               hiding ( Reader
-                                                , asks
-                                                , runReader
-                                                )
-
-import           Control.Carrier.Lift           ( runM )
-import           Control.Effect.Error
-import           Control.Carrier.Reader
-import           Lib.Error
-import           Yesod.Core                     ( getYesod )
-
-import           Foundation
-import qualified Lib.Algebra.Domain.AppMgr     as AppMgr2
-import           Lib.Types.Core
-
-postResetLanR :: Handler ()
-postResetLanR = do
-    ctx <- getYesod
-    runM . handleS9ErrC . runReader ctx $ postResetLanLogic
-
-postResetLanLogic :: (MonadIO m, Has (Reader AgentCtx) sig m, Has (Error S9Error) sig m) => m ()
-postResetLanLogic = do
-    threadVar <- asks appLanThread
-    mtid      <- liftIO . tryTakeMVar $ threadVar
-    case mtid of
-        Nothing  -> throwError $ TemporarilyForbiddenE (AppId "LAN") "reset" "being reset"
-        Just tid -> liftIO $ do
-            killThread tid
-            newTid <- forkIO (void . runM . runExceptT @S9Error . AppMgr2.runAppMgrCliC $ AppMgr2.lanEnable)
-            putMVar threadVar newTid

agent/src/Handler/Notifications.hs

@@ -1,32 +0,0 @@
-module Handler.Notifications where
-
-import           Startlude
-
-import           Data.UUID
-import           Database.Persist
-import           Yesod.Core.Handler
-import           Yesod.Core.Types               ( JSONResponse(..) )
-import           Yesod.Persist.Core
-
-import           Foundation
-import qualified Lib.Notifications             as Notification
-import           Model
-
-getNotificationsR :: Handler (JSONResponse [Entity Notification])
-getNotificationsR = runDB $ do
-    page     <- lookupGetParam "page" `orDefaultTo` 1
-    pageSize <- lookupGetParam "perPage" `orDefaultTo` 20
-    evs      <- selectList [] [Desc NotificationCreatedAt, LimitTo pageSize, OffsetBy ((page - 1) * pageSize)]
-    let toArchive = fmap entityKey $ filter ((== Nothing) . notificationArchivedAt . entityVal) evs
-    void $ Notification.archive toArchive
-    pure $ JSONResponse evs
-    where
-        orDefaultTo :: (Monad m, Read a) => m (Maybe Text) -> a -> m a
-        orDefaultTo m a = do
-            m' <- m
-            case m' >>= readMaybe . toS of
-                Nothing -> pure a
-                Just x  -> pure x
-
-deleteNotificationR :: UUID -> Handler ()
-deleteNotificationR notifId = runDB $ delete (coerce @_ @(Key Notification) notifId)

agent/src/Handler/PasswordUpdate.hs

@@ -1,36 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-module Handler.PasswordUpdate where
-
-import           Startlude               hiding ( ask )
-
-import           Data.Aeson
-import           Yesod.Core              hiding ( expiresAt )
-import           Yesod.Persist
-
-
-import           Foundation
-import           Lib.Error
-import           Lib.Password
-import           Model
-
-patchPasswordR :: Handler ()
-patchPasswordR = handleS9ErrT $ do
-    PasswordUpdateReq {..} <- requireCheckJsonBody
-    updateAccountRegistration rootAccountName passwordUpdateReqPassword
-data PasswordUpdateReq = PasswordUpdateReq
-    { passwordUpdateReqPassword :: Text
-    } deriving (Eq, Show)
-instance FromJSON PasswordUpdateReq where
-    parseJSON = withObject "Update Password" $ \o -> do
-        passwordUpdateReqPassword <- o .: "value"
-        pure PasswordUpdateReq { .. }
-
-updateAccountRegistration :: Text -> Text -> S9ErrT Handler ()
-updateAccountRegistration acctName newPassword = do
-    now     <- liftIO $ getCurrentTime
-    account <- (lift . runDB . getBy $ UniqueAccount acctName) >>= \case
-        Nothing -> throwE $ NotFoundE "account" acctName
-        Just a  -> pure a
-
-    account' <- setPassword newPassword $ (entityVal account) { accountUpdatedAt = now }
-    (lift . runDB $ Yesod.Persist.replace (entityKey account) account')

agent/src/Handler/PowerOff.hs

@@ -1,28 +0,0 @@
-module Handler.PowerOff where
-
-import           Startlude
-
-import           System.Process
-
-import           Foundation
-import           Lib.Sound
-import           Yesod.Core.Handler
-import           Network.HTTP.Types
-
-postShutdownR :: Handler ()
-postShutdownR = do
-    liftIO $ callCommand "/bin/sync"
-    liftIO $ playSong 400 marioDeath
-    void $ liftIO $ forkIO $ do
-        threadDelay 1_000_000
-        callCommand "/sbin/shutdown now"
-    sendResponseStatus status200 ()
-
-postRestartR :: Handler ()
-postRestartR = do
-    liftIO $ callCommand "/bin/sync"
-    liftIO $ playSong 400 marioDeath
-    void $ liftIO $ forkIO $ do
-        threadDelay 1_000_000
-        callCommand "/sbin/reboot"
-    sendResponseStatus status200 ()

agent/src/Handler/Register.hs

@@ -1,166 +0,0 @@
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE RecordWildCards #-}
-module Handler.Register where
-
-import           Startlude               hiding ( ask )
-
-import           Control.Carrier.Error.Either   ( runError
-                                                , Error
-                                                , throwError
-                                                )
-import           Control.Carrier.Lift
-import           Control.Effect.Throw           ( liftEither )
-import           Crypto.Cipher.Types
-import           Data.ByteArray.Sized
-import qualified Data.ByteString               as BS
-import qualified Data.Text                     as T
-import           Database.Persist
-import           Network.HTTP.Types.Status
-import           Yesod.Core              hiding ( expiresAt )
-import           Yesod.Persist.Core
-
-import           Daemon.ZeroConf
-import           Foundation
-import           Handler.Register.Nginx
-import           Handler.Register.Tor
-import           Handler.Types.HmacSig
-import           Handler.Types.Register
-import           Lib.Crypto
-import           Lib.Error
-import           Lib.Password
-import           Lib.ProductKey
-import           Lib.Ssl
-import           Lib.SystemPaths
-import           Lib.Tor
-import           Model
-import           Settings
-
-postRegisterR :: Handler RegisterRes
-postRegisterR = handleS9ErrT $ do
-    settings           <- getsYesod appSettings
-
-    productKey         <- liftIO . getProductKey . appFilesystemBase $ settings
-    req                <- requireCheckJsonBody
-
-    -- Decrypt torkey and password. This acts as product key authentication.
-    torKeyFileContents <- decryptTorkey productKey req
-    password           <- decryptPassword productKey req
-    rsaKeyFileContents <- decryptRSAKey productKey req
-
-    -- Check for existing registration.
-    checkExistingPasswordRegistration rootAccountName >>= \case
-        Nothing        -> pure ()
-        Just claimedAt -> do
-            res <- mapExceptT (liftIO . runM . injectFilesystemBaseFromContext settings)
-                $ getRegistration productKey claimedAt
-            sendResponseStatus (Status 209 "Preexisting") res
-
-    -- install new tor hidden service key and restart tor
-    registerResTorAddress <- runM (injectFilesystemBaseFromContext settings $ bootupTor torKeyFileContents) >>= \case
-        Just t  -> pure t
-        Nothing -> throwE TorServiceTimeoutE
-
-    -- install new ssl CA cert + nginx conf and restart nginx
-    registerResCert <-
-        runM . handleS9ErrC . liftEither <=< liftIO . runM . injectFilesystemBaseFromContext settings $ do
-            bootupHttpNginx
-            runError @S9Error $ bootupSslNginx rsaKeyFileContents
-
-    -- create an hmac of the torAddress + caCert for front end
-    registerResTorAddressSig <- produceProofOfKey productKey registerResTorAddress
-    registerResCertSig       <- produceProofOfKey productKey registerResCert
-
-    -- must match CN in config/csr.conf
-    let registerResCertName = root_CA_CERT_NAME
-    registerResLanAddress <- runM . injectFilesystemBaseFromContext settings $ getStart9AgentHostnameLocal
-
-    -- registration successful, save the password hash
-    registerResClaimedAt  <- saveAccountRegistration rootAccountName password
-    pure RegisterRes { .. }
-
-
-decryptTorkey :: MonadIO m => Text -> RegisterReq -> S9ErrT m ByteString
-decryptTorkey productKey RegisterReq { registerTorKey, registerTorCtrCounter, registerTorKdfSalt } = do
-    aesKey <- case mkAesKey registerTorKdfSalt productKey of
-        Just k  -> pure k
-        Nothing -> throwE ProductKeyE
-
-    torKeyFileContents <- case makeIV registerTorCtrCounter of
-        Just counter -> pure $ decryptAes256Ctr aesKey counter (unSizedByteArray registerTorKey)
-        Nothing      -> throwE $ ClientCryptographyE "invalid torkey aes ctr counter"
-
-    unless (torKeyPrefix `BS.isPrefixOf` torKeyFileContents) (throwE $ ClientCryptographyE "invalid tor key encryption")
-
-    pure torKeyFileContents
-    where torKeyPrefix = "== ed25519v1-secret: type0 =="
-
-decryptPassword :: MonadIO m => Text -> RegisterReq -> S9ErrT m Text
-decryptPassword productKey RegisterReq { registerPassword, registerPasswordCtrCounter, registerPasswordKdfSalt } = do
-    aesKey <- case mkAesKey registerPasswordKdfSalt productKey of
-        Just k  -> pure k
-        Nothing -> throwE ProductKeyE
-
-    password <- case makeIV registerPasswordCtrCounter of
-        Just counter -> pure $ decryptAes256Ctr aesKey counter registerPassword
-        Nothing      -> throwE $ ClientCryptographyE "invalid password aes ctr counter"
-
-    let decoded = decodeUtf8 password
-    unless (passwordPrefix `T.isPrefixOf` decoded) (throwE $ ClientCryptographyE "invalid password encryption")
-
-    -- drop password prefix in this case
-    pure . T.drop (T.length passwordPrefix) $ decoded
-    where passwordPrefix = "== password =="
-
-decryptRSAKey :: MonadIO m => Text -> RegisterReq -> S9ErrT m ByteString
-decryptRSAKey productKey RegisterReq { registerRsa, registerRsaCtrCounter, registerRsaKdfSalt } = do
-    aesKey <- case mkAesKey registerRsaKdfSalt productKey of
-        Just k  -> pure k
-        Nothing -> throwE ProductKeyE
-
-    cert <- case makeIV registerRsaCtrCounter of
-        Just counter -> pure $ decryptAes256Ctr aesKey counter registerRsa
-        Nothing      -> throwE $ ClientCryptographyE "invalid password aes ctr counter"
-
-    unless (certPrefix `BS.isPrefixOf` cert) (throwE $ ClientCryptographyE "invalid cert encryption")
-
-    pure cert
-    where certPrefix = "-----BEGIN RSA PRIVATE KEY-----"
-
-
-checkExistingPasswordRegistration :: Text -> S9ErrT Handler (Maybe UTCTime)
-checkExistingPasswordRegistration acctIdentifier = lift . runDB $ do
-    mAccount <- getBy $ UniqueAccount acctIdentifier
-    pure $ fmap (accountCreatedAt . entityVal) mAccount
-
-saveAccountRegistration :: Text -> Text -> S9ErrT Handler UTCTime
-saveAccountRegistration acctName password = lift . runDB $ do
-    now     <- liftIO getCurrentTime
-    account <- setPassword password $ accountNoPw now
-    insert_ account
-    pure now
-    where accountNoPw t = Account t t acctName ""
-
-produceProofOfKey :: MonadIO m => Text -> Text -> m HmacSig
-produceProofOfKey key message = do
-    salt <- random16
-    let hmac = computeHmac key message salt
-    pure $ HmacSig hmac message salt
-
-getRegistration :: (MonadIO m, HasFilesystemBase sig m, Has (Error S9Error) sig m) => Text -> UTCTime -> m RegisterRes
-getRegistration productKey registerResClaimedAt = do
-    torAddress <- getAgentHiddenServiceUrlMaybe >>= \case
-        Nothing -> throwError $ NotFoundE "prior registration" "torAddress"
-        Just t  -> pure $ t
-    caCert <- readSystemPath rootCaCertPath >>= \case
-        Nothing -> throwError $ NotFoundE "prior registration" "cert"
-        Just t  -> pure t
-
-    -- create an hmac of the torAddress + caCert for front end
-    registerResTorAddressSig <- produceProofOfKey productKey torAddress
-    registerResCertSig       <- produceProofOfKey productKey caCert
-
-    let registerResCertName = root_CA_CERT_NAME
-    registerResLanAddress <- getStart9AgentHostnameLocal
-
-    pure RegisterRes { .. }

agent/src/Handler/Register/Nginx.hs

@@ -1,158 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE QuasiQuotes #-}
-module Handler.Register.Nginx where
-
-import           Startlude               hiding ( ask
-                                                , catchError
-                                                , err
-                                                )
-
-import           Control.Carrier.Error.Church
-import           Control.Effect.Lift
-import qualified Control.Effect.Reader.Labelled
-                                               as Fused
-import qualified Data.ByteString               as BS
-import           System.Directory
-import           Daemon.ZeroConf
-import           Lib.ClientManifest
-import           Lib.Error
-import           Lib.Ssl
-import           Lib.Synchronizers
-import           Lib.SystemPaths
-import           Lib.Tor
-import           System.Posix                   ( removeLink )
-
--- Left error, Right CA cert for hmac signing
-bootupSslNginx :: (HasFilesystemBase sig m, Has (Error S9Error) sig m, Has (Lift IO) sig m, MonadIO m)
-               => ByteString
-               -> m Text
-bootupSslNginx rsaKeyFileContents = do
-    -- we need to ensure if the ssl setup fails that we remove all openssl key material and the nginx ssl conf before
-    -- starting again
-    resetSslState
-    cert <- writeSslKeyAndCert rsaKeyFileContents
-    sid  <- getStart9AgentHostname
-    installAmbassadorUiNginxHTTPS (sslOverrides sid) "start9-ambassador-ssl.conf"
-    pure cert
-    where
-        sslOverrides sid =
-            let hostname = sid <> ".local"
-            in  NginxSiteConfOverride
-                    { nginxSiteConfOverrideAdditionalServerName = hostname
-                    , nginxSiteConfOverrideListen = 443
-                    , nginxSiteConfOverrideSsl = Just $ NginxSsl { nginxSslKeyPath         = entityKeyPath sid
-                                                                 , nginxSslCertPath        = entityCertPath sid
-                                                                 , nginxSslOnlyServerNames = [hostname]
-                                                                 }
-                    }
-
-resetSslState :: (HasFilesystemBase sig m, Has (Lift IO) sig m, MonadIO m) => m ()
-resetSslState = do
-    base <- Fused.ask @"filesystemBase"
-    host <- getStart9AgentHostname
-    -- remove all files we explicitly create
-    traverse_
-        (liftIO . removePathForcibly . toS . flip relativeTo base)
-        [ rootCaKeyPath
-        , relBase $ (rootCaCertPath `relativeTo` base) <> ".csr"
-        , rootCaCertPath
-        , intermediateCaKeyPath
-        , relBase $ (intermediateCaCertPath `relativeTo` base) <> ".csr"
-        , intermediateCaCertPath
-        , entityKeyPath host
-        , relBase $ (entityCertPath host `relativeTo` base) <> ".csr"
-        , entityCertPath host
-        , entityConfPath host
-        , nginxSitesAvailable nginxSslConf
-        ]
-    liftIO $ do
-        withCurrentDirectory (toS $ flip relativeTo base $ rootCaDirectory <> "/newcerts")
-            $   listDirectory "."
-            >>= traverse_ removePathForcibly
-        withCurrentDirectory (toS $ flip relativeTo base $ intermediateCaDirectory <> "/newcerts")
-            $   listDirectory "."
-            >>= traverse_ removePathForcibly
-        writeFile (toS $ flip relativeTo base $ rootCaDirectory <> "/index.txt")         ""
-        writeFile (toS $ flip relativeTo base $ intermediateCaDirectory <> "/index.txt") ""
-    _ <- liftIO $ try @SomeException . removeLink . toS $ nginxSitesEnabled nginxSslConf `relativeTo` base
-    pure ()
-
-bootupHttpNginx :: (HasFilesystemBase sig m, MonadIO m) => m ()
-bootupHttpNginx = installAmbassadorUiNginxHTTP "start9-ambassador.conf"
-
-writeSslKeyAndCert :: (MonadIO m, HasFilesystemBase sig m, Has (Error S9Error) sig m) => ByteString -> m Text
-writeSslKeyAndCert rsaKeyFileContents = do
-    directory     <- toS <$> getAbsoluteLocationFor sslDirectory
-    caKeyPath     <- toS <$> getAbsoluteLocationFor rootCaKeyPath
-    caConfPath    <- toS <$> getAbsoluteLocationFor rootCaOpenSslConfPath
-    caCertPath    <- toS <$> getAbsoluteLocationFor rootCaCertPath
-    intCaKeyPath  <- toS <$> getAbsoluteLocationFor intermediateCaKeyPath
-    intCaConfPath <- toS <$> getAbsoluteLocationFor intermediateCaOpenSslConfPath
-    intCaCertPath <- toS <$> getAbsoluteLocationFor intermediateCaCertPath
-    sid           <- getStart9AgentHostname
-    entKeyPath    <- toS <$> getAbsoluteLocationFor (entityKeyPath sid)
-    entConfPath   <- toS <$> getAbsoluteLocationFor (entityConfPath sid)
-    entCertPath   <- toS <$> getAbsoluteLocationFor (entityCertPath sid)
-    torAddr       <- getAgentHiddenServiceUrl
-
-    let hostname = sid <> ".local"
-
-    liftIO $ createDirectoryIfMissing False directory
-    liftIO $ BS.writeFile caKeyPath rsaKeyFileContents
-
-    (exit, str1, str2) <- writeRootCaCert caConfPath caKeyPath caCertPath
-    liftIO $ do
-        putStrLn @Text "openssl logs"
-        putStrLn @Text "exit code: "
-        print exit
-        putStrLn @String $ "stdout: " <> str1
-        putStrLn @String $ "stderr: " <> str2
-    case exit of
-        ExitSuccess    -> pure ()
-        ExitFailure ec -> throwError $ OpenSslE "root" ec str1 str2
-
-    (exit', str1', str2') <- writeIntermediateCert $ DeriveCertificate { applicantConfPath = intCaConfPath
-                                                                       , applicantKeyPath  = intCaKeyPath
-                                                                       , applicantCertPath = intCaCertPath
-                                                                       , signingConfPath   = caConfPath
-                                                                       , signingKeyPath    = caKeyPath
-                                                                       , signingCertPath   = caCertPath
-                                                                       , duration          = 3650
-                                                                       }
-    liftIO $ do
-        putStrLn @Text "openssl logs"
-        putStrLn @Text "exit code: "
-        print exit'
-        putStrLn @String $ "stdout: " <> str1'
-        putStrLn @String $ "stderr: " <> str2'
-    case exit' of
-        ExitSuccess    -> pure ()
-        ExitFailure ec -> throwError $ OpenSslE "intermediate" ec str1' str2'
-
-
-    liftIO $ BS.writeFile entConfPath (domain_CSR_CONF hostname)
-
-    (exit'', str1'', str2'') <- writeLeafCert
-        DeriveCertificate { applicantConfPath = entConfPath
-                          , applicantKeyPath  = entKeyPath
-                          , applicantCertPath = entCertPath
-                          , signingConfPath   = intCaConfPath
-                          , signingKeyPath    = intCaKeyPath
-                          , signingCertPath   = intCaCertPath
-                          , duration          = 365
-                          }
-        hostname
-        torAddr
-
-    liftIO $ do
-        putStrLn @Text "openssl logs"
-        putStrLn @Text "exit code: "
-        print exit''
-        putStrLn @String $ "stdout: " <> str1''
-        putStrLn @String $ "stderr: " <> str2''
-    case exit'' of
-        ExitSuccess    -> pure ()
-        ExitFailure ec -> throwError $ OpenSslE "leaf" ec str1' str2'
-
-    readSystemPath' rootCaCertPath

agent/src/Handler/Register/Tor.hs

@@ -1,44 +0,0 @@
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE RecordWildCards #-}
-module Handler.Register.Tor where
-
-import           Startlude               hiding ( ask )
-
-import           Control.Effect.Reader.Labelled
-import qualified Data.ByteString               as BS
-import           System.Directory
-import           System.Process
-import           Lib.SystemCtl
-import           Lib.SystemPaths
-import           Lib.Tor
-
-bootupTor :: (HasFilesystemBase sig m, MonadIO m) => ByteString -> m (Maybe Text)
-bootupTor torKeyFileContents = do
-    base <- ask @"filesystemBase"
-    writeTorPrivateKeyFile torKeyFileContents
-
-    putStrLn @Text "restarting tor"
-    liftIO . void $ systemCtl RestartService "tor"
-    putStrLn @Text "restarted tor"
-
-    liftIO . fmap (join . hush) $ race
-        (threadDelay 30_000_000)
-        (runMaybeT . asum . repeat $ MaybeT . fmap hush $ try @SomeException
-            (threadDelay 100_000 *> injectFilesystemBase base getAgentHiddenServiceUrl)
-        )
-
-writeTorPrivateKeyFile :: (MonadIO m, HasFilesystemBase sig m) => ByteString -> m ()
-writeTorPrivateKeyFile contents = do
-    directory          <- fmap toS . getAbsoluteLocationFor $ agentTorHiddenServiceDirectory
-    privateKeyFilePath <- fmap toS . getAbsoluteLocationFor $ agentTorHiddenServicePrivateKeyPath
-    liftIO $ do
-        -- Clean out directory
-        removePathForcibly directory
-        createDirectory directory
-
-        -- write private key file
-        BS.writeFile privateKeyFilePath contents
-
-        -- Set ownership and permissions so tor executable can generate other files
-        callCommand $ "chown -R debian-tor:debian-tor " <> directory
-        callCommand $ "chmod 2700 " <> directory

agent/src/Handler/SelfUpdate.hs

@@ -1,51 +0,0 @@
-{-# LANGUAGE QuasiQuotes     #-}
-{-# LANGUAGE TemplateHaskell #-}
-
-module Handler.SelfUpdate where
-
-import           Startlude
-
-import           Control.Carrier.Error.Either
-import           Data.Aeson
-import           Yesod.Core
-
-import           Foundation
-import           Lib.Algebra.State.RegistryUrl
-import           Lib.Error
-import           Lib.External.Registry
-import           Lib.SystemPaths
-import           Lib.Types.Emver
-
-newtype UpdateAgentReq = UpdateAgentReq { updateAgentVersionSpecification :: VersionRange } deriving (Eq, Show)
-
-instance FromJSON UpdateAgentReq where
-    parseJSON = withObject "update agent request" $ fmap UpdateAgentReq . (.: "version")
-
-newtype UpdateAgentRes = UpdateAgentRes { status :: UpdateInitStatus } deriving (Eq)
-instance ToJSON UpdateAgentRes where
-    toJSON (UpdateAgentRes status) = object ["status" .= status]
-
-instance ToTypedContent UpdateAgentRes where
-    toTypedContent = toTypedContent . toJSON
-instance ToContent UpdateAgentRes where
-    toContent = toContent . toJSON
-
-
-data UpdateInitStatus = UpdatingAlreadyInProgress | UpdatingCommence deriving (Show, Eq)
-instance ToJSON UpdateInitStatus where
-    toJSON UpdatingAlreadyInProgress = String "UPDATING_ALREADY_IN_PROGRESS"
-    toJSON UpdatingCommence          = String "UPDATING_COMMENCE"
-
-postUpdateAgentR :: Handler UpdateAgentRes
-postUpdateAgentR = handleS9ErrT $ do
-    settings <- getsYesod appSettings
-    avs      <- updateAgentVersionSpecification <$> requireCheckJsonBody
-    mVersion <- interp settings $ getLatestAgentVersionForSpec avs
-
-    when (isNothing mVersion) $ throwE $ NoCompliantAgentE avs
-
-    updateSpecBox <- getsYesod appSelfUpdateSpecification
-    success       <- liftIO $ tryPutMVar updateSpecBox avs
-
-    if success then pure $ UpdateAgentRes UpdatingCommence else pure $ UpdateAgentRes UpdatingAlreadyInProgress
-    where interp s = ExceptT . liftIO . runError . injectFilesystemBaseFromContext s . runRegistryUrlIOC

agent/src/Handler/SshKeys.hs

@@ -1,39 +0,0 @@
-{-# LANGUAGE QuasiQuotes     #-}
-{-# LANGUAGE RecordWildCards #-}
-module Handler.SshKeys where
-
-import           Startlude
-
-import           Yesod.Core
-import           Yesod.Core.Types               ( JSONResponse(..) )
-
-import           Foundation
-import           Lib.Error
-import           Lib.Ssh
-import           Util.Function
-import           Handler.Types.V0.Ssh
-
-postSshKeysR :: Handler SshKeyFingerprint
-postSshKeysR = handleS9ErrT $ do
-    settings <- getsYesod appSettings
-    key      <- sshKey <$> requireCheckJsonBody
-    case fingerprint key of
-        Left  e  -> throwE $ InvalidSshKeyE (toS e)
-        Right fp -> do
-            runReaderT (createSshKey key) settings
-            pure $ uncurry3 SshKeyFingerprint fp
-
-deleteSshKeyByFingerprintR :: Text -> Handler ()
-deleteSshKeyByFingerprintR key = handleS9ErrT $ do
-    settings <- getsYesod appSettings
-    runReaderT (deleteSshKey key) settings >>= \case
-        True  -> pure ()
-        False -> throwE $ NotFoundE "sshKey" key
-
-getSshKeysR :: Handler (JSONResponse [SshKeyFingerprint]) -- deprecated in 0.2.0
-getSshKeysR = handleS9ErrT $ do
-    settings <- getsYesod appSettings
-    keys     <- runReaderT getSshKeys settings
-    JSONResponse <$> case traverse fingerprint keys of
-        Left  e  -> throwE $ InvalidSshKeyE (toS e)
-        Right as -> pure $ uncurry3 SshKeyFingerprint <$> as

agent/src/Handler/Status.hs

@@ -1,81 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TemplateHaskell #-}
-module Handler.Status where
-
-import           Startlude
-
-import           Control.Carrier.Error.Either
-import           Data.Aeson.Encoding
-import           Git.Embed
-import           Yesod.Core.Handler
-import           Yesod.Core.Json
-import           Yesod.Core.Types
-
-import           Constants
-import           Daemon.ZeroConf
-import           Foundation
-import           Handler.Types.Metrics
-import           Handler.Types.V0.Specs
-import           Handler.Types.V0.Base
-import           Lib.Algebra.State.RegistryUrl
-import           Lib.Error
-import           Lib.External.Metrics.Df
-import qualified Lib.External.Registry         as Reg
-import           Lib.External.Specs.CPU
-import           Lib.External.Specs.Memory
-import           Lib.Metrics
-import           Lib.SystemPaths         hiding ( (</>) )
-import           Lib.Tor
-import           Settings
-import           Control.Carrier.Lift           ( runM )
-import           System.Process
-import qualified UnliftIO
-import           System.FileLock
-
-getVersionR :: Handler AppVersionRes
-getVersionR = pure . AppVersionRes $ agentVersion
-
-getVersionLatestR :: Handler VersionLatestRes
-getVersionLatestR = handleS9ErrT $ do
-    s <- getsYesod appSettings
-    uncurry VersionLatestRes <$> interp s Reg.getLatestAgentVersion
-    where interp s = ExceptT . liftIO . runError . injectFilesystemBaseFromContext s . runRegistryUrlIOC
-
-
-getSpecsR :: Handler Encoding -- deprecated in 0.2.0
-getSpecsR = handleS9ErrT $ do
-    settings        <- getsYesod appSettings
-    specsCPU        <- liftIO getCpuInfo
-    specsMem        <- liftIO getMem
-    specsDisk       <- fmap show . metricDiskSize <$> getDfMetrics
-    specsNetworkId  <- lift . runM . injectFilesystemBaseFromContext settings $ getStart9AgentHostname
-    specsTorAddress <- lift . runM . injectFilesystemBaseFromContext settings $ getAgentHiddenServiceUrl
-    specsLanAddress <-
-        fmap (<> ".local") . lift . runM . injectFilesystemBaseFromContext settings $ getStart9AgentHostname
-
-    let specsAgentVersion = agentVersion
-    returnJsonEncoding SpecsRes { .. }
-
-getMetricsR :: Handler (JSONResponse MetricsRes)
-getMetricsR = do
-    app <- getYesod
-    fmap (JSONResponse . MetricsRes) . handleS9ErrT . getServerMetrics $ app
-
-embassyNamePath :: SystemPath
-embassyNamePath = "/root/agent/name.txt"
-
-patchServerR :: Handler ()
-patchServerR = do
-    PatchServerReq { patchServerReqName } <- requireCheckJsonBody @_ @PatchServerReq
-    base <- getsYesod $ appFilesystemBase . appSettings
-    liftIO $ writeFile (toS $ embassyNamePath `relativeTo` base) patchServerReqName
-
-getGitR :: Handler Text
-getGitR = pure $embedGitRevision
-
-getLogsR :: Handler (JSONResponse [Text])
-getLogsR = do
-    let debugLock = "/root/agent/tmp/debug.lock"
-    UnliftIO.bracket (liftIO $ lockFile debugLock Exclusive) (liftIO . unlockFile) $ const $ do
-        liftIO $ callCommand "journalctl -u agent --since \"1 hour ago\" > /root/agent/tmp/debug.log"
-        liftIO $ JSONResponse . lines <$> readFile "/root/agent/tmp/debug.log"

agent/src/Handler/Tor.hs

@@ -1,24 +0,0 @@
-module Handler.Tor where
-
-import           Startlude
-
-import           Data.Aeson
-import           Yesod.Core
-
-import           Foundation
-import           Lib.SystemPaths
-import           Lib.Tor
-import           Control.Carrier.Lift           ( runM )
-
-newtype GetTorRes = GetTorRes { unGetTorRes :: Text }
-instance ToJSON GetTorRes where
-    toJSON a = object ["torAddress" .= unGetTorRes a]
-instance ToContent GetTorRes where
-    toContent = toContent . toJSON
-instance ToTypedContent GetTorRes where
-    toTypedContent = toTypedContent . toJSON
-
-getTorAddressR :: Handler GetTorRes
-getTorAddressR = do
-    settings <- getsYesod appSettings
-    runM $ GetTorRes <$> injectFilesystemBaseFromContext settings getAgentHiddenServiceUrl

agent/src/Handler/Types/Apps.hs

@@ -1,205 +0,0 @@
-{-# LANGUAGE StandaloneKindSignatures #-}
-{-# LANGUAGE QuasiQuotes     #-}
-{-# LANGUAGE RecordWildCards #-}
-module Handler.Types.Apps where
-
-import           Startlude
-
-import           Data.Aeson
-import           Data.Aeson.Flatten
-import           Data.Singletons
-
-import qualified Lib.External.AppManifest      as Manifest
-import           Lib.TyFam.ConditionalData
-import           Lib.Types.Core
-import           Lib.Types.Emver
-import           Lib.Types.Emver.Orphans        ( )
-import           Lib.Types.NetAddress
-data AppBase = AppBase
-    { appBaseId      :: AppId
-    , appBaseTitle   :: Text
-    , appBaseIconUrl :: Text
-    }
-    deriving (Eq, Show)
-instance ToJSON AppBase where
-    toJSON AppBase {..} = object ["id" .= appBaseId, "title" .= appBaseTitle, "iconURL" .= appBaseIconUrl]
-
-data AppAvailablePreview = AppAvailablePreview
-    { appAvailablePreviewBase             :: AppBase
-    , appAvailablePreviewVersionLatest    :: Version
-    , appAvailablePreviewDescriptionShort :: Text
-    , appAvailablePreviewInstallInfo      :: Maybe (Version, AppStatus)
-    , appAvailablePreviewTimestamp        :: UTCTime
-    }
-    deriving (Eq, Show)
-instance ToJSON AppAvailablePreview where
-    toJSON AppAvailablePreview {..} = mergeTo (toJSON appAvailablePreviewBase) $ object
-        [ "versionLatest" .= appAvailablePreviewVersionLatest
-        , "descriptionShort" .= appAvailablePreviewDescriptionShort
-        , "versionInstalled" .= (fst <$> appAvailablePreviewInstallInfo)
-        , "status" .= (snd <$> appAvailablePreviewInstallInfo)
-        , "latestVersionTimestamp" .= appAvailablePreviewTimestamp
-        ]
-
-data AppInstalledPreview = AppInstalledPreview
-    { appInstalledPreviewBase             :: AppBase
-    , appInstalledPreviewStatus           :: AppStatus
-    , appInstalledPreviewVersionInstalled :: Version
-    , appInstalledPreviewTorAddress       :: Maybe TorAddress
-    , appInstalledPreviewLanAddress       :: Maybe LanAddress
-    , appInstalledPreviewTorUi            :: Bool
-    , appInstalledPreviewLanUi            :: Bool
-    }
-    deriving (Eq, Show)
-instance ToJSON AppInstalledPreview where
-    toJSON AppInstalledPreview {..} = mergeTo (toJSON appInstalledPreviewBase) $ object
-        [ "status" .= appInstalledPreviewStatus
-        , "versionInstalled" .= appInstalledPreviewVersionInstalled
-        , "torAddress" .= (unTorAddress <$> appInstalledPreviewTorAddress)
-        , "lanAddress" .= (unLanAddress <$> appInstalledPreviewLanAddress)
-        , "torUi" .= appInstalledPreviewTorUi
-        , "lanUi" .= appInstalledPreviewLanUi
-        ]
-
-data InstallNewAppReq = InstallNewAppReq
-    { installNewAppVersion :: Version
-    , installNewAppDryRun  :: Bool
-    }
-    deriving (Eq, Show)
-instance FromJSON InstallNewAppReq where
-    parseJSON = withObject "Install New App Request" $ \o -> do
-        installNewAppVersion <- o .: "version"
-        installNewAppDryRun  <- o .:? "dryRun" .!= False
-        pure InstallNewAppReq { .. }
-
-data AppAvailableFull = AppAvailableFull
-    { appAvailableFullBase                   :: AppBase
-    , appAvailableFullInstallInfo            :: Maybe (Version, AppStatus)
-    , appAvailableFullVersionLatest          :: Version
-    , appAvailableFullDescriptionShort       :: Text
-    , appAvailableFullDescriptionLong        :: Text
-    , appAvailableFullReleaseNotes           :: Text
-    , appAvailableFullInstallAlert           :: Maybe Text
-    , appAvailableFullDependencyRequirements :: [Full AppDependencyRequirement]
-    , appAvailableFullVersions               :: NonEmpty Version
-    }
-    -- deriving Eq
-instance ToJSON AppAvailableFull where
-    toJSON AppAvailableFull {..} = mergeTo
-        (toJSON appAvailableFullBase)
-        (object
-            [ "versionInstalled" .= fmap fst appAvailableFullInstallInfo
-            , "status" .= fmap snd appAvailableFullInstallInfo
-            , "versionLatest" .= appAvailableFullVersionLatest
-            , "descriptionShort" .= appAvailableFullDescriptionShort
-            , "descriptionLong" .= appAvailableFullDescriptionLong
-            , "versions" .= appAvailableFullVersions
-            , "releaseNotes" .= appAvailableFullReleaseNotes
-            , "serviceRequirements" .= appAvailableFullDependencyRequirements
-            , "installAlert" .= appAvailableFullInstallAlert
-            ]
-        )
-
-type AppDependencyRequirement :: (Type ~> Type) -> Type
-data AppDependencyRequirement f = AppDependencyRequirement
-    { appDependencyRequirementBase           :: AppBase
-    , appDependencyRequirementReasonOptional :: Apply f (Maybe Text)
-    , appDependencyRequirementDefault        :: Apply f Bool
-    , appDependencyRequirementDescription    :: Maybe Text
-    , appDependencyRequirementViolation      :: Maybe ApiDependencyViolation
-    , appDependencyRequirementVersionSpec    :: VersionRange
-    }
-instance ToJSON (AppDependencyRequirement Strip) where
-    toJSON AppDependencyRequirement {..} = mergeTo (toJSON appDependencyRequirementBase) $ object
-        [ "versionSpec" .= appDependencyRequirementVersionSpec
-        , "description" .= appDependencyRequirementDescription
-        , "violation" .= appDependencyRequirementViolation
-        ]
-instance ToJSON (AppDependencyRequirement Keep) where
-    toJSON r =
-        let stripped = r { appDependencyRequirementReasonOptional = (), appDependencyRequirementDefault = () }
-        in
-            mergeTo
-                (toJSON @(AppDependencyRequirement Strip) stripped)
-                (object
-                    [ "optional" .= appDependencyRequirementReasonOptional r
-                    , "default" .= appDependencyRequirementDefault r
-                    ]
-                )
-
--- filter non required dependencies in installed show
--- mute violations downstream of version for installing apps
-data AppInstalledFull = AppInstalledFull
-    { appInstalledFullBase                   :: AppBase
-    , appInstalledFullStatus                 :: AppStatus
-    , appInstalledFullVersionInstalled       :: Version
-    , appInstalledFullTorAddress             :: Maybe TorAddress
-    , appInstalledFullLanAddress             :: Maybe LanAddress
-    , appInstalledFullTorUi                  :: Bool
-    , appInstalledFullLanUi                  :: Bool
-    , appInstalledFullInstructions           :: Maybe Text
-    , appInstalledFullLastBackup             :: Maybe UTCTime
-    , appInstalledFullConfiguredRequirements :: [Stripped AppDependencyRequirement]
-    , appInstalledFullUninstallAlert         :: Maybe Text
-    , appInstalledFullRestoreAlert           :: Maybe Text
-    , appInstalledFullStartAlert             :: Maybe Text
-    , appInstalledFullActions                :: [Manifest.Action]
-    }
-instance ToJSON AppInstalledFull where
-    toJSON AppInstalledFull {..} = object
-        [ "instructions" .= appInstalledFullInstructions
-        , "lastBackup" .= appInstalledFullLastBackup
-        , "configuredRequirements" .= appInstalledFullConfiguredRequirements
-        , "torAddress" .= (unTorAddress <$> appInstalledFullTorAddress)
-        , "lanAddress" .= (unLanAddress <$> appInstalledFullLanAddress)
-        , "torUi" .= appInstalledFullTorUi
-        , "lanUi" .= appInstalledFullLanUi
-        , "id" .= appBaseId appInstalledFullBase
-        , "title" .= appBaseTitle appInstalledFullBase
-        , "iconURL" .= appBaseIconUrl appInstalledFullBase
-        , "versionInstalled" .= appInstalledFullVersionInstalled
-        , "status" .= appInstalledFullStatus
-        , "uninstallAlert" .= appInstalledFullUninstallAlert
-        , "restoreAlert" .= appInstalledFullRestoreAlert
-        , "startAlert" .= appInstalledFullStartAlert
-        , "actions" .= appInstalledFullActions
-        ]
-
-data AppVersionInfo = AppVersionInfo
-    { appVersionInfoVersion                :: Version
-    , appVersionInfoReleaseNotes           :: Text
-    , appVersionInfoDependencyRequirements :: [Full AppDependencyRequirement]
-    , appVersionInfoInstallAlert           :: Maybe Text
-    }
-instance ToJSON AppVersionInfo where
-    toJSON AppVersionInfo {..} = object
-        [ "version" .= appVersionInfoVersion
-        , "releaseNotes" .= appVersionInfoReleaseNotes
-        , "serviceRequirements" .= appVersionInfoDependencyRequirements
-        , "installAlert" .= appVersionInfoInstallAlert
-        ]
-
-data ApiDependencyViolation
-    = Missing
-    | IncompatibleVersion
-    | IncompatibleConfig [Text] -- rule violations
-    | IncompatibleStatus AppStatus
-
-instance ToJSON ApiDependencyViolation where
-    toJSON Missing             = object ["name" .= ("missing" :: Text)]
-    toJSON IncompatibleVersion = object ["name" .= ("incompatible-version" :: Text)]
-    toJSON (IncompatibleConfig ruleViolations) =
-        object ["name" .= ("incompatible-config" :: Text), "ruleViolations" .= ruleViolations]
-    toJSON (IncompatibleStatus status) = object ["name" .= ("incompatible-status" :: Text), "status" .= status]
-
-data WithBreakages a = WithBreakages [AppBase] a
-instance {-# Overlappable #-} ToJSON a => ToJSON (WithBreakages a) where
-    toJSON (WithBreakages breakages thing) = mergeTo (toJSON thing) (object ["breakages" .= breakages])
-instance ToJSON (WithBreakages ()) where
-    toJSON (WithBreakages breakages _) = object ["breakages" .= breakages]
-
-newtype AutoconfigureChangesRes = AutoconfigureChangesRes
-    { autoconfigureChangesConfig :: Maybe Value
-    }
-instance ToJSON AutoconfigureChangesRes where
-    toJSON AutoconfigureChangesRes {..} = object ["config" .= autoconfigureChangesConfig]

agent/src/Handler/Types/HmacSig.hs

@@ -1,28 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-module Handler.Types.HmacSig where
-
-import           Startlude
-
-import           Crypto.Hash
-import           Data.Aeson
-import           Data.ByteArray.Encoding
-import           Data.ByteArray.Sized
-import           Yesod.Core
-
-import           Handler.Types.Parse
-
-data HmacSig = HmacSig
-    { sigHmac    :: Digest SHA256
-    , sigMessage :: Text
-    , sigSalt    :: SizedByteArray 16 ByteString
-    }
-    deriving (Eq, Show)
-
-instance ToJSON HmacSig where
-    toJSON (HmacSig {..}) =
-        object ["hmac" .= fromUnsizedBs Base16 sigHmac, "message" .= sigMessage, "salt" .= fromSizedBs Base16 sigSalt]
-
-instance ToTypedContent HmacSig where
-    toTypedContent = toTypedContent . toJSON
-instance ToContent HmacSig where
-    toContent = toContent . toJSON

agent/src/Handler/Types/Hosts.hs

@@ -1,44 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-module Handler.Types.Hosts where
-
-import           Startlude
-
-import           Crypto.Hash
-import           Data.Aeson
-import           Data.ByteArray.Encoding
-import           Data.ByteArray.Sized
-import           Yesod.Core
-
-import           Handler.Types.Parse
-import           Handler.Types.Register
-import           Lib.Error
-
-data HostsParams = HostsParams
-    { hostsParamsHmac       :: Digest SHA256 -- hmac of an expiration timestamp
-    , hostsParamsExpiration :: Text -- This is a UTC time text string. we leave it as text as it is precisely this which is signed by the above hmac.
-    , hostsParamsSalt       :: SizedByteArray 16 ByteString
-    }
-
-data HostsRes = NullReply | HostsRes RegisterRes
-    deriving (Eq, Show)
-
-instance ToJSON HostsRes where
-    toJSON NullReply              = Null
-    toJSON (HostsRes registerRes) = toJSON registerRes
-
-instance ToTypedContent HostsRes where
-    toTypedContent = toTypedContent . toJSON
-instance ToContent HostsRes where
-    toContent = toContent . toJSON
-
-extractHostsQueryParams :: MonadHandler m => S9ErrT m HostsParams
-extractHostsQueryParams = do
-    hostsParamsHmac <- lookupGetParam "hmac" <&> (>>= sizedBs @32 Base16 >=> digestFromByteString) >>= orThrow400 "hmac"
-    hostsParamsSalt <- lookupGetParam "salt" <&> (>>= sizedBs @16 Base16) >>= orThrow400 "salt"
-    hostsParamsExpiration <- lookupGetParam "message" >>= orThrow400 "message"
-
-    pure HostsParams { .. }
-    where
-        orThrow400 desc = \case
-            Nothing -> throwE $ HostsParamsE desc
-            Just p  -> pure p

agent/src/Handler/Types/Metrics.hs

@@ -1,26 +0,0 @@
-{-# LANGUAGE DeriveGeneric   #-}
-{-# LANGUAGE NamedFieldPuns  #-}
-{-# LANGUAGE RecordWildCards #-}
-module Handler.Types.Metrics where
-
-import           Startlude
-
-import           Lib.Metrics
-
-import           Data.Aeson
-import           Yesod.Core.Content
-
-newtype MetricsRes = MetricsRes { unMetricsRes :: ServerMetrics }
-instance ToJSON MetricsRes where
-    toJSON     = toJSON . unMetricsRes
-    toEncoding = toEncoding . unMetricsRes
-instance ToTypedContent MetricsRes where
-    toTypedContent = toTypedContent . toJSON
-instance ToContent MetricsRes where
-    toContent = toContent . toJSON
-
-newtype PatchServerReq = PatchServerReq { patchServerReqName :: Text }
-instance FromJSON PatchServerReq where
-    parseJSON = withObject "Patch Server Request" $ \o -> do
-        patchServerReqName <- o .: "name"
-        pure $ PatchServerReq { patchServerReqName }

agent/src/Handler/Types/Parse.hs

@@ -1,32 +0,0 @@
-module Handler.Types.Parse where
-
-import           Startlude
-
-import           Control.Monad.Fail
-import           Data.Aeson.Types
-import           Data.ByteArray
-import           Data.ByteArray.Encoding
-import           Data.ByteArray.Sized
-
-mToParser :: String -> Maybe a -> Parser a
-mToParser failureText = \case
-  Nothing -> fail failureText
-  Just t -> pure t
-
-toUnsizedBs :: String -> Base -> Text -> Parser ByteString
-toUnsizedBs failureText base = mToParser failureText . unsizedBs base
-
-unsizedBs :: Base -> Text -> Maybe ByteString
-unsizedBs base = hush . convertFromBase base . encodeUtf8
-
-toSizedBs :: KnownNat n => String -> Base -> Text -> Parser (SizedByteArray n ByteString)
-toSizedBs failureText base = mToParser failureText . sizedBs base
-
-sizedBs :: KnownNat n => Base -> Text -> Maybe (SizedByteArray n ByteString)
-sizedBs base = sizedByteArray <=< unsizedBs base
-
-fromUnsizedBs :: ByteArrayAccess ba => Base -> ba -> Text
-fromUnsizedBs base = decodeUtf8 . convertToBase base
-
-fromSizedBs :: (KnownNat n, ByteArrayAccess ba) => Base -> SizedByteArray n ba -> Text
-fromSizedBs b = fromUnsizedBs b . unSizedByteArray

agent/src/Handler/Types/Register.hs

@@ -1,65 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-module Handler.Types.Register where
-
-import           Startlude
-
-import           Data.Aeson
-import           Data.ByteArray.Encoding
-import           Data.ByteArray.Sized
-import           Yesod.Core
-
-import           Handler.Types.HmacSig
-import           Handler.Types.Parse
-
-data RegisterReq = RegisterReq
-    { registerTorKey             :: SizedByteArray 96 ByteString -- Represents a tor private key along with tor private key file prefix.
-    , registerTorCtrCounter      :: SizedByteArray 16 ByteString
-    , registerTorKdfSalt         :: SizedByteArray 16 ByteString
-    , registerPassword           :: ByteString -- Encrypted password
-    , registerPasswordCtrCounter :: SizedByteArray 16 ByteString
-    , registerPasswordKdfSalt    :: SizedByteArray 16 ByteString
-    , registerRsa                :: ByteString -- Encrypted RSA key
-    , registerRsaCtrCounter      :: SizedByteArray 16 ByteString
-    , registerRsaKdfSalt         :: SizedByteArray 16 ByteString
-    }
-    deriving (Eq, Show)
-
-
-data RegisterRes = RegisterRes
-    { registerResClaimedAt     :: UTCTime
-    , registerResTorAddressSig :: HmacSig
-    , registerResCertSig       :: HmacSig
-    , registerResCertName      :: Text
-    , registerResLanAddress    :: Text
-    }
-    deriving (Eq, Show)
-
-instance FromJSON RegisterReq where
-    parseJSON = withObject "Register Tor Request" $ \o -> do
-        registerTorKey             <- o .: "torkey" >>= toSizedBs "Invalid torkey encryption" Base16
-        registerTorCtrCounter      <- o .: "torkeyCounter" >>= toSizedBs "Invalid torkey ctr counter" Base16
-        registerTorKdfSalt         <- o .: "torkeySalt" >>= toSizedBs "Invalid torkey pbkdf2 salt" Base16
-
-        registerPassword           <- o .: "password" >>= toUnsizedBs "Invalid password encryption" Base16
-        registerPasswordCtrCounter <- o .: "passwordCounter" >>= toSizedBs "Invalid password ctr counter" Base16
-        registerPasswordKdfSalt    <- o .: "passwordSalt" >>= toSizedBs "Invalid password pbkdf2 salt" Base16
-
-        registerRsa                <- o .: "rsaKey" >>= toUnsizedBs "Invalid rsa encryption" Base16
-        registerRsaCtrCounter      <- o .: "rsaCounter" >>= toSizedBs "Invalid rsa ctr counter" Base16
-        registerRsaKdfSalt         <- o .: "rsaSalt" >>= toSizedBs "Invalid rsa pbkdf2 salt" Base16
-
-        pure RegisterReq { .. }
-
-instance ToJSON RegisterRes where
-    toJSON (RegisterRes {..}) = object
-        [ "claimedAt" .= registerResClaimedAt
-        , "torAddressSig" .= registerResTorAddressSig
-        , "certSig" .= registerResCertSig
-        , "certName" .= registerResCertName
-        , "lanAddress" .= registerResLanAddress
-        ]
-
-instance ToTypedContent RegisterRes where
-    toTypedContent = toTypedContent . toJSON
-instance ToContent RegisterRes where
-    toContent = toContent . toJSON

agent/src/Handler/Types/V0/Base.hs

@@ -1,82 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-module Handler.Types.V0.Base where
-
-import           Startlude
-
-import           Data.Aeson
-import           Database.Persist
-import           Yesod.Core
-
-import           Handler.Types.V0.Ssh
-import           Handler.Types.V0.Specs
-import           Handler.Types.V0.Wifi
-import           Lib.Types.Core
-import           Lib.Types.Emver
-import           Model
-
-data VersionLatestRes = VersionLatestRes
-    { versionLatestVersion      :: Version
-    , versionLatestReleaseNotes :: Maybe Text
-    }
-    deriving (Eq, Show)
-instance ToJSON VersionLatestRes where
-    toJSON VersionLatestRes {..} =
-        object $ ["versionLatest" .= versionLatestVersion, "releaseNotes" .= versionLatestReleaseNotes]
-instance ToTypedContent VersionLatestRes where
-    toTypedContent = toTypedContent . toJSON
-instance ToContent VersionLatestRes where
-    toContent = toContent . toJSON
-
-data ServerRes = ServerRes
-    { serverId                     :: Text
-    , serverName                   :: Text
-    , serverStatus                 :: Maybe AppStatus
-    , serverStatusAt               :: UTCTime
-    , serverVersionInstalled       :: Version
-    , serverNotifications          :: [Entity Notification]
-    , serverWifi                   :: WifiList
-    , serverSsh                    :: [SshKeyFingerprint]
-    , serverAlternativeRegistryUrl :: Maybe Text
-    , serverSpecs                  :: SpecsRes
-    , serverWelcomeAck             :: Bool
-    , serverAutoCheckUpdates       :: Bool
-    }
-    deriving (Eq, Show)
-
-type JsonEncoding a = Encoding
-jsonEncode :: (Monad m, ToJSON a) => a -> m (JsonEncoding a)
-jsonEncode = returnJsonEncoding
-
-instance ToJSON ServerRes where
-    toJSON ServerRes {..} = object
-        [ "serverId" .= serverId
-        , "name" .= serverName
-        , "status" .= case serverStatus of
-            Nothing   -> String "UPDATING"
-            Just stat -> toJSON stat
-        , "versionInstalled" .= serverVersionInstalled
-        , "notifications" .= serverNotifications
-        , "wifi" .= serverWifi
-        , "ssh" .= serverSsh
-        , "alternativeRegistryUrl" .= serverAlternativeRegistryUrl
-        , "specs" .= serverSpecs
-        , "welcomeAck" .= serverWelcomeAck
-        , "autoCheckUpdates" .= serverAutoCheckUpdates
-        ]
-instance ToTypedContent ServerRes where
-    toTypedContent = toTypedContent . toJSON
-instance ToContent ServerRes where
-    toContent = toContent . toJSON
-
-newtype AppVersionRes = AppVersionRes
-    { unAppVersionRes :: Version } deriving (Eq, Show)
-instance ToJSON AppVersionRes where
-    toJSON AppVersionRes { unAppVersionRes } = object ["version" .= unAppVersionRes]
-instance FromJSON AppVersionRes where
-    parseJSON = withObject "app version response" $ \o -> do
-        av <- o .: "version"
-        pure $ AppVersionRes av
-instance ToContent AppVersionRes where
-    toContent = toContent . toJSON
-instance ToTypedContent AppVersionRes where
-    toTypedContent = toTypedContent . toJSON

agent/src/Handler/Types/V0/Specs.hs

@@ -1,48 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-module Handler.Types.V0.Specs where
-
-import           Startlude
-
-import           Lib.Types.Emver
-import           Lib.Types.Emver.Orphans        ( )
-
-import           Data.Aeson
-import           Yesod.Core
-
-data SpecsRes = SpecsRes
-    { specsCPU          :: Text
-    , specsMem          :: Text
-    , specsDisk         :: Maybe Text
-    , specsNetworkId    :: Text
-    , specsAgentVersion :: Version
-    , specsTorAddress   :: Text
-    , specsLanAddress   :: Text
-    }
-    deriving (Eq, Show)
-
-instance ToJSON SpecsRes where
-    toJSON SpecsRes {..} = object
-        [ "EmbassyOS Version" .= specsAgentVersion
-        , "Tor Address" .= specsTorAddress
-        , "LAN Address" .= specsLanAddress
-        , "Network ID" .= specsNetworkId
-        , "CPU" .= specsCPU
-        , "Memory" .= specsMem
-        , "Disk" .= specsDisk
-        ]
-    toEncoding SpecsRes {..} =
-        pairs
-            . fold
-            $ [ "EmbassyOS Version" .= specsAgentVersion
-              , "Tor Address" .= specsTorAddress
-              , "LAN Address" .= specsLanAddress
-              , "Network ID" .= specsNetworkId
-              , "CPU" .= specsCPU
-              , "Memory" .= specsMem
-              , "Disk" .= specsDisk
-              ]
-
-instance ToTypedContent SpecsRes where
-    toTypedContent = toTypedContent . toJSON
-instance ToContent SpecsRes where
-    toContent = toContent . toJSON

agent/src/Handler/Types/V0/Ssh.hs

@@ -1,25 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-module Handler.Types.V0.Ssh where
-
-import           Startlude
-
-import           Lib.Ssh
-
-import           Data.Aeson
-import           Yesod.Core
-
-newtype SshKeyModReq = SshKeyModReq { sshKey :: Text } deriving (Eq, Show)
-instance FromJSON SshKeyModReq where
-    parseJSON = withObject "ssh key" $ fmap SshKeyModReq . (.: "sshKey")
-
-data SshKeyFingerprint = SshKeyFingerprint
-    { sshKeyAlg      :: SshAlg
-    , sshKeyHash     :: Text
-    , sshKeyHostname :: Text
-    } deriving (Eq, Show)
-instance ToJSON SshKeyFingerprint where
-    toJSON SshKeyFingerprint {..} = object ["alg" .= sshKeyAlg, "hash" .= sshKeyHash, "hostname" .= sshKeyHostname]
-instance ToTypedContent SshKeyFingerprint where
-    toTypedContent = toTypedContent . toJSON
-instance ToContent SshKeyFingerprint where
-    toContent = toContent . toJSON

agent/src/Handler/Types/V0/Wifi.hs

@@ -1,32 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-module Handler.Types.V0.Wifi where
-
-import           Startlude
-
-import           Data.Aeson
-import           Yesod.Core
-
-data AddWifiReq = AddWifiReq
-    { addWifiSsid     :: Text
-    , addWifiPassword :: Text
-    , addWifiCountry  :: Text
-    , skipConnect     :: Bool
-    } deriving (Eq, Show)
-instance FromJSON AddWifiReq where
-    parseJSON = withObject "AddWifiReq" $ \o -> do
-        addWifiSsid     <- o .: "ssid"
-        addWifiPassword <- o .: "password"
-        addWifiCountry  <- o .:? "country" .!= "US"
-        skipConnect     <- o .:? "skipConnect" .!= False
-        pure AddWifiReq { .. }
-
-data WifiList = WifiList
-    { wifiListCurrent :: Maybe Text
-    , wifiListSsids   :: [Text]
-    } deriving (Eq, Show)
-instance ToJSON WifiList where
-    toJSON WifiList {..} = object ["current" .= wifiListCurrent, "ssids" .= wifiListSsids]
-instance ToTypedContent WifiList where
-    toTypedContent = toTypedContent . toJSON
-instance ToContent WifiList where
-    toContent = toContent . toJSON

agent/src/Handler/Util.hs

@@ -1,16 +0,0 @@
-module Handler.Util where
-
-import           Startlude
-
-import           Data.IORef
-import           Yesod.Core
-
-import           Foundation
-import           Lib.Error
-
-disableEndpointOnFailedUpdate :: Handler a -> Handler a
-disableEndpointOnFailedUpdate m = handleS9ErrT $ do
-    updateFailed <- getsYesod appIsUpdateFailed >>= liftIO . readIORef
-    case updateFailed of
-        Just e  -> throwE e
-        Nothing -> lift m

agent/src/Handler/V0.hs

@@ -1,144 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TemplateHaskell #-}
-module Handler.V0 where
-
-import           Startlude               hiding ( runReader )
-
-import           Control.Carrier.Lift           ( runM )
-import           Data.Aeson
-import           Data.IORef
-import qualified Data.Text                     as T
-import           Database.Persist              as Persist
-import           Yesod.Core.Handler
-import           Yesod.Persist.Core
-import           Yesod.Core.Json
-
-import           Constants
-import           Daemon.ZeroConf
-import           Foundation
-import           Handler.Types.V0.Specs
-import           Handler.Types.V0.Ssh
-import           Handler.Types.V0.Base
-import           Handler.Types.V0.Wifi
-import           Lib.Error
-import           Lib.External.Metrics.Df
-import           Lib.External.Specs.CPU
-import           Lib.External.Specs.Memory
-import qualified Lib.External.WpaSupplicant    as WpaSupplicant
-import           Lib.Notifications
-import           Lib.SystemPaths
-import           Lib.Ssh
-import           Lib.Tor
-import           Lib.Types.Core
-import           Lib.Types.Emver
-import           Model
-import           Settings
-import           Util.Function
-
-
-getServerR :: Handler (JsonEncoding ServerRes)
-getServerR = handleS9ErrT $ do
-    agentCtx <- getYesod
-    let settings = appSettings agentCtx
-    now        <- liftIO getCurrentTime
-    isUpdating <- getsYesod appIsUpdating >>= liftIO . readIORef
-
-    let status = if isJust isUpdating then Nothing else Just Running
-
-    notifs <- case isUpdating of
-        Nothing -> lift . runDB $ do
-            notif <- selectList [NotificationArchivedAt ==. Nothing] [Desc NotificationCreatedAt]
-            void . archive . fmap entityKey $ notif
-            pure notif
-        Just _ -> pure []
-
-    alternativeRegistryUrl <- runM $ injectFilesystemBaseFromContext settings $ readSystemPath altRegistryUrlPath
-    name                   <- runM $ injectFilesystemBaseFromContext settings $ readSystemPath serverNamePath
-    ssh                    <- readFromPath settings sshKeysFilePath >>= parseSshKeys
-    wifi <- WpaSupplicant.runWlan0 $ liftA2 WifiList WpaSupplicant.getCurrentNetwork WpaSupplicant.listNetworks
-    specs                  <- getSpecs settings
-    welcomeAck             <- fmap isJust . lift . runDB . Persist.get $ WelcomeAckKey agentVersion
-    autoCheckUpdates       <- runM $ injectFilesystemBaseFromContext settings $ fmap not (existsSystemPath disableAutoCheckUpdatesPath)
-
-    let sid = T.drop 7 $ specsNetworkId specs
-
-    jsonEncode ServerRes { serverId                     = specsNetworkId specs
-                         , serverName                   = fromMaybe ("Embassy:" <> sid) name
-                         , serverStatus                 = AppStatusAppMgr <$> status
-                         , serverStatusAt               = now
-                         , serverVersionInstalled       = agentVersion
-                         , serverNotifications          = notifs
-                         , serverWifi                   = wifi
-                         , serverSsh                    = ssh
-                         , serverAlternativeRegistryUrl = alternativeRegistryUrl
-                         , serverSpecs                  = specs
-                         , serverWelcomeAck             = welcomeAck
-                         , serverAutoCheckUpdates       = autoCheckUpdates
-                         }
-    where
-        parseSshKeys :: Text -> S9ErrT Handler [SshKeyFingerprint]
-        parseSshKeys keysContent = do
-            let keys = lines . T.strip $ keysContent
-            case traverse fingerprint keys of
-                Left  e  -> throwE $ InvalidSshKeyE (toS e)
-                Right as -> pure $ uncurry3 SshKeyFingerprint <$> as
-
-postWelcomeR :: Version -> Handler ()
-postWelcomeR version = runDB $ repsert (WelcomeAckKey version) WelcomeAck
-
-getSpecs :: MonadIO m => AppSettings -> S9ErrT m SpecsRes
-getSpecs settings = do
-    specsCPU        <- liftIO getCpuInfo
-    specsMem        <- liftIO getMem
-    specsDisk       <- fmap show . metricDiskSize <$> getDfMetrics
-    specsNetworkId  <- runM $ injectFilesystemBaseFromContext settings getStart9AgentHostname
-    specsTorAddress <- runM $ injectFilesystemBaseFromContext settings getAgentHiddenServiceUrl
-    specsLanAddress <- fmap (<> ".local") . runM $ injectFilesystemBaseFromContext settings getStart9AgentHostname
-
-    let specsAgentVersion = agentVersion
-    pure $ SpecsRes { .. }
-
-readFromPath :: MonadIO m => AppSettings -> SystemPath -> S9ErrT m Text
-readFromPath settings sp = runM (injectFilesystemBaseFromContext settings (readSystemPath sp)) >>= \case
-    Nothing  -> throwE $ MissingFileE sp
-    Just res -> pure res
-
---------------------- UPDATES TO SERVER -------------------------
-
-newtype PatchReq = PatchReq { patchValue :: Text } deriving(Eq, Show)
-instance FromJSON PatchReq where
-    parseJSON = withObject "Patch Request" $ \o -> PatchReq <$> o .: "value"
-
-newtype NullablePatchReq = NullablePatchReq { mpatchValue :: Maybe Text } deriving(Eq, Show)
-instance FromJSON NullablePatchReq where
-    parseJSON = withObject "Nullable Patch Request" $ \o -> NullablePatchReq <$> o .:? "value"
-
-newtype BoolPatchReq = BoolPatchReq { bpatchValue :: Bool } deriving (Eq, Show)
-
-instance FromJSON BoolPatchReq where
-    parseJSON = withObject "Patch Request" $ \o -> BoolPatchReq <$> o .: "value"
-
-patchNameR :: Handler ()
-patchNameR = patchFile serverNamePath
-
-patchAutoCheckUpdatesR :: Handler ()
-patchAutoCheckUpdatesR = do
-    settings         <- getsYesod appSettings
-    BoolPatchReq val <- requireCheckJsonBody
-    runM $ injectFilesystemBaseFromContext settings $ if val
-        then deleteSystemPath disableAutoCheckUpdatesPath
-        else writeSystemPath disableAutoCheckUpdatesPath ""
-
-patchFile :: SystemPath -> Handler ()
-patchFile path = do
-    settings     <- getsYesod appSettings
-    PatchReq val <- requireCheckJsonBody
-    runM $ injectFilesystemBaseFromContext settings $ writeSystemPath path val
-
-patchNullableFile :: SystemPath -> Handler ()
-patchNullableFile path = do
-    settings              <- getsYesod appSettings
-    NullablePatchReq mVal <- requireCheckJsonBody
-    runM $ injectFilesystemBaseFromContext settings $ case mVal of
-        Just val -> writeSystemPath path $ T.strip val
-        Nothing  -> deleteSystemPath path

agent/src/Handler/Wifi.hs

@@ -1,76 +0,0 @@
-{-# LANGUAGE QuasiQuotes     #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TemplateHaskell #-}
-module Handler.Wifi where
-
-import           Startlude
-
-import           Data.String.Interpolate.IsString
-import qualified Data.Text                     as T
-import           Network.HTTP.Types
-import           Yesod.Core
-
-import           Constants
-import           Foundation
-import           Handler.Types.V0.Wifi
-import           Lib.Error
-import qualified Lib.External.WpaSupplicant    as WpaSupplicant
-
-getWifiR :: Handler WifiList
-getWifiR = WpaSupplicant.runWlan0 $ liftA2 WifiList WpaSupplicant.getCurrentNetwork WpaSupplicant.listNetworks
-
-postWifiR :: Handler ()
-postWifiR = handleS9ErrT $ do
-    AddWifiReq { addWifiSsid, addWifiPassword, addWifiCountry, skipConnect } <- requireCheckJsonBody
-    unless (T.all isAscii addWifiSsid) $ throwE InvalidSsidE
-    unless (T.all isAscii addWifiPassword) $ throwE InvalidPskE
-
-    _ <- liftIO . forkIO . WpaSupplicant.runWlan0 $ do
-        lift $ withAgentVersionLog_ [i|Adding new WiFi network: '#{addWifiSsid}'|]
-        WpaSupplicant.addNetwork addWifiSsid addWifiPassword addWifiCountry
-        unless skipConnect $ do
-            mCurrent <- WpaSupplicant.getCurrentNetwork
-            connected <- WpaSupplicant.selectNetwork addWifiSsid addWifiCountry
-            unless connected do
-                lift $ withAgentVersionLog_ [i|Failed to add new WiFi network: '#{addWifiSsid}'|]
-                WpaSupplicant.removeNetwork addWifiSsid
-                case mCurrent of
-                    Nothing -> pure ()
-                    Just current -> void $ WpaSupplicant.selectNetwork current addWifiSsid
-    sendResponseStatus status200 ()
-
-
-postWifiBySsidR :: Text -> Handler ()
-postWifiBySsidR ssid = handleS9ErrT $ do
-    unless (T.all isAscii ssid) $ throwE InvalidSsidE
-
-    -- TODO: Front end never sends this on switching between networks. This means that we can only
-    -- switch to US networks.
-    country <- fromMaybe "US" <$> lookupGetParam "country"
-    _       <- liftIO . forkIO . WpaSupplicant.runWlan0 $ do
-        mCurrent <- WpaSupplicant.getCurrentNetwork
-        connected <- WpaSupplicant.selectNetwork ssid country
-        if connected
-            then lift $ withAgentVersionLog_ [i|Successfully connected to WiFi: #{ssid}|]
-            else do
-                lift $ withAgentVersionLog_ [i|Failed to add new WiFi network: '#{ssid}'|]
-                case mCurrent of
-                    Nothing -> lift $ withAgentVersionLog_ [i|No WiFi to revert to!|]
-                    Just current -> void $ WpaSupplicant.selectNetwork current country
-    sendResponseStatus status200 ()
-
-deleteWifiBySsidR :: Text -> Handler ()
-deleteWifiBySsidR ssid = handleS9ErrT $ do
-    unless (T.all isAscii ssid) $ throwE InvalidSsidE
-    WpaSupplicant.runWlan0 $ do
-        current <- WpaSupplicant.getCurrentNetwork
-        case current of
-            Nothing -> deleteIt
-            Just ssid' -> if ssid == ssid'
-                then do
-                    eth0 <- WpaSupplicant.isConnectedToEthernet
-                    if eth0
-                        then deleteIt
-                        else lift $ throwE WifiOrphaningE
-                else deleteIt
-    where deleteIt = void $ WpaSupplicant.removeNetwork ssid

agent/src/Lib/Algebra/Domain/AppMgr.hs

@@ -1,481 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -- because of my sheer laziness in dealing with conditional data
-{-# OPTIONS_GHC -fno-show-valid-hole-fits #-} -- to not make dev'ing this module cripplingly slow
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneKindSignatures #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-module Lib.Algebra.Domain.AppMgr
-    ( module Lib.Algebra.Domain.AppMgr
-    , module Lib.Algebra.Domain.AppMgr.Types
-    , module Lib.Algebra.Domain.AppMgr.TH
-    )
-where
-
-import           Startlude
-
-import           Control.Algebra
-import           Control.Effect.Error
-import           Control.Effect.TH
-import           Data.Aeson
-import           Data.Aeson.Types               ( Parser )
-import qualified Data.HashMap.Strict           as HM
-import           Data.Singletons.Prelude hiding ( Error )
-import           Data.Singletons.Prelude.Either
-import qualified Data.String                   as String
-
-import           Lib.Algebra.Domain.AppMgr.Types
-import           Lib.Algebra.Domain.AppMgr.TH
-import           Lib.Error
-import qualified Lib.External.AppManifest      as Manifest
-import           Lib.TyFam.ConditionalData
-import           Lib.Types.Core                 ( AppId(..)
-                                                , AppContainerStatus(..)
-                                                )
-import           Lib.Types.NetAddress
-import           Lib.Types.Emver
-import           Control.Monad.Trans.Class      ( MonadTrans )
-import qualified Data.ByteString.Lazy          as LBS
-import           System.Process.Typed
-import           Data.String.Interpolate.IsString
-                                                ( i )
-import           Control.Monad.Base             ( MonadBase(..) )
-import           Control.Monad.Fail             ( MonadFail(fail) )
-import           Control.Monad.Trans.Resource   ( MonadResource(..) )
-import           Control.Monad.Trans.Control    ( defaultLiftBaseWith
-                                                , defaultRestoreM
-                                                , MonadTransControl(..)
-                                                , MonadBaseControl(..)
-                                                )
-import qualified Data.ByteString.Char8         as C8
-import           System.Process
-
-
-type InfoRes :: Either OnlyInfoFlag [IncludeInfoFlag] -> Type
-data InfoRes a = InfoRes
-    { infoResTitle         :: Include (IsRight a) Text
-    , infoResVersion       :: Include (IsRight a) Version
-    , infoResTorAddress    :: Include (IsRight a) (Maybe TorAddress)
-    , infoResIsConfigured  :: Include (IsRight a) Bool
-    , infoResIsRecoverable :: Include (IsRight a) Bool
-    , infoResNeedsRestart  :: Include (IsRight a) Bool
-    , infoResConfig        :: Include (Either_ (DefaultEqSym1 'OnlyConfig) (ElemSym1 'IncludeConfig) a) Value
-    , infoResDependencies
-          :: Include
-              (Either_ (DefaultEqSym1 'OnlyDependencies) (ElemSym1 'IncludeDependencies) a)
-              (HM.HashMap AppId DependencyInfo)
-    , infoResManifest
-          :: Include (Either_ (DefaultEqSym1 'OnlyManifest) (ElemSym1 'IncludeManifest) a) Manifest.AppManifest
-    , infoResStatus :: Include (Either_ (DefaultEqSym1 'OnlyStatus) (ElemSym1 'IncludeStatus) a) AppContainerStatus
-    }
-instance SingI (a :: Either OnlyInfoFlag [IncludeInfoFlag]) => FromJSON (InfoRes a) where
-    parseJSON = withObject "AppMgr Info/List Response" $ \o -> do
-        let recurse :: forall (a :: [IncludeInfoFlag]) . SingI a => Value -> Parser (InfoRes ( 'Right a))
-            recurse = parseJSON @(InfoRes ( 'Right a))
-        let infoResConfig       = ()
-        let infoResDependencies = ()
-        let infoResManifest     = ()
-        let infoResStatus       = ()
-        case sing @a of
-            SLeft f -> do
-                let infoResTitle         = ()
-                let infoResVersion       = ()
-                let infoResTorAddress    = ()
-                let infoResIsConfigured  = ()
-                let infoResIsRecoverable = ()
-                let infoResNeedsRestart  = ()
-                case f of
-                    SOnlyConfig       -> let infoResConfig = (Object o) in pure InfoRes { .. }
-                    SOnlyDependencies -> parseJSON (Object o) >>= \infoResDependencies -> pure InfoRes { .. }
-                    SOnlyManifest     -> parseJSON (Object o) >>= \infoResManifest -> pure InfoRes { .. }
-                    SOnlyStatus       -> o .: "status" >>= \infoResStatus -> pure InfoRes { .. }
-            SRight ls -> do
-                infoResTitle         <- o .: "title"
-                infoResVersion       <- o .: "version"
-                infoResTorAddress    <- TorAddress <<$>> o .: "tor-address"
-                infoResIsConfigured  <- o .: "configured"
-                infoResIsRecoverable <- o .:? "recoverable" .!= False
-                infoResNeedsRestart  <- o .:? "needs-restart" .!= False
-                let base = (InfoRes { .. } :: InfoRes ( 'Right '[]))
-                case ls of
-                    SNil -> pure base
-                    SCons SIncludeConfig (rest :: Sing b) -> do
-                        InfoRes {..}  <- withSingI rest $ recurse @b (Object o)
-                        infoResConfig <- o .: "config"
-                        pure InfoRes { .. }
-                    SCons SIncludeDependencies (rest :: Sing b) -> do
-                        InfoRes {..}        <- withSingI rest $ recurse @b (Object o)
-                        infoResDependencies <- o .: "dependencies"
-                        pure InfoRes { .. }
-                    SCons SIncludeManifest (rest :: Sing b) -> do
-                        InfoRes {..}    <- withSingI rest $ recurse @b (Object o)
-                        infoResManifest <- o .: "manifest"
-                        pure InfoRes { .. }
-                    SCons SIncludeStatus (rest :: Sing b) -> do
-                        InfoRes {..}  <- withSingI rest $ recurse @b (Object o)
-                        infoResStatus <- o .: "status"
-                        pure InfoRes { .. }
-
-data DependencyInfo = DependencyInfo
-    { dependencyInfoVersionSpec    :: VersionRange
-    , dependencyInfoReasonOptional :: Maybe Text
-    , dependencyInfoDescription    :: Maybe Text
-    , dependencyInfoConfigRules    :: [ConfigRule]
-    , dependencyInfoRequired       :: Bool
-    , dependencyInfoError          :: Maybe DependencyViolation
-    }
-    deriving (Eq, Show)
-instance FromJSON DependencyInfo where
-    parseJSON = withObject "AppMgr DependencyInfo" $ \o -> do
-        dependencyInfoVersionSpec    <- o .: "version"
-        dependencyInfoReasonOptional <- o .: "optional"
-        dependencyInfoDescription    <- o .: "description"
-        dependencyInfoConfigRules    <- o .: "config"
-        dependencyInfoRequired       <- o .: "required"
-        dependencyInfoError          <- o .:? "error"
-        pure DependencyInfo { .. }
-
-data ConfigRule = ConfigRule
-    { configRuleRule        :: Text
-    , configRuleDescription :: Text
-    , configRuleSuggestions :: [ConfigRuleSuggestion]
-    }
-    deriving (Eq, Show)
-instance FromJSON ConfigRule where
-    parseJSON = withObject "AppMgr Config Rule" $ \o -> do
-        configRuleRule        <- o .: "rule"
-        configRuleDescription <- o .: "description"
-        configRuleSuggestions <- o .: "suggestions"
-        pure ConfigRule { .. }
-data ConfigRuleSuggestion
-    = SuggestionPush Text Value
-    | SuggestionSet Text Target
-    | SuggestionDelete Text
-    deriving (Eq, Show)
-instance FromJSON ConfigRuleSuggestion where
-    parseJSON = withObject "AppMgr ConfigRule Suggestion" $ \o -> do
-        let push = do
-                o' <- o .: "PUSH"
-                t  <- o' .: "to"
-                v  <- o' .: "value"
-                pure $ SuggestionPush t v
-        let set = do
-                o' <- o .: "SET"
-                v  <- o' .: "var"
-                t  <- parseJSON (Object o')
-                pure $ SuggestionSet v t
-        let delete = SuggestionDelete <$> o .: "DELETE"
-        push <|> set <|> delete
-
-data Target
-    = To Text
-    | ToValue Value
-    | ToEntropy Text Word16
-    deriving (Eq, Show)
-instance FromJSON Target where
-    parseJSON = withObject "Suggestion SET Target" $ \o -> do
-        (To <$> o .: "to") <|> (ToValue <$> o .: "to-value") <|> do
-            o' <- o .: "to-entropy"
-            ToEntropy <$> o' .: "charset" <*> o' .: "len"
-
-data DependencyError
-    = Violation DependencyViolation
-    | PointerUpdateError Text
-    | Other Text
-    deriving (Eq, Show)
-instance FromJSON DependencyError where
-    parseJSON v = (Violation <$> parseJSON v) <|> case v of
-        Object o -> (PointerUpdateError <$> o .: "pointer-update-error") <|> (Other <$> o .: "other")
-        other    -> fail $ "Invalid DependencyError. Expected Object, got " <> (show other)
-
-data DependencyViolation
-    = NotInstalled
-    | NotRunning
-    | InvalidVersion VersionRange Version
-    | UnsatisfiedConfig [Text]
-    deriving (Eq, Show)
-instance FromJSON DependencyViolation where
-    parseJSON (String "not-installed") = pure NotInstalled
-    parseJSON (String "not-running"  ) = pure NotRunning
-    parseJSON (Object o) =
-        let version = do
-                o' <- o .: "incorrect-version"
-                s  <- o' .: "expected"
-                v  <- o' .: "received"
-                pure $ InvalidVersion s v
-            config = UnsatisfiedConfig <$> o .: "config-unsatisfied"
-        in  version <|> config
-    parseJSON other = fail $ "Invalid Dependency Violation" <> show other
-
-data AutoconfigureRes = AutoconfigureRes
-    { autoconfigureConfigRes :: ConfigureRes
-    , autoconfigureChanged   :: HM.HashMap AppId Value
-    }
-instance FromJSON AutoconfigureRes where
-    parseJSON = withObject "AppMgr AutoconfigureRes" $ \o -> do
-        autoconfigureConfigRes <- parseJSON (Object o)
-        autoconfigureChanged   <- o .: "changed"
-        pure AutoconfigureRes { .. }
-
-data ConfigureRes = ConfigureRes
-    { configureResNeedsRestart :: [AppId]
-    , configureResStopped      :: HM.HashMap AppId (AppId, DependencyError) -- TODO: Consider making this nested hashmaps
-    }
-    deriving Eq
-instance FromJSON ConfigureRes where
-    parseJSON = withObject "AppMgr ConfigureRes" $ \o -> do
-        configureResNeedsRestart <- o .: "needs-restart"
-        configureResStopped'     <- o .: "stopped"
-        configureResStopped      <- for
-            configureResStopped'
-            \v -> do
-                depId    <- v .: "dependency"
-                depError <- v .: "error"
-                pure (depId, depError)
-        pure ConfigureRes { .. }
-
-newtype BreakageMap = BreakageMap { unBreakageMap :: HM.HashMap AppId (AppId, DependencyError) }
-instance FromJSON BreakageMap where
-    parseJSON = withObject "Breakage Map" $ \o -> do
-        fmap (BreakageMap . HM.fromList) $ for (HM.toList o) $ \(k, v) -> do
-            case v of
-                Object v' -> do
-                    depId    <- v' .: "dependency"
-                    depError <- v' .: "error"
-                    pure (AppId k, (depId, depError))
-                otherwise -> fail $ "Expected Breakage Object, got" <> show otherwise
-
-data AppMgr (m :: Type -> Type) k where
-    -- Backup ::_
-    CheckDependencies ::LocalOnly -> AppId -> Maybe VersionRange -> AppMgr m (HM.HashMap AppId DependencyInfo)
-    Configure ::DryRun -> AppId -> Maybe Value -> AppMgr m ConfigureRes
-    Autoconfigure ::DryRun -> AppId -> AppId -> AppMgr m AutoconfigureRes
-    -- Disks ::_
-    Info ::Sing (flags :: Either OnlyInfoFlag [IncludeInfoFlag]) -> AppId -> AppMgr m (Maybe (InfoRes flags))
-    InfoRaw ::OnlyInfoFlag -> AppId -> AppMgr m (Maybe Text)
-    -- Inspect ::_
-    Install ::NoCache -> AppId -> Maybe VersionRange -> AppMgr m ()
-    Instructions ::AppId -> AppMgr m (Maybe Text)
-    List ::Sing ('Right (flags :: [IncludeInfoFlag])) -> AppMgr m (HM.HashMap AppId (InfoRes ('Right flags)))
-    -- Logs ::_
-    -- Notifications ::_
-    -- Pack ::_
-    Remove ::Either DryRun Purge -> AppId -> AppMgr m BreakageMap
-    Restart ::AppId -> AppMgr m ()
-    -- SelfUpdate ::_
-    -- Semver ::_
-    Start ::AppId -> AppMgr m ()
-    Stop ::DryRun -> AppId -> AppMgr m BreakageMap
-    -- Tor ::_
-    Update ::DryRun -> AppId -> Maybe VersionRange -> AppMgr m BreakageMap
-    -- Verify ::_
-    LanEnable ::AppMgr m ()
-    Action ::AppId -> Text -> AppMgr m (HM.HashMap Text Value)
-makeSmartConstructors ''AppMgr
-
-newtype AppMgrCliC m a = AppMgrCliC { runAppMgrCliC :: m a }
-    deriving newtype (Functor, Applicative, Monad, MonadIO)
-instance MonadTrans AppMgrCliC where
-    lift = AppMgrCliC
-instance MonadResource m => MonadResource (AppMgrCliC m) where
-    liftResourceT = lift . liftResourceT
-instance MonadBase IO m => MonadBase IO (AppMgrCliC m) where
-    liftBase = AppMgrCliC . liftBase
-instance MonadTransControl AppMgrCliC where
-    type StT AppMgrCliC a = a
-    liftWith f = AppMgrCliC $ f $ runAppMgrCliC
-    restoreT = AppMgrCliC
-instance MonadBaseControl IO m => MonadBaseControl IO (AppMgrCliC m) where
-    type StM (AppMgrCliC m) a = StM m a
-    liftBaseWith = defaultLiftBaseWith
-    restoreM     = defaultRestoreM
-
-instance (Has (Error S9Error) sig m, Algebra sig m, MonadIO m) => Algebra (AppMgr :+: sig) (AppMgrCliC m) where
-    alg hdl sig ctx = case sig of
-        (L (CheckDependencies (LocalOnly b) appId version)) -> do
-            let local = if b then ("--local-only" :) else id
-                args  = "check-dependencies" : local [versionSpec version (show appId), "--json"]
-            (ec, out) <- readProcessInheritStderr "appmgr" args ""
-            res       <- case ec of
-                ExitSuccess -> case eitherDecodeStrict out of
-                    Left  e -> throwError $ AppMgrParseE (toS $ String.unwords args) (decodeUtf8 out) e
-                    Right x -> pure x
-                ExitFailure 6 -> throwError $ NotFoundE "appId@version" (versionSpec version (show appId))
-                ExitFailure n -> throwError $ AppMgrE "check-dependencies" n
-            pure $ ctx $> res
-        (L (Configure (DryRun b) appId cfg)) -> do
-            let dryrun = if b then ("--dry-run" :) else id
-            let input = case cfg of
-                    Nothing -> ""
-                    Just x  -> LBS.toStrict $ encode x
-            let args = "configure" : dryrun [show appId, "--json", "--stdin"]
-            (ec, out, e) <- readProcessWithExitCode' "appmgr" args input
-            res          <- case ec of
-                ExitSuccess -> case eitherDecodeStrict out of
-                    Left  e -> throwError $ AppMgrParseE (toS $ String.unwords args) (decodeUtf8 out) e
-                    Right x -> pure x
-                ExitFailure 4 -> throwError $ (AppMgrInvalidConfigE . decodeUtf8) e -- doesn't match spec
-                ExitFailure 5 -> throwError $ (AppMgrInvalidConfigE . decodeUtf8) e -- doesn't match rules
-                ExitFailure n -> throwError $ AppMgrE "configure" n
-            pure $ ctx $> res
-        (L (Autoconfigure (DryRun dry) dependent dependency)) -> do
-            let flags = (if dry then ("--dry-run" :) else id) . ("--json" :)
-            let args  = "autoconfigure-dependency" : flags [show dependent, show dependency]
-            (ec, out) <- readProcessInheritStderr "appmgr" args ""
-            res       <- case ec of
-                ExitSuccess -> case eitherDecodeStrict out of
-                    Left  e -> throwError $ AppMgrParseE (toS $ String.unwords args) (decodeUtf8 out) e
-                    Right a -> pure a
-                ExitFailure n -> throwError $ AppMgrE "autoconfigure-dependency" n
-            pure $ ctx $> res
-        (L (Info fs appId)) -> do
-            let args = case fromSing fs of
-                    Left  o  -> ["info", genExclusiveFlag o, show appId, "--json"]
-                    Right ls -> "info" : ((genInclusiveFlag <$> ls) <> [show appId, "--json"])
-            (ec, out) <- readProcessInheritStderr "appmgr" args ""
-            res       <- case ec of
-                ExitSuccess -> case withSingI fs $ eitherDecodeStrict out of
-                    Left  e -> throwError $ AppMgrParseE (show args) (decodeUtf8 out) e
-                    Right x -> pure $ Just x
-                ExitFailure 6 -> pure Nothing
-                ExitFailure n -> throwError $ AppMgrE "info" n
-            pure $ ctx $> res
-        (L (InfoRaw f appId)) -> do
-            let args = ["info", genExclusiveFlag f, show appId, "--json"]
-            (ec, out) <- readProcessInheritStderr "appmgr" args ""
-            res       <- case ec of
-                ExitSuccess   -> pure (Just $ decodeUtf8 out)
-                ExitFailure 6 -> pure Nothing
-                ExitFailure n -> throwError $ AppMgrE "info (raw)" n
-            pure $ ctx $> res
-        (L (Install (NoCache b) appId version)) -> do
-            let nocache = if b then ("--no-cache" :) else id
-            let versionSpec :: (IsString a, Semigroup a, ConvertText String a) => a -> a
-                versionSpec = case version of
-                    Nothing -> id
-                    Just x  -> (<> [i|@#{x}|])
-            let args = "install" : nocache [versionSpec (show appId)]
-            (ec, _) <- readProcessInheritStderr "appmgr" args ""
-            case ec of
-                ExitSuccess   -> pure ctx
-                ExitFailure 6 -> throwError $ NotFoundE "appId" (show appId)
-                ExitFailure n -> throwError $ AppMgrE "install" n
-        (L (Instructions appId)) -> do
-            (ec, out) <- readProcessInheritStderr "appmgr" ["instructions", show appId] ""
-            case ec of
-                ExitSuccess   -> pure $ ctx $> Just (decodeUtf8 out)
-                ExitFailure 6 -> pure $ ctx $> Nothing
-                ExitFailure n -> throwError $ AppMgrE "instructions" n
-        (L (List (SRight flags))) -> do
-            let renderedFlags = (genInclusiveFlag <$> fromSing flags) <> ["--json"]
-            let args          = "list" : renderedFlags
-            (ec, out) <- readProcessInheritStderr "appmgr" args ""
-            res       <- case ec of
-                ExitSuccess -> case withSingI flags $ eitherDecodeStrict out of
-                    Left  e -> throwError $ AppMgrParseE (toS $ String.unwords args) (decodeUtf8 out) e
-                    Right x -> pure x
-                ExitFailure n -> throwError $ AppMgrE "list" n
-            pure $ ctx $> res
-        (L (Remove dryorpurge appId)) -> do
-            let args = "remove" : case dryorpurge of
-                    Left  (DryRun True) -> ["--dry-run", show appId, "--json"]
-                    Right (Purge  True) -> ["--purge", show appId, "--json"]
-                    _                   -> [show appId]
-            (ec, out) <- readProcessInheritStderr "appmgr" args ""
-            res       <- case ec of
-                ExitSuccess -> case eitherDecodeStrict out of
-                    Left  e -> throwError $ AppMgrParseE (toS $ String.unwords args) (decodeUtf8 out) e
-                    Right x -> pure x
-                ExitFailure 6 -> throwError $ NotFoundE "appId" (show appId)
-                ExitFailure n -> throwError $ AppMgrE (toS $ String.unwords args) n
-            pure $ ctx $> res
-        (L (Restart appId)) -> do
-            (ec, _) <- readProcessInheritStderr "appmgr" ["restart", show appId] ""
-            case ec of
-                ExitSuccess   -> pure ctx
-                ExitFailure 6 -> throwError $ NotFoundE "appId" (show appId)
-                ExitFailure n -> throwError $ AppMgrE "restart" n
-        (L (Start appId)) -> do
-            (ec, _) <- readProcessInheritStderr "appmgr" ["start", show appId] ""
-            case ec of
-                ExitSuccess   -> pure ctx
-                ExitFailure 6 -> throwError $ NotFoundE "appId" (show appId)
-                ExitFailure n -> throwError $ AppMgrE "start" n
-        (L (Stop (DryRun dry) appId)) -> do
-            let args = "stop" : (if dry then ("--dry-run" :) else id) [show appId, "--json"]
-            (ec, out) <- readProcessInheritStderr "appmgr" args ""
-            case ec of
-                ExitSuccess -> case eitherDecodeStrict out of
-                    Left  e -> throwError $ AppMgrParseE (toS $ String.unwords args) (decodeUtf8 out) e
-                    Right x -> pure $ ctx $> x
-                ExitFailure 6 -> throwError $ NotFoundE "appId" (show appId)
-                ExitFailure n -> throwError $ AppMgrE (toS $ String.unwords args) n
-        (L (Update (DryRun dry) appId version)) -> do
-            let args = "update" : (if dry then ("--dry-run" :) else id) [versionSpec version (show appId), "--json"]
-            (ec, out) <- readProcessInheritStderr "appmgr" args ""
-            case ec of
-                ExitSuccess ->
-                    let output = if not dry then fromMaybe "" $ lastMay (C8.lines out) else out
-                    in  case eitherDecodeStrict output of
-                            Left  e -> throwError $ AppMgrParseE (toS $ String.unwords args) (decodeUtf8 out) e
-                            Right x -> pure $ ctx $> x
-                ExitFailure 6 ->
-                    throwError $ NotFoundE "appId@version" ([i|#{appId}#{maybe "" (('@':) . show) version}|])
-                ExitFailure n -> throwError $ AppMgrE (toS $ String.unwords args) n
-        (L LanEnable            ) -> liftIO $ callProcess "appmgr" ["lan", "enable"] $> ctx
-        (L (Action appId action)) -> do
-            let args = ["actions", show appId, toS action]
-            (ec, out) <- readProcessInheritStderr "appmgr" args ""
-            case ec of
-                ExitSuccess -> case eitherDecodeStrict out of
-                    Left  e -> throwError $ AppMgrParseE (toS $ String.unwords args) (decodeUtf8 out) e
-                    Right x -> pure $ ctx $> x
-                ExitFailure 6 -> throwError $ NotFoundE "appId" (show appId)
-                ExitFailure n -> throwError $ AppMgrE (toS $ String.unwords args) n
-        R other -> AppMgrCliC $ alg (runAppMgrCliC . hdl) other ctx
-        where
-            versionSpec :: (IsString a, Semigroup a, ConvertText String a) => Maybe VersionRange -> a -> a
-            versionSpec v = case v of
-                Nothing -> id
-                Just x  -> (<> [i|@#{x}|])
-    {-# INLINE alg #-}
-
-genInclusiveFlag :: IncludeInfoFlag -> String
-genInclusiveFlag = \case
-    IncludeConfig       -> "-c"
-    IncludeDependencies -> "-d"
-    IncludeManifest     -> "-m"
-    IncludeStatus       -> "-s"
-
-genExclusiveFlag :: OnlyInfoFlag -> String
-genExclusiveFlag = \case
-    OnlyConfig       -> "-C"
-    OnlyDependencies -> "-D"
-    OnlyManifest     -> "-M"
-    OnlyStatus       -> "-S"
-
-readProcessInheritStderr :: MonadIO m => String -> [String] -> ByteString -> m (ExitCode, ByteString)
-readProcessInheritStderr a b c = liftIO $ do
-    let pc =
-            setStdin (byteStringInput $ LBS.fromStrict c)
-                $ setStderr inherit
-                $ setEnvInherit
-                $ setStdout byteStringOutput
-                $ (System.Process.Typed.proc a b)
-    withProcessWait pc
-        $ \process -> atomically $ liftA2 (,) (waitExitCodeSTM process) (fmap LBS.toStrict $ getStdout process)
-
-readProcessWithExitCode' :: MonadIO m => String -> [String] -> ByteString -> m (ExitCode, ByteString, ByteString)
-readProcessWithExitCode' a b c = liftIO $ do
-    let pc =
-            setStdin (byteStringInput $ LBS.fromStrict c)
-                $ setStderr byteStringOutput
-                $ setEnvInherit
-                $ setStdout byteStringOutput
-                $ (System.Process.Typed.proc a b)
-    withProcessWait pc $ \process -> atomically $ liftA3 (,,)
-                                                         (waitExitCodeSTM process)
-                                                         (fmap LBS.toStrict $ getStdout process)
-                                                         (fmap LBS.toStrict $ getStderr process)

agent/src/Lib/Algebra/Domain/AppMgr/TH.hs

@@ -1,43 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-module Lib.Algebra.Domain.AppMgr.TH where
-
-import           Startlude
-
-import           Data.Singletons
-import           Data.String
-import           Language.Haskell.TH.Syntax
-import           Language.Haskell.TH.Quote      ( QuasiQuoter(..) )
-
-import           Lib.Algebra.Domain.AppMgr.Types
-
-flags :: QuasiQuoter
-flags = QuasiQuoter
-    { quoteType = \s ->
-        let
-            w = Data.String.words s
-            additive []       = Just []
-            additive (f : fs) = case f of
-                "-s" -> ('IncludeStatus :) <$> additive fs
-                "-c" -> ('IncludeConfig :) <$> additive fs
-                "-d" -> ('IncludeDependencies :) <$> additive fs
-                "-m" -> ('IncludeManifest :) <$> additive fs
-                _    -> Nothing
-            exclusive [f] = case f of
-                "-S" -> Just 'OnlyStatus
-                "-C" -> Just 'OnlyConfig
-                "-D" -> Just 'OnlyDependencies
-                "-M" -> Just 'OnlyManifest
-                _    -> Nothing
-            exclusive _ = Nothing
-            typ = case eitherA (exclusive w) (additive w) of
-                Nothing         -> panic $ "Invalid Flags: '" <> toS s <> "'"
-                Just (Left  o ) -> pure $ AppT (PromotedT 'Left) (PromotedT $ o)
-                Just (Right ls) -> pure $ AppT
-                    (PromotedT 'Right)
-                    (foldr (\f fs -> AppT (AppT PromotedConsT . PromotedT $ f) fs) PromotedNilT ls)
-        in
-            typ
-    , quoteExp  = \s -> AppTypeE (VarE 'sing) <$> quoteType flags s
-    , quotePat  = panic "appmgr 'flags' cannot be used in patterns"
-    , quoteDec  = panic "appmgr 'flags' cannot be used in declarations"
-    }

agent/src/Lib/Algebra/Domain/AppMgr/Types.hs

@@ -1,29 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE UndecidableInstances #-}
-module Lib.Algebra.Domain.AppMgr.Types where
-
-import           Startlude
-
-import           Data.Singletons.TH
-
-newtype LocalOnly = LocalOnly { unLocalOnly :: Bool }
-newtype NoCache = NoCache { unNoCache :: Bool }
-newtype Purge = Purge { unPurge :: Bool }
-newtype DryRun = DryRun { unDryRun :: Bool }
-
-$(singletons [d|
-    data IncludeInfoFlag
-        = IncludeConfig
-        | IncludeDependencies
-        | IncludeManifest
-        | IncludeStatus deriving (Eq, Show) |])
-
-$(singletons [d|
-    data OnlyInfoFlag
-        = OnlyConfig
-        | OnlyDependencies
-        | OnlyManifest
-        | OnlyStatus deriving (Eq, Show) |])
-

agent/src/Lib/Algebra/State/RegistryUrl.hs

@@ -1,84 +0,0 @@
-{-# LANGUAGE UndecidableInstances #-}
-module Lib.Algebra.State.RegistryUrl where
-
-import           Startlude               hiding ( State
-                                                , get
-                                                , put
-                                                )
-
-import           Control.Algebra
-import           Control.Effect.State
-import           Control.Monad.Catch
-import           Control.Monad.Trans.Class
-import           Control.Monad.Trans.Resource
-import qualified Data.Text                     as T
-
-import           Lib.SystemPaths
-import           Lib.Types.Url
-import           Control.Monad.Trans.Control
-import           Control.Monad.Base
-
-data RegistryUrl (m :: Type -> Type) k where
-    GetRegistryUrl ::RegistryUrl m (Maybe Url)
-    PutRegistryUrl ::Url -> RegistryUrl m ()
-
-getRegistryUrl :: Has RegistryUrl sig m => m (Maybe Url)
-getRegistryUrl = send GetRegistryUrl
-
-putRegistryUrl :: Has RegistryUrl sig m => Url -> m ()
-putRegistryUrl = send . PutRegistryUrl
-
-
-newtype RegistryUrlIOC m a = RegistryUrlIOC { runRegistryUrlIOC :: m a }
-    deriving newtype (Functor, Applicative, Monad, MonadIO)
-
-instance MonadTrans RegistryUrlIOC where
-    lift = RegistryUrlIOC
-
-instance MonadThrow m => MonadThrow (RegistryUrlIOC m) where
-    throwM = lift . throwM
-
-instance MonadResource m => MonadResource (RegistryUrlIOC m) where
-    liftResourceT = lift . liftResourceT
-
-instance MonadTransControl RegistryUrlIOC where
-    type StT RegistryUrlIOC a = a
-    liftWith f = RegistryUrlIOC $ f $ runRegistryUrlIOC
-    restoreT = RegistryUrlIOC
-instance MonadBase IO m => MonadBase IO (RegistryUrlIOC m) where
-    liftBase = RegistryUrlIOC . liftBase
-instance MonadBaseControl IO m => MonadBaseControl IO (RegistryUrlIOC m) where
-    type StM (RegistryUrlIOC m) a = StM m a
-    liftBaseWith = defaultLiftBaseWith
-    restoreM     = defaultRestoreM
-
--- the semantics of this are currently as follows, url fetches will fail with an empty value if the path does not exist
--- as well as if the url in the file desired does not parse as a url
-instance (MonadIO m, Algebra sig m, HasFilesystemBase sig m) => Algebra (RegistryUrl :+: sig) (RegistryUrlIOC m) where
-    alg hdl sig ctx = case sig of
-        L GetRegistryUrl -> do
-            result <- readSystemPath altRegistryUrlPath
-            case result of
-                Nothing -> pure $ ctx $> Nothing
-                Just raw ->
-                    let stripped = T.strip raw
-                    in  case parseUrl stripped of
-                            Left _ -> do
-                                putStrLn @Text $ "Could not parse alternate registry url: " <> stripped
-                                pure $ ctx $> Nothing
-                            Right url -> pure $ ctx $> (Just url)
-        L (PutRegistryUrl url) -> do
-            writeSystemPath altRegistryUrlPath (show url)
-            pure ctx
-        R other -> RegistryUrlIOC $ alg (runRegistryUrlIOC . hdl) other ctx
-    {-# INLINE alg #-}
-
-
-newtype RegistryUrlStateC m a = RegistryUrlStateC { runRegistryUrlStateC :: m a }
-    deriving newtype (Functor, Applicative, Monad, MonadIO)
-instance (Monad m, Has (State (Maybe Url)) sig m) => Algebra (RegistryUrl :+: sig) (RegistryUrlStateC m) where
-    alg hdl sig ctx = case sig of
-        L GetRegistryUrl       -> (ctx $>) <$> get
-        L (PutRegistryUrl url) -> (ctx $>) <$> put (Just url)
-        R other                -> RegistryUrlStateC $ alg (runRegistryUrlStateC . hdl) other ctx
-

agent/src/Lib/Avahi.hs

@@ -1,68 +0,0 @@
-{-# LANGUAGE QuasiQuotes      #-}
-{-# LANGUAGE TypeApplications #-}
-module Lib.Avahi where
-
-import           Startlude               hiding ( (<.>) )
-
-import           Data.String.Interpolate.IsString
-import qualified Data.Text                     as T
-import           System.Directory
-
-import           Lib.Error
-import           Lib.SystemCtl
-import           Lib.SystemPaths
-import           Settings
-
-avahiConf :: Text -> Text
-avahiConf hostname = T.drop 1 $ [i|
-[server]
-host-name=#{hostname}
-domain-name=local
-use-ipv4=yes
-use-ipv6=no
-allow-interfaces=wlan0,eth0
-ratelimit-interval-usec=100000
-ratelimit-burst=1000
-
-[wide-area]
-enable-wide-area=yes
-
-[publish]
-
-[reflector]
-
-[rlimits]
-|]
-
-data WildcardReplacement =
-      WildcardsEnabled
-    | WildcardsDisabled
-    deriving (Eq, Show)
-
-serviceConfig :: (WildcardReplacement, Text) -> Text -> Word16 -> Text
-serviceConfig (wildcards, name) protocol port = T.drop 1 $ [i|
-<?xml version="1.0" standalone='no'?><!--*-nxml-*-->
-<!DOCTYPE service-group SYSTEM "avahi-service.dtd">
-<service-group>
-    <name replace-wildcards=#{show $ bool ("no" :: Text) "yes" (wildcards == WildcardsEnabled) :: Text}>#{name}</name>
-    <service protocol="ipv4">
-        <type>#{protocol}</type>
-        <port>#{port}</port>
-    </service>
-</service-group>|]
-
-createService :: (MonadReader AppSettings m, MonadIO m) => Text -> (WildcardReplacement, Text) -> Text -> Word16 -> m ()
-createService title params proto port = do
-    base <- asks appFilesystemBase
-    liftIO $ writeFile (toS $ avahiServicePath title `relativeTo` base) $ serviceConfig params proto port
-
-createDaemonConf :: Text -> IO ()
-createDaemonConf = writeFile "/etc/avahi/avahi-daemon.conf" . avahiConf
-
-listServices :: IO [FilePath]
-listServices = listDirectory "/etc/avahi/services"
-
-reload :: IO ()
-reload = do
-    ec <- systemCtl RestartService "avahi-daemon"
-    unless (ec == ExitSuccess) $ throwIO . AvahiE $ "systemctl restart avahi-daemon" <> show ec

agent/src/Lib/Background.hs

@@ -1,46 +0,0 @@
-module Lib.Background where
-
-import           Startlude               hiding ( mapMaybe )
-
-import           Data.HashMap.Strict
-import           Data.Singletons
-import           Data.Singletons.Decide
-import           Exinst
-
-import           Lib.Types.Core
-import           Lib.Types.ServerApp
-
-type JobMetadata :: AppTmpStatus -> Type
-data JobMetadata a where
-    Install ::StoreApp -> StoreAppVersionInfo -> JobMetadata 'Installing
-    Backup ::JobMetadata 'CreatingBackup
-    Restore ::JobMetadata 'RestoringBackup
-    StopApp ::JobMetadata 'StoppingT
-    RestartApp ::JobMetadata 'RestartingT
-
-jobType :: JobMetadata a -> SAppTmpStatus a
-jobType = \case
-    Install _ _ -> SInstalling
-    Backup      -> SCreatingBackup
-    Restore     -> SRestoringBackup
-    StopApp     -> SStoppingT
-    RestartApp  -> SRestartingT
-
-newtype JobCache = JobCache { unJobCache :: HashMap AppId (Some1 JobMetadata, ThreadId) }
-
-inspect :: SAppTmpStatus a -> JobCache -> HashMap AppId (JobMetadata a, ThreadId)
-inspect stat (JobCache cache) = flip mapMaybe cache $ \(Some1 sa jm, tid) -> case stat %~ sa of
-    Proved    Refl -> Just (jm, tid)
-    Disproved _    -> Nothing
-
-statuses :: JobCache -> HashMap AppId AppTmpStatus
-statuses (JobCache cache) = some1SingRep . fst <$> cache
-
-installInfo :: JobMetadata 'Installing -> (StoreApp, StoreAppVersionInfo)
-installInfo (Install a b) = (a, b)
-
-insertJob :: AppId -> JobMetadata a -> ThreadId -> JobCache -> JobCache
-insertJob appId jm tid = JobCache . insert appId (withSingI (jobType jm) (some1 jm), tid) . unJobCache
-
-deleteJob :: AppId -> JobCache -> JobCache
-deleteJob appId = JobCache . delete appId . unJobCache

agent/src/Lib/ClientManifest.hs

@@ -1,297 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TupleSections #-}
-module Lib.ClientManifest where
-
-import           Startlude               hiding ( takeWhile
-                                                , toList
-                                                )
-import qualified Protolude.Base                as P
-
-import           Control.Error.Util
-import           Control.Monad.Fail
-import           Data.Aeson
-import           Data.Attoparsec.Text
-import           Data.HashMap.Strict
-import qualified Data.Map.Strict               as Map
-                                                ( toList )
-import           Data.Singletons.TypeLits
-import           Data.String.Interpolate.IsString
-import qualified Data.Text                     as T
-import qualified Data.Yaml                     as Yaml
-import           Exinst
-import           Network.Mime
-import           Numeric.Natural
-import           Streaming.Prelude             as Stream
-                                         hiding ( show
-                                                , for
-                                                , toList
-                                                , cons
-                                                )
-import           System.IO                      ( hClose )
-
-import           Lib.Error
-import           Lib.SystemPaths
-import           Lib.Types.NetAddress
-import           Lib.Types.Core
-import           Lib.Types.Emver
-
-data ClientManifest (n :: Nat) where
-    V0 ::ClientManifestV0 -> ClientManifest 0
-
-deriving instance Show (ClientManifest a)
-
-instance Dict1 Show ClientManifest where
-    dict1 sn = case sn of
-        SNat -> Dict
-
-data ClientManifestV0 = ClientManifestV0
-    { clientManifestV0AppId       :: AppId
-    , clientManifestV0AppVersion  :: Version
-    , clientManifestV0Main        :: SystemPath
-    , clientManifestV0UriRewrites :: HashMap UriPattern LanExp
-    , clientManifestV0ErrorFiles  :: HashMap Int FilePath
-    , clientManifestV0MimeRules   :: MimeMap
-    , clientManifestV0MimeDefault :: MimeType
-    }
-    deriving Show
-
-data UriPattern = MatchExact Text | MatchPrefix Text
-    deriving (Eq, Show, Generic, Hashable)
-newtype LanExp = LanExp { unLanExp :: (AppId, LanIp -> Text) }
-instance Show LanExp where
-    show (LanExp (AppId appId, f)) = toS . f . LanIp $ "{{" <> appId <> "}}"
-
-parseUriPattern :: Parser UriPattern
-parseUriPattern = do
-    cons <- char '=' *> pure MatchExact <|> pure MatchPrefix
-    cons . toS <$> takeWhile1 (not . isSpace)
-
-parseUriRewrite :: Parser (UriPattern, LanExp)
-parseUriRewrite = do
-    pat <- parseUriPattern
-    skipSpace
-    void $ char '-' *> char '>'
-    skipSpace
-    tgt <- parseUriTarget
-    pure (pat, tgt)
-
-parseUriTarget :: Parser LanExp
-parseUriTarget = do
-    proto  <- (string "https" <|> string "http")
-    opener <- string "://" <* string "{{"
-    host   <- takeWhile1 (not . (== '}'))
-    closer <- string "}}" *> string ":"
-    port   <- decimal @Word16
-    path   <- takeWhile1 (not . isSpace)
-    pure . LanExp $ (AppId host, \ip -> proto <> opener <> unLanIp ip <> closer <> show port <> path)
-
-instance FromJSON (Some1 ClientManifest) where
-    parseJSON = withObject "Client Manifest" $ \o -> do
-        v <- o .: "manifest-version"
-        case (v :: Natural) of
-            0 -> some1 . V0 <$> parseJSON (Object o)
-            _ -> fail $ "Unsupported Manifest Version: " <> show v
-
-instance FromJSON ClientManifestV0 where
-    parseJSON = withObject "Client Manifest V0" $ \o -> do
-        clientManifestV0AppId       <- o .: "app-id"
-        clientManifestV0AppVersion  <- o .: "app-version"
-        clientManifestV0Main        <- relBase <$> o .: "main-is"
-        clientManifestV0UriRewrites <- fmap fromList $ o .: "uri-rewrites" >>= \rewrites -> do
-            for (fmap (parseOnly parseUriRewrite) rewrites) $ \case
-                Right r -> pure r
-                Left  e -> fail $ "Invalid Rewrite Rule: " <> e
-        clientManifestV0ErrorFiles  <- fromMaybe mempty <$> o .: "error-pages"
-        clientManifestV0MimeRules   <- encodeUtf8 <<$>> o .: "mime-types"
-        clientManifestV0MimeDefault <- encodeUtf8 <$> o .: "mime-default"
-        pure ClientManifestV0 { .. }
-
-testClientManifest :: ByteString
-testClientManifest = [i|
-manifest-version: 0
-app-id: start9-ambassador
-app-version: 0.2.0
-main-is: /index.html
-uri-rewrites:
-    - =/api -> http://{{start9-ambassador}}:5959/authenticate
-    - /api -> http://{{start9-ambassador}}:5959/
-error-pages:
-    404: /err404.html
-mime-types:
-    bin: application/octet-stream
-    json: application/json
-mime-default: text/plain
-|]
-
-data NginxSiteConf = NginxSiteConf
-    { nginxSiteConfAppId        :: AppId
-    , nginxSiteConfAppVersion   :: Version
-    , nginxSiteConfRoot         :: SystemPath
-    , nginxSiteConfListen       :: Word16
-    , nginxSiteConfServerName   :: [Text]
-    , nginxSiteConfLocations    :: [NginxLocation]
-    , nginxSiteConfIndex        :: SystemPath
-    , nginxSiteConfMimeMappings :: HashMap MimeType [Extension]
-    , nginxSiteConfErrorPages   :: HashMap Int SystemPath
-    , nginxSiteConfDefaultMime  :: MimeType
-    , nginxSiteConfSsl          :: Maybe NginxSsl
-    }
-    deriving Show
-
-data NginxLocation = NginxLocation
-    { nginxLocationPattern :: UriPattern
-    , nginxLocationTarget  :: Text
-    }
-    deriving Show
-
-data NginxSsl = NginxSsl
-    { nginxSslKeyPath         :: SystemPath
-    , nginxSslCertPath        :: SystemPath
-    , nginxSslOnlyServerNames :: [Text]
-    }
-    deriving Show
-
-transpileV0ToNginx :: MonadReader (HashMap AppId (TorAddress, LanIp)) m => ClientManifest 0 -> S9ErrT m NginxSiteConf
-transpileV0ToNginx (V0 ClientManifestV0 {..}) = do
-    hm <- ask
-    let nginxSiteConfAppId      = clientManifestV0AppId
-    let nginxSiteConfAppVersion = clientManifestV0AppVersion
-    let nginxSiteConfRoot = "/var/www/html" <> relBase (unAppId clientManifestV0AppId)
-    let nginxSiteConfListen     = 80
-    nginxSiteConfServerName <-
-        pure . unTorAddress . fst <$> lookup clientManifestV0AppId hm ?? (EnvironmentValE clientManifestV0AppId)
-    nginxSiteConfLocations <- for (toList clientManifestV0UriRewrites) $ \(pat, (LanExp (appId, tgt))) -> do
-        lan <- snd <$> lookup appId hm ?? EnvironmentValE appId
-        pure $ NginxLocation pat (tgt lan)
-    let nginxSiteConfIndex      = clientManifestV0Main
-    let nginxSiteConfErrorPages = fmap fromString clientManifestV0ErrorFiles
-    let nginxSiteConfMimeMappings =
-            flip execState Data.HashMap.Strict.empty $ for (Map.toList clientManifestV0MimeRules) $ \(ext, mime) -> do
-                modify (alter (maybe (Just [ext]) (Just . (ext :))) mime)
-    let nginxSiteConfDefaultMime = clientManifestV0MimeDefault
-    let nginxSiteConfSsl         = Nothing
-    pure NginxSiteConf { .. }
-
--- TODO WRONG, this caching disabled for all uri rewrites
--- this hack is ok for ambassador-ui, but does not generalize
--- we might want to deprecate this means of cachine anyway though
--- see: https://developers.google.com/web/ilt/pwa/caching-files-with-service-worker#cache_then_network
-nginxConfGen :: MonadState Int m => NginxSiteConf -> Stream (Of Text) m ()
-nginxConfGen NginxSiteConf {..} = do
-    emit "server {"
-    indent $ do
-        emit $ "root " <> nginxSiteConfRoot `relativeTo` "/" <> ";"
-
-        case nginxSiteConfSsl of
-            Nothing -> emit $ "listen " <> show nginxSiteConfListen <> ";"
-            Just _  -> emit $ "listen " <> show nginxSiteConfListen <> " ssl;"
-
-        emit $ "server_name " <> (T.intercalate " " nginxSiteConfServerName) <> ";"
-
-        case nginxSiteConfSsl of
-            Nothing            -> pure ()
-            Just NginxSsl {..} -> do
-                emit $ "ssl_certificate " <> (nginxSslCertPath `relativeTo` "/") <> ";"
-                emit $ "ssl_certificate_key " <> (nginxSslKeyPath `relativeTo` "/") <> ";"
-
-        for_ nginxSiteConfLocations $ \(NginxLocation pat tgt) -> do
-            case pat of
-                MatchExact  p -> emit $ "location = " <> p <> " {"
-                MatchPrefix p -> emit $ "location " <> p <> " {"
-            indent $ do
-                emit $ "proxy_pass " <> tgt <> ";"
-                emit $ "proxy_set_header Host $host;"
-            emit "}"
-        emit "location = / {"
-        indent $ do
-            emit $ "add_header X-Consulate-App-ID " <> (show nginxSiteConfAppId) <> ";"
-            emit $ "add_header X-Consulate-App-Version " <> (show nginxSiteConfAppVersion) <> ";"
-            emit $ "add_header Cache-Control private;"
-            emit $ "expires 86400;"
-            emit $ "etag on;"
-            emit $ "index " <> nginxSiteConfIndex `relativeTo` "/" <> ";"
-        emit "}"
-        for_ (toList nginxSiteConfErrorPages) $ \(ec, path) -> do
-            emit $ "error_page " <> show ec <> " " <> (path `relativeTo` "/") <> ";"
-            emit $ "location = " <> path `relativeTo` "/" <> " {"
-            indent $ do
-                emit $ "add_header X-Consulate-App-ID " <> (show nginxSiteConfAppId) <> ";"
-                emit $ "add_header X-Consulate-App-Version " <> (show nginxSiteConfAppVersion) <> ";"
-                emit "internal;"
-            emit "}"
-        emit "location / {"
-        indent $ do
-            emit $ "add_header X-Consulate-App-ID " <> (show nginxSiteConfAppId) <> ";"
-            emit $ "add_header X-Consulate-App-Version " <> (show nginxSiteConfAppVersion) <> ";"
-            emit $ "add_header Cache-Control private;"
-            emit $ "expires 86400;"
-            emit $ "etag on;"
-        emit "}"
-        emit "types {"
-        indent $ for_ (toList nginxSiteConfMimeMappings) $ \(typ, exts) -> do
-            emit $ decodeUtf8 typ <> " " <> T.unwords exts <> ";"
-        emit "}"
-        emit $ "default_type " <> decodeUtf8 nginxSiteConfDefaultMime <> ";"
-    emit "}"
-    case nginxSslOnlyServerNames <$> nginxSiteConfSsl of
-        Nothing -> pure ()
-        Just [] -> pure ()
-        Just ls -> do
-            emit "server {"
-            indent $ do
-                emit "listen 80;"
-                emit $ "server_name " <> T.intercalate " " ls <> ";"
-                emit $ "return 301 https://$host$request_uri;"
-            emit "}"
-    where
-        emit :: MonadState Int m => Text -> Stream (Of Text) m ()
-        emit t = get >>= \n -> yield $ T.replicate n "\t" <> t
-        indent :: MonadState Int m => m a -> m a
-        indent m = modify (+ (1 :: Int)) *> m <* modify (subtract (1 :: Int))
-
-data NginxSiteConfOverride = NginxSiteConfOverride
-    { nginxSiteConfOverrideAdditionalServerName :: Text
-    , nginxSiteConfOverrideListen               :: Word16
-    , nginxSiteConfOverrideSsl                  :: Maybe NginxSsl
-    }
-overrideNginx :: NginxSiteConfOverride -> NginxSiteConf -> NginxSiteConf
-overrideNginx NginxSiteConfOverride {..} nginxSiteConf = nginxSiteConf
-    { nginxSiteConfServerName = previousServerNames <> [nginxSiteConfOverrideAdditionalServerName]
-    , nginxSiteConfListen     = nginxSiteConfOverrideListen
-    , nginxSiteConfSsl        = nginxSiteConfOverrideSsl
-    }
-    where previousServerNames = nginxSiteConfServerName nginxSiteConf
-
--- takes if' app-manifest, converts it to an nginx conf, writes it to of'
-transpile :: (MonadReader (HashMap AppId (TorAddress, LanIp)) m, MonadIO m)
-          => Maybe NginxSiteConfOverride
-          -> FilePath
-          -> FilePath
-          -> m Bool
-transpile mOverride if' of' = do
-    oh       <- liftIO $ openFile of' WriteMode
-    hm       <- ask
-    contents <- liftIO $ toS <$> Startlude.readFile if'
-    case Yaml.decodeEither' (encodeUtf8 contents) :: Either Yaml.ParseException (Some1 ClientManifest) of
-        Left e -> do
-            Startlude.print e
-            liftIO $ hClose oh
-            pure False
-        Right (Some1 _ cm) -> case cm of
-            cmv0@(V0 _) -> case runExceptT (fmap overrides $ transpileV0ToNginx cmv0) hm of
-                Left e -> do
-                    Startlude.print e
-                    liftIO $ hClose oh
-                    pure False
-                Right nsc -> do
-                    flip (evalStateT @_ @Int) 0 $ Stream.toHandle oh $ Stream.toHandle stdout $ Stream.copy
-                        (Stream.map toS $ nginxConfGen nsc)
-                    liftIO $ hClose oh
-                    pure True
-    where
-        overrides = case mOverride of
-            Nothing -> id
-            Just o  -> overrideNginx o
-

agent/src/Lib/Crypto.hs

@@ -1,53 +0,0 @@
-{-# LANGUAGE DataKinds          #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-module Lib.Crypto where
-
-import           Startlude
-
-import           Control.Arrow
-import           Crypto.Cipher.AES
-import           Crypto.Cipher.Types
-import           Crypto.Error
-import           Crypto.Hash                   as Hash
-import           Crypto.KDF.PBKDF2
-import           Crypto.MAC.HMAC
-import           Crypto.Random
-import           Data.Maybe
-import           Data.ByteArray.Sized          as BA
-import           Data.ByteString               as BS
-
--- expands given key by pbkdf2
-computeHmac :: Text -> Text -> SizedByteArray 16 ByteString -> Digest SHA256
-computeHmac key message salt = hmacGetDigest $ hmac (pbkdf2 salt' key) (encodeUtf8 message)
-    where salt' = unSizedByteArray salt
-
-mkAesKey :: SizedByteArray 16 ByteString -> Text -> Maybe AES256
-mkAesKey salt = pbkdf2 salt' >>> cipherInit >>> \case
-    CryptoPassed k -> Just k
-    CryptoFailed _ -> Nothing
-    where salt' = unSizedByteArray salt
-
-pbkdf2 :: ByteString -> Text -> ByteString
-pbkdf2 salt key = fastPBKDF2_SHA256 pbkdf2Parameters (encodeUtf8 key) salt
-    where pbkdf2Parameters = Parameters 100000 32 -- 32 is the length in *bytes* of the output key
-
-encryptAes256Ctr :: AES256 -> IV AES256 -> ByteString -> ByteString
-encryptAes256Ctr = ctrCombine
-
-decryptAes256Ctr :: AES256 -> IV AES256 -> ByteString -> ByteString
-decryptAes256Ctr = encryptAes256Ctr
-
-random16 :: MonadIO m => m (SizedByteArray 16 ByteString)
-random16 = randomBytes
-random8 :: MonadIO m => m (SizedByteArray 8 ByteString)
-random8 = randomBytes
-random32 :: MonadIO m => m (SizedByteArray 32 ByteString)
-random32 = randomBytes
-
-randomBytes :: forall m n . (MonadIO m, KnownNat n) => m (SizedByteArray n ByteString)
-randomBytes = liftIO $ fromJust . sizedByteArray <$> getRandomBytes byteCount
-    where
-        casing :: SizedByteArray n ByteString
-        casing    = BA.zero
-        byteCount = BS.length $ unSizedByteArray casing

agent/src/Lib/Database.hs

@@ -1,53 +0,0 @@
-module Lib.Database where
-
-import           Startlude               hiding ( throwIO
-                                                , Reader
-                                                )
-
-import           Control.Effect.Reader.Labelled
-import           Control.Monad.Logger
-import           Database.Persist.Sql
-import           System.Directory
-
-import           Constants
-import           Lib.Migration
-import           Lib.SystemPaths
-import           Lib.Types.Emver
-import           Model
-import           Util.Function
-
-------------------------------------------------------------------------------------------------------------------------
--- Migrations
-------------------------------------------------------------------------------------------------------------------------
-
-data UpMigrationHistory = UpMigrationHistory (Maybe Version) (Maybe Version) -- previous db version, current db version.
-
-type Logger = Loc -> LogSource -> LogLevel -> LogStr -> IO ()
-
-ensureCoherentDbVersion :: (HasFilesystemBase sig m, HasLabelled "sqlDatabase" (Reader Text) sig m, MonadIO m)
-                        => ConnectionPool
-                        -> Logger
-                        -> m UpMigrationHistory
-ensureCoherentDbVersion pool logFunc = do
-    db         <- dbPath
-    mDbVersion <- liftIO $ doesFileExist (toS db) >>= \case
-        True  -> runSqlPool getCurrentDbVersion pool -- get db version if db exists
-        False -> pure Nothing
-
-    liftIO $ case mDbVersion of
-        Nothing        -> initializeDb agentVersion pool logFunc
-        Just dbVersion -> upMigration pool dbVersion agentVersion
-
-initializeDb :: Version -> ConnectionPool -> Logger -> IO UpMigrationHistory
-initializeDb av = runLoggingT .* runSqlPool $ do
-    now <- liftIO getCurrentTime
-    runMigration migrateAll
-    void . insertEntity $ ExecutedMigration now now av av
-    pure $ UpMigrationHistory Nothing (Just agentVersion)
-
-upMigration :: ConnectionPool -> Version -> Version -> IO UpMigrationHistory
-upMigration pool dbVersion currentAgentVersion = if dbVersion < currentAgentVersion
-    then do
-        ioMigrationDbVersion pool dbVersion currentAgentVersion
-        pure $ UpMigrationHistory (Just dbVersion) (Just currentAgentVersion)
-    else pure $ UpMigrationHistory (Just dbVersion) Nothing

agent/src/Lib/Error.hs

@@ -1,289 +0,0 @@
-{-# LANGUAGE QuasiQuotes     #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TemplateHaskell #-}
-
-module Lib.Error where
-
-import           Startlude
-
-import           Control.Carrier.Error.Church
-import           Data.Aeson              hiding ( Error )
-import           Data.String.Interpolate.IsString
-import qualified Data.Yaml                     as Yaml
-import qualified GHC.Show                       ( Show(..) )
-import           Network.HTTP.Types
-import           System.Process
-import           Yesod.Core              hiding ( ErrorResponse )
-
-import           Lib.SystemPaths
-import           Lib.Types.Core
-import           Lib.Types.Emver
-
-
-type S9ErrT m = ExceptT S9Error m
-
-data S9Error =
-      ProductKeyE
-    | RegistrationE
-    | NoCompliantAgentE VersionRange
-    | PersistentE Text
-    | WifiConnectionE
-    | AppMgrParseE Text Text String
-    | AppMgrInvalidConfigE Text
-    | AppMgrE Text Int
-    | EjectE Int
-    | AvahiE Text
-    | MetricE Text
-    | AppMgrVersionE Version VersionRange
-    | RegistryUnreachableE
-    | RegistryParseE Text Text
-    | AppNotInstalledE AppId
-    | AppStateActionIncompatibleE AppId AppStatus AppAction
-    | UpdateSelfE UpdateSelfStep Text
-    | InvalidSshKeyE Text
-    | InvalidSsidE
-    | InvalidPskE
-    | InvalidRequestE Value Text
-    | NotFoundE Text Text
-    | UpdateInProgressE
-    | TemporarilyForbiddenE AppId Text Text
-    | TorServiceTimeoutE
-    | NginxSslE Text
-    | WifiOrphaningE
-    | NoPasswordExistsE
-    | HostsParamsE Text
-    | ParamsE Text
-    | MissingFileE SystemPath
-    | ClientCryptographyE Text
-    | TTLExpirationE Text
-    | ManifestParseE AppId Yaml.ParseException
-    | EnvironmentValE AppId
-    | InternalE Text
-    | BackupE AppId Text
-    | BackupPassInvalidE
-    | OpenSslE Text Int String String
-data UpdateSelfStep =
-      GetLatestCompliantVersion
-    | GetYoungAgentBinary
-    | ShutdownWeb
-    | StartupYoungAgent
-    | PingYoungAgent ProcessHandle
-instance Show S9Error where
-    show = show . toError
-
-instance Exception S9Error
-
-newtype InternalS9Error = InternalS9Error Text deriving (Eq, Show)
-instance Exception InternalS9Error
-
--- | Redact any sensitive data in this function
-toError :: S9Error -> ErrorResponse
-toError = \case
-    ProductKeyE            -> ErrorResponse PRODUCT_KEY_ERROR "The product key is invalid"
-    RegistrationE          -> ErrorResponse REGISTRATION_ERROR "The product already has an owner"
-    NoCompliantAgentE spec -> ErrorResponse AGENT_UPDATE_ERROR [i|No valid agent version for spec #{spec}|]
-    PersistentE       t    -> ErrorResponse DATABASE_ERROR t
-    WifiConnectionE        -> ErrorResponse WIFI_ERROR "Could not connect to wifi"
-    AppMgrInvalidConfigE e -> ErrorResponse APPMGR_CONFIG_ERROR e
-    AppMgrParseE cmd result e ->
-        ErrorResponse APPMGR_PARSE_ERROR [i|"appmgr #{cmd}" yielded an unparseable result:#{result}\nError: #{e}|]
-    AppMgrE cmd code -> ErrorResponse APPMGR_ERROR [i|"appmgr #{cmd}" exited with #{code}|]
-    EjectE code -> ErrorResponse EJECT_ERROR [i|"eject" command exited with #{code}|]
-    AppMgrVersionE av avs ->
-        ErrorResponse APPMGR_ERROR [i|"appmgr version #{av}" fails to satisfy requisite spec #{avs}|]
-    AvahiE  e               -> ErrorResponse AVAHI_ERROR [i|#{e}|]
-    MetricE m               -> ErrorResponse METRICS_ERROR [i|failed to provide metrics: #{m}|]
-    RegistryUnreachableE    -> ErrorResponse REGISTRY_ERROR [i|registry is unreachable|]
-    RegistryParseE path msg -> ErrorResponse REGISTRY_ERROR [i|registry "#{path}" failed to parse: #{msg}|]
-    AppNotInstalledE appId  -> ErrorResponse APP_NOT_INSTALLED [i|#{appId} is not installed|]
-    AppStateActionIncompatibleE appId status action -> ErrorResponse APP_ACTION_FORBIDDEN $ case (status, action) of
-        (AppStatusAppMgr Dead, _) -> [i|#{appId} cannot be #{action}ed because it is dead...contact support?|]
-        (AppStatusAppMgr Removing, _) -> [i|#{appId} cannot be #{action}ed because it is being removed|]
-        (AppStatusAppMgr Running, Start) -> [i|#{appId} is already running|]
-        (AppStatusAppMgr Stopped, Stop) -> [i|#{appId} is already stopped|]
-        (AppStatusAppMgr Restarting, Start) -> [i|#{appId} is already running|]
-        (AppStatusAppMgr Running, Stop) -> [i|Running apps should be stoppable, this is a bug, contact support|]
-        (AppStatusAppMgr Stopped, Start) -> [i|Stopped apps should be startable, this is a bug, contact support|]
-        (AppStatusAppMgr Restarting, Stop) -> [i|Restarting apps should be stoppable, this is a bug, contact support|]
-        (AppStatusAppMgr Paused, _) -> [i|Paused is not an externally visible state, this is a bug, contact support|]
-        (AppStatusTmp NeedsConfig, Start) -> [i|#{appId} cannot be started because it is not configured|]
-        (AppStatusTmp NeedsConfig, Stop) -> [i|#{appId} is already stopped|]
-        (AppStatusTmp BrokenDependencies, Start) -> [i|Cannot start service: Dependency Issue|]
-        (AppStatusTmp _, _) -> [i|Cannot issue control actions to apps in temporary states|]
-    UpdateSelfE step e -> ErrorResponse SELF_UPDATE_ERROR $ case step of
-        GetLatestCompliantVersion -> [i|could not find a compliant version for the specification|]
-        GetYoungAgentBinary       -> [i|could not get young agent binary: #{e}|]
-        ShutdownWeb               -> [i|could not shutdown web: #{e}|]
-        StartupYoungAgent         -> [i|could not startup young agent: #{e}|]
-        PingYoungAgent _          -> [i|could not ping young agent: #{e}|]
-    InvalidSshKeyE key -> ErrorResponse INVALID_SSH_KEY [i|The ssh key "#{key}" is invalid|]
-    InvalidSsidE -> ErrorResponse INVALID_SSID [i|The ssid is invalid. Only ASCII characters allowed.|]
-    InvalidPskE -> ErrorResponse INVALID_SSID [i|The wifi password is invalid. Only ASCII characters allowed.|]
-    InvalidRequestE val reason -> ErrorResponse INVALID_REQUEST [i|The body #{encode val} is invalid: #{reason}|]
-    NotFoundE resource val -> ErrorResponse RESOURCE_NOT_FOUND [i|The #{resource} #{val} was not found|]
-    UpdateInProgressE ->
-        ErrorResponse UPDATE_IN_PROGRESS [i|Your request could not be completed because your server is updating|]
-    TemporarilyForbiddenE appId action st ->
-        ErrorResponse APP_ACTION_FORBIDDEN [i|The #{action} for #{appId} is temporarily forbidden because it is #{st}|]
-    TorServiceTimeoutE ->
-        ErrorResponse INTERNAL_ERROR [i|The MeshOS Tor Service could not be started...contact support|]
-    NginxSslE e    -> ErrorResponse INTERNAL_ERROR [i|MeshOS could not be started with SSL #{e}|]
-    WifiOrphaningE -> ErrorResponse
-        WIFI_ERROR
-        [i|You cannot delete the wifi network you are currently connected to unless on ethernet|]
-    ManifestParseE appId e ->
-        ErrorResponse INTERNAL_ERROR [i|There was an error inspecting the manifest for #{appId}: #{e}|]
-    NoPasswordExistsE         -> ErrorResponse REGISTRATION_ERROR [i|Unauthorized. No password has been registered|]
-    MissingFileE        sp    -> ErrorResponse RESOURCE_NOT_FOUND [i|File not found as #{leaf sp}|]
-    ClientCryptographyE desc  -> ErrorResponse REGISTRATION_ERROR [i|Cryptography failure: #{desc}|]
-    TTLExpirationE      desc  -> ErrorResponse REGISTRATION_ERROR [i|TTL Expiration failure: #{desc}|]
-    EnvironmentValE     appId -> ErrorResponse SYNCHRONIZATION_ERROR [i|Could not read environment values for #{appId}|]
-    HostsParamsE        key   -> ErrorResponse REGISTRATION_ERROR [i|Missing or invalid parameter #{key}|]
-    ParamsE             key   -> ErrorResponse INVALID_REQUEST [i|Missing or invalid parameter #{key}|]
-    InternalE           msg   -> ErrorResponse INTERNAL_ERROR msg
-    BackupE appId reason      -> ErrorResponse BACKUP_ERROR [i|Backup failed for #{appId}: #{reason}|]
-    BackupPassInvalidE        -> ErrorResponse BACKUP_ERROR [i|Password provided for backups is invalid|]
-    OpenSslE cert ec stdout' stderr' ->
-        ErrorResponse OPENSSL_ERROR [i|OPENSSL ERROR: #{cert} - #{show ec <> "\n" <> stdout' <> "\n" <> stderr'}|]
-
-data ErrorCode =
-      PRODUCT_KEY_ERROR
-    | REGISTRATION_ERROR
-    | AGENT_UPDATE_ERROR
-    | DATABASE_ERROR
-    | WIFI_ERROR
-    | APPMGR_CONFIG_ERROR
-    | APPMGR_PARSE_ERROR
-    | APPMGR_ERROR
-    | EJECT_ERROR
-    | AVAHI_ERROR
-    | REGISTRY_ERROR
-    | APP_NOT_INSTALLED
-    | APP_NOT_CONFIGURED
-    | APP_ACTION_FORBIDDEN
-    | SELF_UPDATE_ERROR
-    | INVALID_SSH_KEY
-    | INVALID_SSID
-    | INVALID_PSK
-    | INVALID_REQUEST
-    | INVALID_HEADER
-    | MISSING_HEADER
-    | METRICS_ERROR
-    | RESOURCE_NOT_FOUND
-    | UPDATE_IN_PROGRESS
-    | INTERNAL_ERROR
-    | SYNCHRONIZATION_ERROR
-    | BACKUP_ERROR
-    | OPENSSL_ERROR
-    deriving (Eq, Show)
-instance ToJSON ErrorCode where
-    toJSON = String . show
-
-data ErrorResponse = ErrorResponse
-    { errorCode    :: ErrorCode
-    , errorMessage :: Text
-    }
-    deriving (Eq, Show)
-instance ToJSON ErrorResponse where
-    toJSON ErrorResponse {..} = object ["code" .= errorCode, "message" .= errorMessage]
-instance ToContent ErrorResponse where
-    toContent = toContent . toJSON
-instance ToTypedContent ErrorResponse where
-    toTypedContent = toTypedContent . toJSON
-
-instance ToTypedContent S9Error where
-    toTypedContent = toTypedContent . toJSON . toError
-instance ToContent S9Error where
-    toContent = toContent . toJSON . toError
-
-toStatus :: S9Error -> Status
-toStatus = \case
-    ProductKeyE            -> status401
-    RegistrationE          -> status403
-    NoCompliantAgentE _    -> status404
-    PersistentE       _    -> status500
-    WifiConnectionE        -> status500
-    AppMgrParseE{}         -> status500
-    AppMgrInvalidConfigE _ -> status400
-    AppMgrE        _ _     -> status500
-    EjectE  _              -> status500
-    AppMgrVersionE _ _     -> status500
-    AvahiE  _              -> status500
-    MetricE _              -> status500
-    RegistryUnreachableE   -> status500
-    RegistryParseE _ _     -> status500
-    AppNotInstalledE _     -> status404
-    AppStateActionIncompatibleE _ status action -> case (status, action) of
-        (AppStatusAppMgr Dead       , _    ) -> status500
-        (AppStatusAppMgr Removing   , _    ) -> status403
-        (AppStatusAppMgr Running    , Start) -> status200
-        (AppStatusAppMgr Running    , Stop ) -> status200
-        (AppStatusAppMgr Restarting , Start) -> status200
-        (AppStatusAppMgr Restarting , Stop ) -> status200
-        (AppStatusAppMgr Stopped    , Start) -> status200
-        (AppStatusAppMgr Stopped    , Stop ) -> status200
-        (AppStatusAppMgr Paused     , _    ) -> status403
-        (AppStatusTmp    NeedsConfig, Start) -> status403
-        (AppStatusTmp    NeedsConfig, Stop ) -> status200
-        (AppStatusTmp    _          , _    ) -> status403
-    UpdateSelfE _ _         -> status500
-    InvalidSshKeyE _        -> status400
-    InvalidSsidE            -> status400
-    InvalidPskE             -> status400
-    InvalidRequestE _ _     -> status400
-    NotFoundE       _ _     -> status404
-    UpdateInProgressE       -> status403
-    TemporarilyForbiddenE{} -> status403
-    TorServiceTimeoutE      -> status500
-    NginxSslE _             -> status500
-    WifiOrphaningE          -> status403
-    ManifestParseE _ _      -> status500
-    NoPasswordExistsE       -> status401
-    MissingFileE        _   -> status500
-    ClientCryptographyE _   -> status401
-    TTLExpirationE      _   -> status403
-    EnvironmentValE     _   -> status500
-    HostsParamsE        _   -> status400
-    ParamsE             _   -> status400
-    BackupE _ _             -> status500
-    BackupPassInvalidE      -> status403
-    InternalE _             -> status500
-    OpenSslE{}              -> status500
-
-handleS9ErrC :: (MonadHandler m, MonadLogger m) => ErrorC S9Error m a -> m a
-handleS9ErrC action =
-    let handleIt e = do
-            $logError $ show e
-            toStatus >>= sendResponseStatus $ e
-    in  runErrorC action handleIt pure
-
-handleS9ErrT :: (MonadHandler m, MonadLogger m) => S9ErrT m a -> m a
-handleS9ErrT action = runExceptT action >>= \case
-    Left e -> do
-        $logError $ show e
-        toStatus >>= sendResponseStatus $ e
-    Right a -> pure a
-
-runS9ErrT :: MonadIO m => S9ErrT m a -> m (Either S9Error a)
-runS9ErrT = runExceptT
-
-logS9ErrT :: (MonadIO m, MonadLogger m) => S9ErrT m a -> m (Maybe a)
-logS9ErrT x = runS9ErrT x >>= \case
-    Left e -> do
-        $logError $ show e
-        pure Nothing
-    Right a -> pure $ Just a
-
-handleS9ErrNuclear :: MonadIO m => S9ErrT m a -> m a
-handleS9ErrNuclear action = runExceptT action >>= \case
-    Left  e -> throwIO e
-    Right a -> pure a
-
-orThrowM :: Has (Error e) sig m => m (Maybe a) -> e -> m a
-orThrowM action e = action >>= maybe (throwError e) pure
-{-# INLINE orThrowM #-}
-
-orThrowPure :: Has (Error e) sig m => Maybe a -> e -> m a
-orThrowPure thing e = maybe (throwError e) pure thing
-{-# INLINE orThrowPure #-}
-

agent/src/Lib/External/AppManifest.hs

@@ -1,153 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-module Lib.External.AppManifest where
-
-import           Startlude               hiding ( ask )
-
-import           Control.Effect.Reader.Labelled
-import           Data.Aeson
-import qualified Data.HashMap.Strict           as HM
-import qualified Data.Yaml                     as Yaml
-
-import           Control.Monad.Fail             ( MonadFail(fail) )
-import           Lib.Error
-import           Lib.SystemPaths
-import           Lib.Types.Core
-import           Lib.Types.Emver
-import           Lib.Types.Emver.Orphans        ( )
-
-data ImageType = ImageTypeTar
-    deriving (Eq, Show)
-
-instance FromJSON ImageType where
-    parseJSON = withText "Image Type" $ \case
-        "tar" -> pure ImageTypeTar
-        wat   -> fail $ "Unknown Image Type: " <> toS wat
-
-data OnionVersion = OnionV2 | OnionV3
-    deriving (Eq, Ord, Show)
-
-instance FromJSON OnionVersion where
-    parseJSON = withText "Onion Version" $ \case
-        "v2" -> pure OnionV2
-        "v3" -> pure OnionV3
-        wat  -> fail $ "Unknown Onion Version: " <> toS wat
-
-data AssetMapping = AssetMapping
-    { assetMappingSource    :: FilePath
-    , assetMappingDest      :: FilePath
-    , assetMappingOverwrite :: Bool
-    }
-    deriving (Eq, Show)
-
-instance FromJSON AssetMapping where
-    parseJSON = withObject "Asset Mapping" $ \o -> do
-        assetMappingSource    <- o .: "src"
-        assetMappingDest      <- o .: "dst"
-        assetMappingOverwrite <- o .: "overwrite"
-        pure $ AssetMapping { .. }
-
-data Action = Action
-    { actionId              :: Text
-    , actionName            :: Text
-    , actionDescription     :: Text
-    , actionWarning         :: Maybe Text
-    , actionAllowedStatuses :: [AppContainerStatus]
-    }
-    deriving Show
-instance FromJSON Action where
-    parseJSON = withObject "AppAction" $ \o -> do
-        actionId              <- o .: "id"
-        actionName            <- o .: "name"
-        actionDescription     <- o .: "description"
-        actionWarning         <- o .:? "warning"
-        actionAllowedStatuses <- o .: "allowed-statuses"
-        pure Action { .. }
-instance ToJSON Action where
-    toJSON Action {..} =
-        object
-            $  [ "id" .= actionId
-               , "name" .= actionName
-               , "description" .= actionDescription
-               , "allowedStatuses" .= actionAllowedStatuses
-               ]
-            <> maybeToList (("warning" .=) <$> actionWarning)
-
-
-data AppManifest where
-     AppManifest ::{ appManifestId :: AppId
-                    , appManifestVersion :: Version
-                    , appManifestTitle :: Text
-                    , appManifestDescShort :: Text
-                    , appManifestDescLong :: Text
-                    , appManifestReleaseNotes :: Text
-                    , appManifestPortMapping :: [PortMapEntry]
-                    , appManifestImageType :: ImageType
-                    , appManifestMount :: FilePath
-                    , appManifestAssets :: [AssetMapping]
-                    , appManifestOnionVersion :: OnionVersion
-                    , appManifestDependencies :: HM.HashMap AppId VersionRange
-                    , appManifestUninstallAlert :: Maybe Text
-                    , appManifestRestoreAlert   :: Maybe Text
-                    , appManifestStartAlert :: Maybe Text
-                    , appManifestActions :: [Action]
-                    } -> AppManifest
-deriving instance Show AppManifest
-
-torUiAvailable :: AppManifest -> Bool
-torUiAvailable AppManifest {..} = any (== 80) $ portMapEntryTor <$> appManifestPortMapping
-
-lanUiAvailable :: AppManifest -> Bool
-lanUiAvailable AppManifest {..} = any id $ fmap portMapEntryLan appManifestPortMapping <&> \case
-    Just Standard     -> True
-    Just (Custom 443) -> True
-    Just (Custom 80 ) -> True
-    _                 -> False
-
-instance FromJSON AppManifest where
-    parseJSON = withObject "App Manifest " $ \o -> do
-        appManifestId             <- o .: "id"
-        appManifestVersion        <- o .: "version"
-        appManifestTitle          <- o .: "title"
-        appManifestDescShort      <- o .: "description" >>= (.: "short")
-        appManifestDescLong       <- o .: "description" >>= (.: "long")
-        appManifestReleaseNotes   <- o .: "release-notes"
-        appManifestPortMapping    <- o .: "ports"
-        appManifestImageType      <- o .: "image" >>= (.: "type")
-        appManifestMount          <- o .: "mount"
-        appManifestAssets         <- o .: "assets" >>= traverse parseJSON
-        appManifestOnionVersion   <- o .: "hidden-service-version"
-        appManifestDependencies   <- o .:? "dependencies" .!= HM.empty >>= traverse parseDepInfo
-        appManifestUninstallAlert <- o .:? "uninstall-alert"
-        appManifestRestoreAlert   <- o .:? "restore-alert"
-        appManifestStartAlert     <- o .:? "start-alert"
-        appManifestActions        <- o .: "actions"
-        pure $ AppManifest { .. }
-        where parseDepInfo = withObject "Dep Info" $ (.: "version")
-
-getAppManifest :: (MonadIO m, HasFilesystemBase sig m) => AppId -> S9ErrT m (Maybe AppManifest)
-getAppManifest appId = do
-    base <- ask @"filesystemBase"
-    ExceptT $ first (ManifestParseE appId) <$> liftIO
-        (Yaml.decodeFileEither . toS $ (appMgrAppPath appId <> "manifest.yaml") `relativeTo` base)
-
-data LanConfiguration = Standard | Custom Word16 deriving (Eq, Show)
-instance FromJSON LanConfiguration where
-    parseJSON = liftA2 (<|>) standard custom
-        where
-            standard =
-                withText "Standard Lan" \t -> if t == "standard" then pure Standard else fail "Not Standard Lan Conf"
-            custom = withObject "Custom Lan" $ \o -> do
-                Custom <$> (o .: "custom" >>= (.: "port"))
-data PortMapEntry = PortMapEntry
-    { portMapEntryInternal :: Word16
-    , portMapEntryTor      :: Word16
-    , portMapEntryLan      :: Maybe LanConfiguration
-    }
-    deriving (Eq, Show)
-instance FromJSON PortMapEntry where
-    parseJSON = withObject "Port Map Entry" $ \o -> do
-        portMapEntryInternal <- o .: "internal"
-        portMapEntryTor      <- o .: "tor"
-        portMapEntryLan      <- o .:? "lan"
-        pure PortMapEntry { .. }

agent/src/Lib/External/AppMgr.hs

@@ -1,291 +0,0 @@
-{-# LANGUAGE DataKinds        #-}
-{-# LANGUAGE GADTs            #-}
-{-# LANGUAGE QuasiQuotes      #-}
-{-# LANGUAGE RecordWildCards  #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies     #-}
-
-module Lib.External.AppMgr where
-
-import           Startlude               hiding ( hPutStrLn
-                                                , toS
-                                                )
-
-import           Control.Monad.Fail
-import           Data.Aeson
-import qualified Data.ByteString               as BS
-import qualified Data.ByteString.Lazy          as LBS
-import qualified Data.HashMap.Strict           as HM
-import           Data.String.Interpolate.IsString
-import           Data.Text                      ( unpack )
-import qualified Data.Yaml                     as Yaml
-import           Exinst
-import           Numeric.Natural
-import           System.IO.Error
-import           System.Process
-import           System.Process.Typed    hiding ( createPipe )
-
-import           Lib.Error
-import           Lib.SystemPaths
-import           Lib.Types.Core
-import           Lib.Types.NetAddress
-import           Lib.Types.Emver
-import qualified Data.ByteString.Char8         as B8
-import qualified Data.Attoparsec.Text          as Atto
-
-readProcessWithExitCode' :: MonadIO m => String -> [String] -> ByteString -> m (ExitCode, ByteString, ByteString)
-readProcessWithExitCode' a b c = liftIO $ do
-    let pc =
-            setStdin (byteStringInput $ LBS.fromStrict c)
-                $ setStderr byteStringOutput
-                $ setEnvInherit
-                $ setStdout byteStringOutput
-                $ (System.Process.Typed.proc a b)
-    withProcessWait pc $ \process -> atomically $ liftA3 (,,)
-                                                         (waitExitCodeSTM process)
-                                                         (fmap LBS.toStrict $ getStdout process)
-                                                         (fmap LBS.toStrict $ getStderr process)
-
-readProcessInheritStderr :: MonadIO m => String -> [String] -> ByteString -> m (ExitCode, ByteString)
-readProcessInheritStderr a b c = liftIO $ do
-    let pc =
-            setStdin (byteStringInput $ LBS.fromStrict c)
-                $ setStderr inherit
-                $ setEnvInherit
-                $ setStdout byteStringOutput
-                $ (System.Process.Typed.proc a b)
-    withProcessWait pc
-        $ \process -> atomically $ liftA2 (,) (waitExitCodeSTM process) (fmap LBS.toStrict $ getStdout process)
-
-torRepair :: MonadIO m => m ExitCode
-torRepair = liftIO $ system "appmgr tor repair"
-
-getConfigurationAndSpec :: MonadIO m => AppId -> S9ErrT m Text
-getConfigurationAndSpec appId = fmap decodeUtf8 $ do
-    (ec, out) <- readProcessInheritStderr "appmgr" ["info", show appId, "-C", "--json"] ""
-    case ec of
-        ExitSuccess   -> pure out
-        ExitFailure n -> throwE $ AppMgrE [i|info #{appId} -C \--json|] n
-
-getAppMgrVersion :: MonadIO m => S9ErrT m Version
-getAppMgrVersion = do
-    (code, out) <- liftIO $ readProcessInheritStderr "appmgr" ["semver"] ""
-    case code of
-        ExitSuccess -> case hush $ Atto.parseOnly parseVersion $ decodeUtf8 out of
-            Nothing -> throwE $ AppMgrParseE "semver" "" (B8.unpack out)
-            Just av -> pure av
-        ExitFailure n -> throwE $ AppMgrE "semver" n
-
-installNewAppMgr :: MonadIO m => VersionRange -> S9ErrT m Version
-installNewAppMgr avs = do
-    getAppMgrVersion >>= \case
-        Version (0, 1, 0, _) -> void $ readProcessInheritStderr "appmgr" ["self-update", "=0.1.1"] ""
-        _                    -> pure ()
-    (ec, _) <- readProcessInheritStderr "appmgr" ["self-update", show avs] ""
-    case ec of
-        ExitSuccess   -> getAppMgrVersion
-        ExitFailure n -> throwE $ AppMgrE [i|self-update #{avs}|] n
-
-torShow :: MonadIO m => AppId -> S9ErrT m (Maybe Text)
-torShow appId = do
-    (ec, out) <- liftIO $ readProcessInheritStderr "appmgr" ["tor", "show", show appId] ""
-    case ec of
-        ExitSuccess   -> pure $ Just (decodeUtf8 out)
-        ExitFailure n -> case n of
-            6  -> pure Nothing
-            n' -> throwE $ AppMgrE "tor show" n'
-
-getAppLogs :: MonadIO m => AppId -> m Text
-getAppLogs appId = liftIO $ do
-    (pipeRead, pipeWrite)    <- createPipe
-    (_, _, _, handleProcess) <- createProcess (System.Process.proc "appmgr" ["logs", "--tail", "40", show appId])
-        { std_out = UseHandle pipeWrite
-        , std_err = UseHandle pipeWrite
-        }
-    void $ waitForProcess handleProcess
-    content <- BS.hGetContents pipeRead
-    pure $ decodeUtf8 content
-
-notifications :: MonadIO m => AppId -> S9ErrT m [AppMgrNotif]
-notifications appId = do
-    (ec, bs) <- readProcessInheritStderr "appmgr" ["notifications", show appId, "--json"] ""
-    case ec of
-        ExitSuccess -> case eitherDecodeStrict bs of
-            Left  e -> throwE $ AppMgrParseE "notifications" (decodeUtf8 bs) e
-            Right x -> pure x
-        ExitFailure n -> throwE $ AppMgrE [i|notifications #{appId} \--json|] n
-
-stats :: MonadIO m => AppId -> S9ErrT m Text
-stats appId = fmap decodeUtf8 $ do
-    (ec, out) <- readProcessInheritStderr "appmgr" ["stats", show appId, "--json"] ""
-    case ec of
-        ExitSuccess   -> pure out
-        ExitFailure n -> throwE $ AppMgrE [i|stats #{appId} \--json|] n
-
-torReload :: MonadIO m => S9ErrT m ()
-torReload = do
-    (ec, _) <- readProcessInheritStderr "appmgr" ["tor", "reload"] ""
-    case ec of
-        ExitSuccess   -> pure ()
-        ExitFailure n -> throwE $ AppMgrE "tor reload" n
-
-diskShow :: MonadIO m => S9ErrT m [DiskInfo]
-diskShow = do
-    (ec, bs) <- readProcessInheritStderr "appmgr" ["disks", "show", "--json"] ""
-    case ec of
-        ExitSuccess -> case eitherDecodeStrict bs of
-            Left  e -> throwE $ AppMgrParseE "disk info" (decodeUtf8 bs) e
-            Right x -> pure x
-        ExitFailure n -> throwE $ AppMgrE "disk show" n
-
-backupCreate :: MonadIO m => Maybe Text -> AppId -> FilePath -> S9ErrT m ()
-backupCreate password appId disk = do
-    let args = case password of
-            Nothing -> ["backup", "create", "-p", "\"\"", show appId, disk]
-            Just p' -> ["backup", "create", "-p", unpack p', show appId, disk]
-    (ec, _) <- readProcessInheritStderr "appmgr" args ""
-    case ec of
-        ExitFailure n | n < 0     -> throwE $ BackupE appId "Interrupted"
-                      | n == 7    -> throwE $ BackupPassInvalidE
-                      | otherwise -> throwE $ AppMgrE "backup" n
-        ExitSuccess -> pure ()
-
-backupRestore :: MonadIO m => Maybe Text -> AppId -> FilePath -> S9ErrT m ()
-backupRestore password appId disk = do
-    let args = case password of
-            Nothing -> ["backup", "restore", "-p", "\"\"", show appId, disk]
-            Just p' -> ["backup", "restore", "-p", unpack p', show appId, disk]
-    (ec, _) <- readProcessInheritStderr "appmgr" args ""
-    case ec of
-        ExitFailure n | n < 0     -> throwE $ BackupE appId "Interrupted"
-                      | n == 7    -> throwE $ BackupPassInvalidE
-                      | otherwise -> throwE $ AppMgrE "backup" n
-        ExitSuccess -> pure ()
-
-data AppMgrLevel =
-      INFO
-    | SUCCESS
-    | WARN
-    | ERROR
-    deriving (Eq, Show, Read)
-
-instance FromJSON AppMgrLevel where
-    parseJSON = withText "Level" $ \t -> case readMaybe t of
-        Nothing -> fail $ "Invalid Level: " <> unpack t
-        Just x  -> pure x
-
-data AppMgrNotif = AppMgrNotif
-    { appMgrNotifTime    :: Rational
-    , appMgrNotifLevel   :: AppMgrLevel
-    , appMgrNotifCode    :: Natural
-    , appMgrNotifTitle   :: Text
-    , appMgrNotifMessage :: Text
-    }
-    deriving (Eq, Show)
-
-instance FromJSON AppMgrNotif where
-    parseJSON = withObject "appmgr notification res" $ \o -> do
-        appMgrNotifTime    <- o .: "time"
-        appMgrNotifLevel   <- o .: "level"
-        appMgrNotifCode    <- o .: "code"
-        appMgrNotifTitle   <- o .: "title"
-        appMgrNotifMessage <- o .: "message"
-        pure AppMgrNotif { .. }
-
-type Manifest = Some1 ManifestStructure
-data ManifestStructure (n :: Nat) where
-    ManifestV0 ::{ manifestTitle :: Text
-        } -> ManifestStructure 0
-
-instance FromJSON (Some1 ManifestStructure) where
-    parseJSON = withObject "app manifest" $ \o -> do
-        o .: "compat" >>= \t -> case (t :: Text) of
-            "v0"  -> some1 <$> parseJSON @(ManifestStructure 0) (Object o)
-            other -> fail $ "Unknown Compat Version" <> unpack other
-
-instance FromJSON (ManifestStructure 0) where
-    parseJSON = withObject "manifest v0" $ \o -> do
-        manifestTitle <- o .: "title"
-        pure $ ManifestV0 { .. }
-
-torrcBase :: SystemPath
-torrcBase = "/root/appmgr/tor/torrc"
-
-torServicesYaml :: SystemPath
-torServicesYaml = "/root/appmgr/tor/services.yaml"
-
-appMgrAppsDirectory :: SystemPath
-appMgrAppsDirectory = "/root/appmgr/apps"
-
-readLanIps :: (MonadReader Text m, MonadIO m) => S9ErrT m (HM.HashMap AppId LanIp)
-readLanIps = do
-    base     <- ask
-    contents <-
-        liftIO $ (Just <$> readFile (unpack $ torServicesYaml `relativeTo` base)) `catch` \(e :: IOException) ->
-            if isDoesNotExistError e then pure Nothing else throwIO e
-    case contents of
-        Nothing        -> pure HM.empty
-        Just contents' -> do
-            val <- case Yaml.decodeEither' (encodeUtf8 contents') of
-                Left  e -> throwE $ AppMgrParseE "lan ip" contents' (show e)
-                Right a -> pure a
-            case Yaml.parseEither parser val of
-                Left  e -> throwE $ AppMgrParseE "lan ip" (show val) e
-                Right a -> pure a
-    where
-        parser :: Value -> Yaml.Parser (HM.HashMap AppId LanIp)
-        parser = withObject "Tor Services Yaml" $ \o -> do
-            hm <- o .: "map"
-            let (services, infos) = unzip $ HM.toList hm
-            ips <- traverse ipParser infos
-            pure . HM.fromList $ zip (AppId <$> services) ips
-        ipParser :: Value -> Yaml.Parser LanIp
-        ipParser = withObject "Service Info" $ \o -> do
-            ip <- o .: "ip"
-            pure $ LanIp ip
-
-data DiskInfo = DiskInfo
-    { diskInfoDescription :: Maybe Text
-    , diskInfoSize        :: Text
-    , diskInfoLogicalName :: FilePath
-    , diskInfoPartitions  :: [PartitionInfo]
-    }
-    deriving (Eq, Show)
-instance FromJSON DiskInfo where
-    parseJSON = withObject "Disk Info" $ \o -> do
-        diskInfoDescription <- o .: "description"
-        diskInfoSize        <- o .: "size"
-        diskInfoLogicalName <- o .: "logicalname"
-        diskInfoPartitions  <- o .: "partitions"
-        pure DiskInfo { .. }
-instance ToJSON DiskInfo where
-    toJSON DiskInfo {..} = object
-        [ "description" .= diskInfoDescription
-        , "size" .= diskInfoSize
-        , "logicalname" .= diskInfoLogicalName
-        , "partitions" .= diskInfoPartitions
-        ]
-
-data PartitionInfo = PartitionInfo
-    { partitionInfoLogicalName :: FilePath
-    , partitionInfoSize        :: Maybe Text
-    , partitionInfoIsMounted   :: Bool
-    , partitionInfoLabel       :: Maybe Text
-    }
-    deriving (Eq, Show)
-instance FromJSON PartitionInfo where
-    parseJSON = withObject "Partition Info" $ \o -> do
-        partitionInfoLogicalName <- o .: "logicalname"
-        partitionInfoSize        <- o .: "size"
-        partitionInfoIsMounted   <- o .: "is-mounted"
-        partitionInfoLabel       <- o .: "label"
-        pure PartitionInfo { .. }
-instance ToJSON PartitionInfo where
-    toJSON PartitionInfo {..} = object
-        [ "logicalname" .= partitionInfoLogicalName
-        , "size" .= partitionInfoSize
-        , "isMounted" .= partitionInfoIsMounted
-        , "label" .= partitionInfoLabel
-        ]

agent/src/Lib/External/Metrics/Df.hs

@@ -1,40 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE RecordWildCards  #-}
-
-module Lib.External.Metrics.Df where
-
-import           Startlude
-
-import           System.Process
-
-import           Lib.Error
-import           Lib.External.Metrics.Types
-
--- Disk :: Size Used Avail Use%
-data DfMetrics = DfMetrics
-    { metricDiskSize           :: Maybe Gigabytes
-    , metricDiskUsed           :: Maybe Gigabytes
-    , metricDiskAvailable      :: Maybe Gigabytes
-    , metricDiskUsedPercentage :: Maybe Percentage
-    } deriving (Eq, Show)
-
-getDfMetrics :: MonadIO m => S9ErrT m DfMetrics
-getDfMetrics = fmap parseDf runDf
-
-runDf :: MonadIO m => S9ErrT m Text
-runDf = do
-    (_, output, err') <- liftIO $ readProcessWithExitCode "df" ["-a", "/"] ""
-    unless (null err') $ throwE . MetricE $ "df command failed with " <> toS err'
-    pure $ toS output
-
-parseDf :: Text -> DfMetrics
-parseDf t =
-    let dataLine                 = words <$> lines t `atMay` 1
-        metricDiskSize           = fmap oneKBlocksToGigs . readMaybe =<< (`atMay` 1) =<< dataLine
-        metricDiskUsed           = fmap oneKBlocksToGigs . readMaybe =<< (`atMay` 2) =<< dataLine
-        metricDiskAvailable      = fmap oneKBlocksToGigs . readMaybe =<< (`atMay` 3) =<< dataLine
-        metricDiskUsedPercentage = readMaybe =<< (`atMay` 4) =<< dataLine
-    in  DfMetrics { .. }
-
-oneKBlocksToGigs :: Double -> Gigabytes
-oneKBlocksToGigs s = Gigabytes $ s / 1e6

agent/src/Lib/External/Metrics/Iotop.hs

@@ -1,58 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-
-module Lib.External.Metrics.Iotop where
-
-import           Startlude
-
-import qualified Data.HashMap.Strict           as HM
-import           System.Process
-
-import           Lib.Error
-import           Lib.External.Metrics.Types
-import           Lib.External.Util
-import           Util.Text
-
-data IotopMetrics = IotopMetrics
-    { metricCurrentRead  :: Maybe BytesPerSecond
-    , metricCurrentWrite :: Maybe BytesPerSecond
-    , metricTotalRead    :: Maybe BytesPerSecond
-    , metricTotalWrite   :: Maybe BytesPerSecond
-    } deriving (Eq, Show)
-
-getIotopMetrics :: MonadIO m => S9ErrT m IotopMetrics
-getIotopMetrics = fmap parseIotop runIotop
-
-runIotop :: MonadIO m => S9ErrT m Text
-runIotop = do
-    (_, output, err') <- liftIO $ readProcessWithExitCode "iotop" ["-bn1"] ""
-    unless (null err') $ throwE . MetricE $ "iotop command failed with " <> toS err'
-    pure $ toS output
-
-parseIotop :: Text -> IotopMetrics
-parseIotop t = IotopMetrics { metricCurrentRead  = BytesPerSecond . fst <$> current
-                            , metricCurrentWrite = BytesPerSecond . snd <$> current
-                            , metricTotalRead    = BytesPerSecond . fst <$> total
-                            , metricTotalWrite   = BytesPerSecond . snd <$> total
-                            }
-    where
-        iotopLines = lines t
-        current    = getHeaderAggregates currentHeader iotopLines
-        total      = getHeaderAggregates totalHeader iotopLines
-
-currentHeader :: Text
-currentHeader = "Current"
-
-totalHeader :: Text
-totalHeader = "Total"
-
-getHeaderAggregates :: Text -> [Text] -> Maybe (Double, Double)
-getHeaderAggregates header iotopLines = do
-    actualLine <- getLineByHeader header iotopLines
-    let stats = HM.fromList . getStats $ actualLine
-    r <- HM.lookup "READ" stats
-    w <- HM.lookup "WRITE" stats
-    pure (r, w)
-getStats :: Text -> [(Text, Double)]
-getStats = mapMaybe (parseToPair readMaybe . words . gsub ":" "") . getMatches statRegex
-    where statRegex = "([\x21-\x7E]+)[ ]{0,}:[ ]{1,}([\x21-\x7E]+)"
-

agent/src/Lib/External/Metrics/ProcDev.hs

@@ -1,118 +0,0 @@
-{-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE RecordWildCards  #-}
-{-# LANGUAGE TupleSections  #-}
-
-module Lib.External.Metrics.ProcDev where
-
-import           Startlude
-
-import           Lib.External.Util
-import           Lib.External.Metrics.Types
-import           Lib.Error
-import           Util.Text
-
-data ProcDevMetrics = ProcDevMetrics
-    { metricRBytesPerSecond    :: Maybe BytesPerSecond
-    , metricRPacketsPerSecond  :: Maybe BytesPerSecond
-    , metricRErrorsPerSecond   :: Maybe BytesPerSecond
-    , metricTBytesPerSecond    :: Maybe BytesPerSecond
-    , metricTPacketsPerSecond  :: Maybe BytesPerSecond
-    , metricTErrorsPerSecond   :: Maybe BytesPerSecond
-    , metricFrom :: UTCTime -- time range across which the above rates were calculated
-    , metricTo   :: UTCTime
-    } deriving Show
-
-getProcDevMetrics :: MonadIO m
-                  => (UTCTime, ProcDevMomentStats)
-                  -> S9ErrT m (UTCTime, ProcDevMomentStats, ProcDevMetrics)
-getProcDevMetrics oldMomentStats = do
-    newMomentStats@(newTime, newStats) <- newProcDevMomentStats
-    let metrics = computeProcDevMetrics oldMomentStats newMomentStats
-    pure (newTime, newStats, metrics)
-
-newProcDevMomentStats :: MonadIO m => S9ErrT m (UTCTime, ProcDevMomentStats)
-newProcDevMomentStats = do
-    res <- runProcDev
-    now <- liftIO getCurrentTime
-    pure $ parseProcDev now res
-
-runProcDev :: MonadIO m => S9ErrT m Text
-runProcDev = do
-    eOutput <- liftIO . try @SomeException $ readFile "/proc/net/dev"
-    case eOutput of
-        Left  e      -> throwE . MetricE $ "ProcDev proc file could not be read with " <> show e
-        Right output -> pure . toS $ output
-
-parseProcDev :: UTCTime -> Text -> (UTCTime, ProcDevMomentStats)
-parseProcDev now t = do
-    (now, ) . fold . foreach filteredLines $ \l ->
-        let ws              = words l
-            procDevRBytes   = ws `atMay` 1 >>= readMaybe
-            procDevRPackets = ws `atMay` 2 >>= readMaybe
-            procDevRErrors  = ws `atMay` 3 >>= readMaybe
-
-            procDevTBytes   = ws `atMay` 9 >>= readMaybe
-            procDevTPackets = ws `atMay` 10 >>= readMaybe
-            procDevTErrors  = ws `atMay` 11 >>= readMaybe
-        in  ProcDevMomentStats { .. }
-    where
-        wlanRegex     = "^[ ]{0,}wlan0"
-        ethRegex      = "^[ ]{0,}eth0"
-
-        isWlan        = containsMatch wlanRegex
-        isEth         = containsMatch ethRegex
-
-        filteredLines = filter (liftA2 (||) isWlan isEth) $ lines t
-
-computeProcDevMetrics :: (UTCTime, ProcDevMomentStats) -> (UTCTime, ProcDevMomentStats) -> ProcDevMetrics
-computeProcDevMetrics (fromTime, fromStats) (toTime, toStats) =
-    let metricRBytesPerSecond   = getMetric (procDevRBytes fromStats, fromTime) (procDevRBytes toStats, toTime)
-        metricRPacketsPerSecond = getMetric (procDevRPackets fromStats, fromTime) (procDevRPackets toStats, toTime)
-        metricRErrorsPerSecond  = getMetric (procDevRErrors fromStats, fromTime) (procDevRErrors toStats, toTime)
-        metricTBytesPerSecond   = getMetric (procDevTBytes fromStats, fromTime) (procDevTBytes toStats, toTime)
-        metricTPacketsPerSecond = getMetric (procDevTPackets fromStats, fromTime) (procDevTPackets toStats, toTime)
-        metricTErrorsPerSecond  = getMetric (procDevTErrors fromStats, fromTime) (procDevTErrors toStats, toTime)
-        metricFrom              = fromTime
-        metricTo                = toTime
-    in  ProcDevMetrics { .. }
-
-getMetric :: (Maybe Integer, UTCTime) -> (Maybe Integer, UTCTime) -> Maybe BytesPerSecond
-getMetric (Just fromMetric, fromTime) (Just toMetric, toTime) = Just . BytesPerSecond $ if timeDiff == 0
-    then 0
-    else truncateTo @Double 10 . fromRational $ (fromIntegral $ toMetric - fromMetric) / (toRational timeDiff)
-    where timeDiff = diffUTCTime toTime fromTime
-getMetric _ _ = Nothing
-
-data ProcDevMomentStats = ProcDevMomentStats
-    { procDevRBytes    :: Maybe Integer
-    , procDevRPackets  :: Maybe Integer
-    , procDevRErrors   :: Maybe Integer
-    , procDevTBytes    :: Maybe Integer
-    , procDevTPackets  :: Maybe Integer
-    , procDevTErrors   :: Maybe Integer
-    } deriving (Eq, Show)
-
-(?+?) :: Num a => Maybe a -> Maybe a -> Maybe a
-(?+?) Nothing Nothing = Nothing
-(?+?) m1      m2      = Just $ fromMaybe 0 m1 + fromMaybe 0 m2
-
-(?-?) :: Num a => Maybe a -> Maybe a -> Maybe a
-(?-?) Nothing Nothing = Nothing
-(?-?) m1      m2      = Just $ fromMaybe 0 m1 - fromMaybe 0 m2
-
-instance Semigroup ProcDevMomentStats where
-    m1 <> m2 = ProcDevMomentStats rBytes rPackets rErrors tBytes tPackets tErrors
-        where
-            rBytes   = procDevRBytes m1 ?+? procDevRBytes m2
-            rPackets = procDevRPackets m1 ?+? procDevRPackets m2
-            rErrors  = procDevRErrors m1 ?+? procDevRErrors m2
-            tBytes   = procDevTBytes m1 ?+? procDevTBytes m2
-            tPackets = procDevTPackets m1 ?+? procDevTPackets m2
-            tErrors  = procDevTErrors m1 ?+? procDevTErrors m2
-instance Monoid ProcDevMomentStats where
-    mempty = ProcDevMomentStats (Just 0) (Just 0) (Just 0) (Just 0) (Just 0) (Just 0)
-
-getDefaultProcDevMetrics :: MonadIO m => m ProcDevMetrics
-getDefaultProcDevMetrics = do
-    now <- liftIO getCurrentTime
-    pure $ ProcDevMetrics Nothing Nothing Nothing Nothing Nothing Nothing now now