Compare commits

..

8 Commits

Author SHA1 Message Date
Keagan McClelland
21f6560074 fix agent code review 2021-07-13 15:15:19 -06:00
Keagan McClelland
a077600c7e fix build issues 2021-07-13 15:15:19 -06:00
Keagan McClelland
59f0d4e23a change release notes 2021-07-13 15:15:19 -06:00
Keagan McClelland
e64b92c5dd alter semantics of tor update 2021-07-13 15:15:19 -06:00
Keagan McClelland
748379becc preps 0.2.14 messaging and version bumps 2021-07-13 15:15:19 -06:00
Keagan McClelland
5b3163465d updates appmgr to 0.2.14 ceremonial 2021-07-13 15:15:19 -06:00
Keagan McClelland
b00af8980a update appmgr dependency 2021-07-13 15:15:19 -06:00
Keagan McClelland
8708a4de8e agent 0.2.14 2021-07-13 15:15:19 -06:00
1531 changed files with 57707 additions and 122764 deletions

View File

@@ -1,102 +0,0 @@
name: 🐛 Bug Report
description: Create a report to help us improve StartOS
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/start-os/issues) that already report this problem.
required: true
- type: input
attributes:
label: Server Hardware
description: On what hardware are you running StartOS? Please be as detailed as possible!
placeholder: Pi (8GB) w/ 32GB microSD & Samsung T7 SSD
validations:
required: true
- type: input
attributes:
label: StartOS Version
description: What version of StartOS are you running?
placeholder: e.g. 0.3.4.3
validations:
required: true
- type: dropdown
attributes:
label: Client 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: Client 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 your server?
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.

View File

@@ -1,7 +0,0 @@
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.

View File

@@ -1,41 +0,0 @@
name: 💡 Feature Request
description: Suggest an idea for StartOS
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/start-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 StartOS?
- 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.

View File

@@ -1,237 +0,0 @@
name: Debian-based ISO and SquashFS
on:
workflow_call:
workflow_dispatch:
inputs:
environment:
type: choice
description: Environment
options:
- NONE
- dev
- unstable
- dev-unstable
- docker
- dev-docker
- dev-unstable-docker
runner:
type: choice
description: Runner
options:
- standard
- fast
platform:
type: choice
description: Platform
options:
- ALL
- x86_64
- x86_64-nonfree
- aarch64
- aarch64-nonfree
- raspberrypi
deploy:
type: choice
description: Deploy
options:
- NONE
- alpha
- beta
push:
branches:
- master
- next
pull_request:
branches:
- master
- next
env:
NODEJS_VERSION: "18.15.0"
ENVIRONMENT: '${{ fromJson(format(''["{0}", ""]'', github.event.inputs.environment || ''dev''))[github.event.inputs.environment == ''NONE''] }}'
jobs:
compile:
name: Compile Base Binaries
strategy:
fail-fast: true
matrix:
arch: >-
${{
fromJson('{
"x86_64": ["x86_64"],
"x86_64-nonfree": ["x86_64"],
"aarch64": ["aarch64"],
"aarch64-nonfree": ["aarch64"],
"raspberrypi": ["aarch64"],
"ALL": ["x86_64", "aarch64"]
}')[github.event.inputs.platform || 'ALL']
}}
runs-on: ${{ fromJson('["ubuntu-22.04", "buildjet-32vcpu-ubuntu-2204"]')[github.event.inputs.runner == 'fast'] }}
steps:
- run: |
sudo mount -t tmpfs tmpfs .
if: ${{ github.event.inputs.runner == 'fast' }}
- uses: actions/checkout@v3
with:
submodules: recursive
- uses: actions/setup-node@v3
with:
node-version: ${{ env.NODEJS_VERSION }}
- name: Set up QEMU
uses: docker/setup-qemu-action@v2
- name: Set up Docker Buildx
uses: docker/setup-buildx-action@v2
- name: Make
run: make ARCH=${{ matrix.arch }} compiled-${{ matrix.arch }}.tar
- uses: actions/upload-artifact@v3
with:
name: compiled-${{ matrix.arch }}.tar
path: compiled-${{ matrix.arch }}.tar
image:
name: Build Image
needs: [compile]
strategy:
fail-fast: false
matrix:
platform: >-
${{
fromJson(
format(
'[
["{0}"],
["x86_64", "x86_64-nonfree", "aarch64", "aarch64-nonfree", "raspberrypi"]
]',
github.event.inputs.platform || 'ALL'
)
)[(github.event.inputs.platform || 'ALL') == 'ALL']
}}
runs-on: >-
${{
fromJson(
format(
'["ubuntu-22.04", "{0}"]',
fromJson('{
"x86_64": "buildjet-8vcpu-ubuntu-2204",
"x86_64-nonfree": "buildjet-8vcpu-ubuntu-2204",
"aarch64": "buildjet-8vcpu-ubuntu-2204-arm",
"aarch64-nonfree": "buildjet-8vcpu-ubuntu-2204-arm",
"raspberrypi": "buildjet-8vcpu-ubuntu-2204-arm",
}')[matrix.platform]
)
)[github.event.inputs.runner == 'fast']
}}
env:
ARCH: >-
${{
fromJson('{
"x86_64": "x86_64",
"x86_64-nonfree": "x86_64",
"aarch64": "aarch64",
"aarch64-nonfree": "aarch64",
"raspberrypi": "aarch64",
}')[matrix.platform]
}}
steps:
- uses: actions/checkout@v3
with:
submodules: recursive
- name: Install dependencies
run: |
sudo apt-get update
sudo apt-get install -y qemu-user-static
wget https://deb.debian.org/debian/pool/main/d/debspawn/debspawn_0.6.2-1_all.deb
sha256sum ./debspawn_0.6.2-1_all.deb | grep 37ef27458cb1e35e8bce4d4f639b06b4b3866fc0b9191ec6b9bd157afd06a817
sudo apt-get install -y ./debspawn_0.6.2-1_all.deb
- name: Configure debspawn
run: |
sudo mkdir -p /etc/debspawn/
echo "AllowUnsafePermissions=true" | sudo tee /etc/debspawn/global.toml
sudo mkdir -p /var/tmp/debspawn
- run: sudo mount -t tmpfs tmpfs /var/tmp/debspawn
if: ${{ github.event.inputs.runner == 'fast' && (matrix.platform == 'x86_64' || matrix.platform == 'x86_64-nonfree') }}
- name: Download compiled artifacts
uses: actions/download-artifact@v3
with:
name: compiled-${{ env.ARCH }}.tar
- name: Extract compiled artifacts
run: tar -xvf compiled-${{ env.ARCH }}.tar
- name: Prevent rebuild of compiled artifacts
run: |
mkdir -p frontend/dist/raw
PLATFORM=${{ matrix.platform }} make -t compiled-${{ env.ARCH }}.tar
- name: Run iso build
run: PLATFORM=${{ matrix.platform }} make iso
if: ${{ matrix.platform != 'raspberrypi' }}
- name: Run img build
run: PLATFORM=${{ matrix.platform }} make img
if: ${{ matrix.platform == 'raspberrypi' }}
- uses: actions/upload-artifact@v3
with:
name: ${{ matrix.platform }}.squashfs
path: results/*.squashfs
- uses: actions/upload-artifact@v3
with:
name: ${{ matrix.platform }}.iso
path: results/*.iso
if: ${{ matrix.platform != 'raspberrypi' }}
- uses: actions/upload-artifact@v3
with:
name: ${{ matrix.platform }}.img
path: results/*.img
if: ${{ matrix.platform == 'raspberrypi' }}
- name: Upload OTA to registry
run: >-
PLATFORM=${{ matrix.platform }} make upload-ota TARGET="${{
fromJson('{
"alpha": "alpha-registry-x.start9.com",
"beta": "beta-registry.start9.com",
}')[github.event.inputs.deploy]
}}" KEY="${{
fromJson(
format('{{
"alpha": "{0}",
"beta": "{1}",
}}', secrets.ALPHA_INDEX_KEY, secrets.BETA_INDEX_KEY)
)[github.event.inputs.deploy]
}}"
if: ${{ github.event.inputs.deploy != '' && github.event.inputs.deploy != 'NONE' }}
index:
if: ${{ github.event.inputs.deploy != '' && github.event.inputs.deploy != 'NONE' }}
needs: [image]
runs-on: ubuntu-22.04
steps:
- run: >-
curl "https://${{
fromJson('{
"alpha": "alpha-registry-x.start9.com",
"beta": "beta-registry.start9.com",
}')[github.event.inputs.deploy]
}}:8443/resync.cgi?key=${{
fromJson(
format('{{
"alpha": "{0}",
"beta": "{1}",
}}', secrets.ALPHA_INDEX_KEY, secrets.BETA_INDEX_KEY)
)[github.event.inputs.deploy]
}}"

30
.gitignore vendored
View File

@@ -1,30 +1,4 @@
.DS_Store
.idea
system-images/binfmt/binfmt.tar
system-images/compat/compat.tar
system-images/util/util.tar
/*.img
/*.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/**/*
/PLATFORM.txt
/ENVIRONMENT.txt
/GIT_HASH.txt
/VERSION.txt
/eos-*.tar.gz
/*.deb
/target
/*.squashfs
/results
/dpkg-workdir
/compiled.tar
/compiled-*.tar
/buster.zip
/product_key

4
.gitmodules vendored
View File

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

175
BuildGuide.md Normal file
View File

@@ -0,0 +1,175 @@
##### Initial Notes & Recommendations
* Due to issues to cross-compile the image from a desktop, this guide will take you step-by-step through the process of compiling EmbassyOS directly on a Raspberry Pi 4 (4GB or 8GB)
* This process will go faster if you have an SSD/NVMe USB drive available.
* This build guide does **not** require a large microSD card, especially if your final build wil be used on an SSD/NVMe USB drive.
* Basic know-how of linux commands and terminal use is recommended.
* Follow the guide carefully and do not skip any steps.
# :hammer_and_wrench: Build Guide
1. Flash [Raspberry Pi OS Lite](https://www.raspberrypi.org/software/operating-systems/) to a microSD and configure your raspi to boot from SSD/NVMe USB drive
1. After flashing, create an empty text file called `ssh` in the `boot` partition of the microSD, then proceed with booting the raspi with the flashed microSD (check your router for the IP assigned to your raspi)
1. Do the usual initial update/config
```
sudo apt update
sudo raspi-config
```
1. Change `Advanced Options->Boot Order`
1. Select `USB Boot` *(it will try to boot from microSD first if it's available)*
1. Select `Finish`, then `Yes` to reboot
1. After reboot, `sudo shutdown now` to power off the raspi and remove the microSD
2. Flash the *Raspi OS Lite* (from step 1) to your SSD/NVMe drive
> :information_source: Don't worry about rootfs partition size (raspi will increase it for you on initial boot)
> :information_source: Every time you re-flash your SSD/NVMe you need to first boot with a microSD and set *Boot Order* again
1. Don't forget to create the empty `ssh` file
1. Connect the drive (remember to remove the microSD) to the raspi and start it up
1. Use `sudo raspi-config` to change the default password
1. Optional: `sudo apt upgrade -y`
1. Optional: `sudo nano /etc/apt/sources.list.d/vscode.list` comment the last line which contains `packages.microsoft.com`
3. Install GHC
```
sudo apt update
sudo apt install -y ghc
#test:
ghc --version
#example of output:
The Glorious Glasgow Haskell Compilation System, version 8.4.4
```
4. Compile Stack:
1. Install Stack v2.1.3
```
cd ~/
wget -qO- https://raw.githubusercontent.com/commercialhaskell/stack/v2.1.3/etc/scripts/get-stack.sh | sh
#test with
stack --version
#example output:
Version 2.1.3, Git revision 636e3a759d51127df2b62f90772def126cdf6d1f (7735 commits) arm hpack-0.31.2
```
1. Use current Stack to compile Stack v2.5.1:
```
git clone --depth 1 --branch v2.5.1 https://github.com/commercialhaskell/stack.git
cd stack
sudo apt install -y screen
screen
```
> :information_source: Build (>=3.5h total... We are using `screen` in case of session timeout issues)
> :memo: If you get disconected you can reattach last sesion again by executing `screen -r`
```
stack build --stack-yaml=stack-ghc-84.yaml --system-ghc
#Install
stack install --stack-yaml=stack-ghc-84.yaml --system-ghc
export PATH=~/.local/bin:$PATH
```
5. Clone EmbassyOS & try to *make* the `agent`:
1. First attempt
> :information_source: The first time you run **make** you'll get an error
```
sudo apt install -y llvm-9 libgmp-dev
export PATH=/usr/lib/llvm-9/bin:$PATH
cd ~/
git clone https://github.com/Start9Labs/embassy-os.git
cd embassy-os/
make agent
```
> :memo: This will install ghc-8.10.2, then attempt to build but will give errors (in next steps we deal with errors)
1. Confirm your cpu info
```
cat /proc/cpuinfo | grep Hardware
```
1. If your "Hardware" is [BCM2711](https://www.raspberrypi.org/documentation/hardware/raspberrypi/bcm2711/README.md) then:
1. Change `C compiler flags` to `-marm -fno-stack-protector -mcpu=cortex-a7` in the GHC settings:
```
nano ~/.stack/programs/arm-linux/ghc-8.10.4/lib/ghc-8.10.4/settings
```
1. To prevent gcc errors we delete the `setup-exe-src` folder
```
rm -rf ~/.stack/setup-exe-src/
```
6. Install requirements for step 7
1. Install NVM
```
cd ~/ && curl -o- https://raw.githubusercontent.com/nvm-sh/nvm/v0.35.3/install.sh | bash
export NVM_DIR="$HOME/.nvm"
[ -s "$NVM_DIR/nvm.sh" ] && \. "$NVM_DIR/nvm.sh" # This loads nvm
[ -s "$NVM_DIR/bash_completion" ] && \. "$NVM_DIR/bash_completion" # This loads nvm bash_completion
nvm --version
```
1. Install Node.js & NPM
```
nvm install node
```
1. Install Ionic CLI
```
npm install -g @ionic/cli
```
1. Install Dependencies
```
sudo apt-get install -y build-essential openssl libssl-dev libc6-dev clang libclang-dev libavahi-client-dev upx ca-certificates
```
1. Install Rust
```
cd ~/ && curl --proto '=https' --tlsv1.2 -sSf https://sh.rustup.rs -o- | bash
#Choose option 1
source $HOME/.cargo/env
#Check rust & cargo versions
rustc --version
cargo --version
```
7. Finally, getting to build the **.img**
1. At this stage you hava a working development environment to build your **embassy.img**.
Before you do that you can choose to enable SSH login for user `pi` in case something will go wrong or just skip to the next step.
```
cd ~/embassy-os
sed -e '/passwd -l pi/ s/^#*/#/' -i setup.sh
```
> :warning: Default password for user `pi` is `raspberry`, change it the next you login.
1. Build the `embassy.img`
```
cd ~/embassy-os
make
#Depending on your hardware this can take 1-2h+
#Wait for the "DONE!" message and take note of your product_key
exit
```
8. Flash the `embassy.img` to a microSD
1. Copy `embassy.img` from the raspi to your PC with scp
```
scp pi@raspi_IP:~/embassy-os/embassy.img .
```
1. Connect to raspi again to do `sudo shutdown now`, after a complete shutdown disconnect SSD/NVMe drive
1. Flash `embassy.img` to a microSD (do this before flashing to the SSD/NVMe, to be sure it works)
9. Prepare for initial setup
1. Boot raspi using flashed microSD
1. After a few minutes, the raspi should reboot itself and make it's first [sounds](#embassy-sounds-explained).
> :information_source: If needed, you can check the `agent` log with: `journalctl -u agent -ef`
1. Proceed with the [initial setup process of EmbassyOS](https://docs.start9labs.com/user-manual/initial-setup.html)
1. If all went well you can safely flash `embassy.img` to an SSD/NVMe and repeat step 9
### Embassy sounds explained
Sound :notes: | Indicating
------- | --------
Bep | Device is powering on
Chime | Device is ready for setup
Mario "Coin" | EmbassyOS has started
Mario "Death" | Device is about to Shutdown/Reboot
Mario "Power Up" | EmbassyOS update sequence
Beethoven | Update failed :(

View File

@@ -1,429 +0,0 @@
# v0.3.3
## Highlights
- x86_64 architecture compatibility
- Kiosk mode - use your Embassy with monitor, keyboard, and mouse (available on x86 builds only, disabled on Raspberry Pi)
- "Updates" tab - view all service updates from all registries in one place
- Various UI/UX improvements
- Various bugfixes and optimizations
## What's Changed
- Minor typo fixes by @kn0wmad in #1887
- Update build pipeline by @moerketh in #1896
- Feature/setup migrate by @elvece in #1841
- Feat/patch migration by @Blu-J in #1890
- make js cancellable by @dr-bonez in #1901
- wip: Making Injectable exec by @Blu-J in #1897
- Fix/debug by @Blu-J in #1909
- chore: Fix on the rsync not having stdout. by @Blu-J in #1911
- install wizard project by @MattDHill in #1893
- chore: Remove the duplicate loggging information that is making usele… by @Blu-J in #1912
- Http proxy by @redragonx in #1772
- fix(marketplace): loosen type in categories component by @waterplea in #1918
- set custom meta title by @MattDHill in #1915
- Feature/git hash by @dr-bonez in #1919
- closes #1900 by @dr-bonez in #1920
- feature/marketplace icons by @dr-bonez in #1921
- Bugfix/0.3.3 migration by @dr-bonez in #1922
- feat: Exposing the rsync that we have to the js by @Blu-J in #1907
- Feature/install wizard disk info by @dr-bonez in #1923
- bump shared and marketplace npm versions by @dr-bonez in #1924
- fix error handling when store unreachable by @dr-bonez in #1925
- wait for network online before launching init by @dr-bonez in #1930
- silence service crash notifications by @dr-bonez in #1929
- disable efi by @dr-bonez in #1931
- Tor daemon fix by @redragonx in #1934
- wait for url to be available before launching kiosk by @dr-bonez in #1933
- fix migration to support portable fatties by @dr-bonez in #1935
- Add guid to partition type by @MattDHill in #1932
- add localhost support to the http server by @redragonx in #1939
- refactor setup wizard by @dr-bonez in #1937
- feat(shared): Ticker add new component and use it in marketplace by @waterplea in #1940
- feat: For ota update using rsyncd by @Blu-J in #1938
- Feat/update progress by @MattDHill in #1944
- Fix/app show hidden by @MattDHill in #1948
- create dpkg and iso workflows by @dr-bonez in #1941
- changing ip addr type by @redragonx in #1950
- Create mountpoints first by @k0gen in #1949
- Hard code registry icons by @MattDHill in #1951
- fix: Cleanup by sending a command and kill when dropped by @Blu-J in #1945
- Update setup wizard styling by @elvece in #1954
- Feature/homepage by @elvece in #1956
- Fix millis by @Blu-J in #1960
- fix accessing dev tools by @MattDHill in #1966
- Update/misc UI fixes by @elvece in #1961
- Embassy-init typo by @redragonx in #1959
- feature: 0.3.2 -> 0.3.3 upgrade by @dr-bonez in #1958
- Fix/migrate by @Blu-J in #1962
- chore: Make validation reject containers by @Blu-J in #1970
- get pubkey and encrypt password on login by @elvece in #1965
- Multiple bugs and styling by @MattDHill in #1975
- filter out usb stick during install by @dr-bonez in #1974
- fix http upgrades by @dr-bonez in #1980
- restore interfaces before creating manager by @dr-bonez in #1982
- fuckit: no patch db locks by @dr-bonez in #1969
- fix websocket hangup error by @dr-bonez in #1981
- revert app show to use header and fix back button by @MattDHill in #1984
- Update/marketplace info by @elvece in #1983
- force docker image removal by @dr-bonez in #1985
- do not error if cannot determine live usb device by @dr-bonez in #1986
- remove community registry from FE defaults by @MattDHill in #1988
- check environment by @dr-bonez in #1990
- fix marketplace search and better category disabling by @MattDHill in #1991
- better migration progress bar by @dr-bonez in #1993
- bump cargo version by @dr-bonez in #1995
- preload icons and pause on setup complete for kiosk mode by @MattDHill in #1997
- use squashfs for rpi updates by @dr-bonez in #1998
- do not start progress at 0 before diff complete by @dr-bonez in #1999
- user must click continue in kiosk on success page by @MattDHill in #2001
- fix regex in image rip script by @dr-bonez in #2002
- fix bug with showing embassy drives and center error text by @MattDHill in #2006
- fix partition type by @dr-bonez in #2007
- lowercase service for alphabetic sorting by @MattDHill in #2008
- dont add updates cat by @MattDHill in #2009
- make downloaded page a full html doc by @MattDHill in #2011
- wait for monitor to be attached before launching firefox by @chrisguida in #2005
- UI fixes by @elvece in #2014
- fix: Stop service before by @Blu-J in #2019
- shield links update by @k0gen in #2018
- fix: Undoing the breaking introduced by trying to stopp by @Blu-J in #2023
- update link rename from embassy -> system by @elvece in #2027
- initialize embassy before restoring packages by @dr-bonez in #2029
- make procfs an optional dependency so sdk can build on macos by @elvece in #2028
- take(1) for recover select by @MattDHill in #2030
- take one from server info to prevent multiple reqs to registries by @MattDHill in #2032
- remove write lock during backup by @MattDHill in #2033
- fix: Ensure that during migration we make the urls have a trailing slash by @Blu-J in #2036
- fix: Make the restores limited # restore at a time by @Blu-J in #2037
- fix error and display of unknown font weight on success page by @elvece in #2038
## Checksums
```
8602e759d3ece7cf503b9ca43e8419109f14e424617c2703b3771c8801483d7e embassyos_amd64.deb
b5c0d8d1af760881a1b5cf32bd7c5b1d1cf6468f6da594a1b4895a866d03a58c embassyos_amd64.iso
fe518453a7e1a8d8c2be43223a1a12adff054468f8082df0560e1ec50df3dbfd embassyos_raspberrypi.img
7b1ff0ada27b6714062aa991ec31c2d95ac4edf254cd464a4fa251905aa47ebd embassyos_raspberrypi.tar.gz
```
# v0.3.2.1
## What's Changed
- Update index.html copy and styling by @elvece in #1855
- increase maximum avahi entry group size by @dr-bonez in #1869
- bump version by @dr-bonez in #1871
### Linux and Mac
Download the `eos.tar.gz` file, then extract and flash the resulting eos.img to your SD Card
Windows
Download the `eos.zip` file, then extract and flash the resulting eos.img to your SD Card
## SHA-256 Checksums
```
c4b17658910dd10c37df134d5d5fdd6478f962ba1b803d24477d563d44430f96 eos.tar.gz
3a8b29878fe222a9d7cbf645c975b12805704b0f39c7daa46033d22380f9828c eos.zip
dedff3eb408ea411812b8f46e6c6ed32bfbd97f61ec2b85a6be40373c0528256 eos.img
```
# v0.3.2
## Highlights
- Autoscrolling for logs
- Improved connectivity between browser and Embassy
- Switch to Postgres for EOS database for better performance
- Multiple bug fixes and under-the-hood improvements
- Various UI/UX enhancements
- Removal of product keys
Update Hash (SHA256): `d8ce908b06baee6420b45be1119e5eb9341ba8df920d1e255f94d1ffb7cc4de9`
Image Hash (SHA256): `e035cd764e5ad9eb1c60e2f7bc3b9bd7248f42a91c69015c8a978a0f94b90bbb`
Note: This image was uploaded as a gzipped POSIX sparse TAR file. The recommended command for unpacking it on systems that support sparse files is `tar --format=posix --sparse -zxvf eos.tar.gz`
## What's Changed
- formatting by @dr-bonez in #1698
- Update README.md by @kn0wmad in #1705
- Update README.md by @dr-bonez in #1703
- feat: migrate to Angular 14 and RxJS 7 by @waterplea in #1681
- 0312 multiple FE by @MattDHill in #1712
- Fix http requests by @MattDHill in #1717
- Add build-essential to README.md by @chrisguida in #1716
- write image to sparse-aware archive format by @dr-bonez in #1709
- fix: Add modification to the max_user_watches by @Blu-J in #1695
- [Feat] follow logs by @chrisguida in #1714
- Update README.md by @dr-bonez in #1728
- fix build for patch-db client for consistency by @elvece in #1722
- fix cli install by @chrisguida in #1720
- highlight instructions if not viewed by @MattDHill in #1731
- Feat: HttpReader by @redragonx in #1733
- Bugfix/dns by @dr-bonez in #1741
- add x86 build and run unittests to backend pipeline by @moerketh in #1682
- [Fix] websocket connecting and patchDB connection monitoring by @MattDHill in #1738
- Set pipeline job timeouts and add ca-certificates to test container by @moerketh in #1753
- Disable bluetooth properly #862 by @redragonx in #1745
- [feat]: resumable downloads by @dr-bonez in #1746
- Fix/empty properties by @elvece in #1764
- use hostname from patchDB as default server name by @MattDHill in #1758
- switch to postgresql by @dr-bonez in #1763
- remove product key from setup flow by @MattDHill in #1750
- pinning cargo dep versions for CLI by @redragonx in #1775
- fix: Js deep dir by @Blu-J in #1784
- 0.3.2 final cleanup by @dr-bonez in #1782
- expect ui marketplace to be undefined by @MattDHill in #1787
- fix init to exit on failure by @dr-bonez in #1788
- fix search to return more accurate results by @MattDHill in #1792
- update backend dependencies by @dr-bonez in #1796
- use base64 for HTTP headers by @dr-bonez in #1795
- fix: Bad cert of *.local.local is now fixed to correct. by @Blu-J in #1798
- fix duplicate patch updates, add scroll button to setup success by @MattDHill in #1800
- level_slider reclaiming that precious RAM memory by @k0gen in #1799
- stop leaking avahi clients by @dr-bonez in #1802
- fix: Deep is_parent was wrong and could be escapped by @Blu-J in #1801
- prevent cfg str generation from running forever by @dr-bonez in #1804
- better RPC error message by @MattDHill in #1803
- Bugfix/marketplace add by @elvece in #1805
- fix mrketplace swtiching by @MattDHill in #1810
- clean up code and logs by @MattDHill in #1809
- fix: Minor fix that matt wanted by @Blu-J in #1808
- onion replace instead of adding tor repository by @k0gen in #1813
- bank Start as embassy hostname from the begining by @k0gen in #1814
- add descriptions to marketplace list page by @elvece in #1812
- Fix/encryption by @elvece in #1811
- restructure initialization by @dr-bonez in #1816
- update license by @MattDHill in #1819
- perform system rebuild after updating by @dr-bonez in #1820
- ignore file not found error for delete by @dr-bonez in #1822
- Multiple by @MattDHill in #1823
- Bugfix/correctly package backend job by @moerketh in #1826
- update patch-db by @dr-bonez in #1831
- give name to logs file by @MattDHill in #1833
- play song during update by @dr-bonez in #1832
- Seed patchdb UI data by @elvece in #1835
- update patch db and enable logging by @dr-bonez in #1837
- reduce patch-db log level to warn by @dr-bonez in #1840
- update ts matches to fix properties ordering bug by @elvece in #1843
- handle multiple image tags having the same hash and increase timeout by @dr-bonez in #1844
- retry pgloader up to 5x by @dr-bonez in #1845
- show connection bar right away by @MattDHill in #1849
- dizzy Rebranding to embassyOS by @k0gen in #1851
- update patch db by @MattDHill in #1852
- camera_flash screenshots update by @k0gen in #1853
- disable concurrency and delete tmpdir before retry by @dr-bonez in #1846
## New Contributors
- @redragonx made their first contribution in #1733
# v0.3.1.1
## What's Changed
- whale2 docker stats fix by @k0gen in #1630
- update backend dependencies by @dr-bonez in #1637
- Fix/receipts health by @Blu-J in #1616
- return correct error on failed os download by @dr-bonez in #1636
- fix build by @dr-bonez in #1639
- Update product.yaml by @dr-bonez in #1638
- handle case where selected union enum is invalid after migration by @MattDHill in #1658
- fix: Resolve fighting with NM by @Blu-J in #1660
- sdk: don't allow mounts in inject actions by @chrisguida in #1653
- feat: Variable args by @Blu-J in #1667
- add readme to system-images folder by @elvece in #1665
- Mask chars beyond 16 by @MattDHill in #1666
- chore: Update to have the new version 0.3.1.1 by @Blu-J in #1668
- feat: Make the rename effect by @Blu-J in #1669
- fix migration, add logging by @dr-bonez in #1674
- run build checks only when relevant FE changes by @elvece in #1664
- trust local ca by @dr-bonez in #1670
- lower log level for docker deser fallback message by @dr-bonez in #1672
- refactor build process by @dr-bonez in #1675
- chore: enable strict mode by @waterplea in #1569
- draft releases notes for 0311 by @MattDHill in #1677
- add standby mode by @dr-bonez in #1671
- feat: atomic writing by @Blu-J in #1673
- allow server.update to update to current version by @dr-bonez in #1679
- allow falsey rpc response by @dr-bonez in #1680
- issue notification when individual package restore fails by @dr-bonez in #1685
- replace bang with question mark in html by @MattDHill in #1683
- only validate mounts for inject if eos >=0.3.1.1 by @dr-bonez in #1686
- add marketplace_url to backup metadata for service by @dr-bonez in #1688
- marketplace published at for service by @MattDHill in #1689
- sync data to fs before shutdown by @dr-bonez in #1690
- messaging for restart, shutdown, rebuild by @MattDHill in #1691
- honor shutdown from diagnostic ui by @dr-bonez in #1692
- ask for sudo password immediately during make by @dr-bonez in #1693
- sync blockdev after update by @dr-bonez in #1694
- set Matt as default assignee by @MattDHill in #1697
- NO_KEY for CI images by @dr-bonez in #1700
- fix typo by @dr-bonez in #1702
# v0.3.1
## What's Changed
- Feat bulk locking by @Blu-J in #1422
- Switching SSH keys to start9 user by @k0gen in #1321
- chore: Convert from ajv to ts-matches by @Blu-J in #1415
- Fix/id params by @elvece in #1414
- make nicer update sound by @ProofOfKeags in #1438
- adds product key to error message in setup flow when there is mismatch by @dr-bonez in #1436
- Update README.md to include yq by @cryptodread in #1385
- yin_yang For the peace of mind yin_yang by @k0gen in #1444
- Feature/update sound by @ProofOfKeags in #1439
- Feature/script packing by @ProofOfKeags in #1435
- rename ActionImplementation to PackageProcedure by @dr-bonez in #1448
- Chore/warning cleanse by @ProofOfKeags in #1447
- refactor packing to async by @ProofOfKeags in #1453
- Add nginx config for proxy redirect by @yzernik in #1421
- Proxy local frontend to remote backend by @elvece in #1452
- Feat/js action by @Blu-J in #1437
- Fix/making js work by @Blu-J in #1456
- fix: Dependency vs dependents by @Blu-J in #1462
- refactor: isolate network toast and login redirect to separate services by @waterplea in #1412
- Fix links in CONTRIBUTING.md, update ToC by @BBlackwo in #1463
- Feature/require script consistency by @ProofOfKeags in #1451
- Chore/version 0 3 1 0 by @Blu-J in #1475
- remove interactive TTY requirement from scripts by @moerketh in #1469
- Disable view in marketplace button when side-loaded by @BBlackwo in #1471
- Link to tor address on LAN setup page (#1277) by @BBlackwo in #1466
- UI version updates and welcome message for 0.3.1 by @elvece in #1479
- Update contribution and frontend readme by @BBlackwo in #1467
- Clean up config by @MattDHill in #1484
- Enable Control Groups for Docker containers by @k0gen in #1468
- Fix/patch db unwrap remove by @Blu-J in #1481
- handles spaces in working dir in make-image.sh by @moerketh in #1487
- UI cosmetic improvements by @MattDHill in #1486
- chore: fix the master by @Blu-J in #1495
- generate unique ca names based off of server id by @ProofOfKeags in #1500
- allow embassy-cli not as root by @dr-bonez in #1501
- fix: potential fix for the docker leaking the errors and such by @Blu-J in #1496
- Fix/memory leak docker by @Blu-J in #1505
- fixes serialization of regex pattern + description by @ProofOfKeags in #1509
- allow interactive TTY if available by @dr-bonez in #1508
- fix "missing proxy" error in embassy-cli by @dr-bonez in #1516
- Feat/js known errors by @Blu-J in #1514
- fixes a bug where nginx will crash if eos goes into diagnostic mode a… by @dr-bonez in #1506
- fix: restart/ uninstall sometimes didn't work by @Blu-J in #1527
- add "error_for_status" to static file downloads by @dr-bonez in #1532
- fixes #1169 by @dr-bonez in #1533
- disable unnecessary services by @dr-bonez in #1535
- chore: Update types to match embassyd by @Blu-J in #1539
- fix: found a unsaturaded args fix by @Blu-J in #1540
- chore: Update the lite types to include the union and enum by @Blu-J in #1542
- Feat: Make the js check for health by @Blu-J in #1543
- fix incorrect error message for deserialization in ValueSpecString by @dr-bonez in #1547
- fix dependency/dependent id issue by @dr-bonez in #1546
- add textarea to ValueSpecString by @dr-bonez in #1534
- Feat/js metadata by @Blu-J in #1548
- feat: uid/gid/mode added to metadata by @Blu-J in #1551
- Strict null checks by @waterplea in #1464
- fix backend builds for safe git config by @elvece in #1549
- update should send version not version spec by @elvece in #1559
- chore: Add tracing for debuging the js procedure slowness by @Blu-J in #1552
- Reset password through setup wizard by @MattDHill in #1490
- feat: Make sdk by @Blu-J in #1564
- fix: Missing a feature flat cfg by @Blu-J in #1563
- fixed sentence that didn't make sense by @BitcoinMechanic in #1565
- refactor(patch-db): use PatchDB class declaratively by @waterplea in #1562
- fix bugs with config and clean up dev options by @MattDHill in #1558
- fix: Make it so we only need the password on the backup by @Blu-J in #1566
- kill all sessions and remove ripple effect by @MattDHill in #1567
- adjust service marketplace button for installation source relevance by @elvece in #1571
- fix connection failure display monitoring and other style changes by @MattDHill in #1573
- add dns server to embassy-os by @dr-bonez in #1572
- Fix/mask generic inputs by @elvece in #1570
- Fix/sideload icon type by @elvece in #1577
- add avahi conditional compilation flags to dns by @dr-bonez in #1579
- selective backups and better drive selection interface by @MattDHill in #1576
- Feat/use modern tor by @kn0wmad in #1575
- update welcome notes for 031 by @MattDHill in #1580
- fix: Properties had a null description by @Blu-J in #1581
- fix backup lock ordering by @dr-bonez in #1582
- Bugfix/backup lock order by @dr-bonez in #1583
- preload redacted and visibility hidden by @MattDHill in #1584
- turn chevron red in config if error by @MattDHill in #1586
- switch to utc by @dr-bonez in #1587
- update patchdb for array patch fix by @elvece in #1588
- filter package ids when backing up by @dr-bonez in #1589
- add select/deselect all to backups and enum lists by @elvece in #1590
- fix: Stop the buffer from dropped pre-maturly by @Blu-J in #1591
- chore: commit the snapshots by @Blu-J in #1592
- nest new entries and message updates better by @MattDHill in #1595
- fix html parsing in logs by @elvece in #1598
- don't crash service if io-format is set for main by @dr-bonez in #1599
- strip html from colors from logs by @elvece in #1604
- feat: fetch effect by @Blu-J in #1605
- Fix/UI misc by @elvece in #1606
- display bottom item in backup list and refactor for cleanliness by @MattDHill in #1609
# v0.3.0.3
## What's Changed
- refactor: decompose app component by @waterplea in #1359
- Update Makefile by @kn0wmad in #1400
- ⬐ smarter wget by @k0gen in #1401
- prevent the kernel from OOMKilling embassyd by @dr-bonez in #1402
- attempt to heal when health check passes by @dr-bonez in #1420
- Feat new locking by @Blu-J in #1384
- version bump by @dr-bonez in #1423
- Update server-show.page.ts by @chrisguida in #1424
- Bump async from 2.6.3 to 2.6.4 in /frontend by @dependabot in #1426
- Update index.html by @mirkoRainer in #1419
## New Contributors
- @dependabot made their first contribution in #1426
- @mirkoRainer made their first contribution in #1419
# v0.3.0.2
- Minor compatibility fixes
- #1392
- #1390
- #1388
# v0.3.0.1
Minor bugfixes and performance improvements
# v0.3.0
- Websockets
- Real-time sync
- Patch DB
- Closely mirror FE and BE state. Most operating systems are connected to their GUI. Here it is served over the web. Patch DB and websockets serve to close the perceptual gap of this inherent challenge.
- Switch kernel from Raspbian to Ubuntu
- 64 bit
- Possibility for alternative hardware
- Merging of lifeline, agent, and appmgr into embassyd
- Elimination of Haskell in favor of pure Rust
- Unified API for interacting with the OS
- Easier to build from source
- OS (quarantined from OS and service data)
- Kernel/boot
- Persistent metadata (disk guid, product key)
- Rootfs (the os)
- Reserved (for updates) - swaps with rootfs
- Revamped OS updates
- Progress indicators
- Non-blocking
- Simple swap on reboot
- Revamped setup flow
- Elimination of Setup App (Apple/Google dependencies gone)
- Setup Wizard on http://embassy.local
- Revamped service config
- Dynamic, validated forms
- Diagnostic UI
- Missing disk, wrong disk, corrupt disk
- Turing complete API for actions, backup/restore, config, properties, notifications, health checks, and dependency requirements
- Optional, arbitrary inputs for actions
- Install, update, recover progress for apps
- Multiple interfaces
- E.g. rpc, p2p, ui
- Health checks
- Developer defined
- Internal, dependencies, and/or external
- Full Embassy backup (diff-based)
- External drive support/requirement
- Single at first
- Groundwork for extension and mirror drives
- Disk encryption
- Random key encrypted with static value
- Groundwork for swapping static value with chosen password
- Session Management
- List all active sessions
- Option to kill
- More robust and extensive logs
- Donations

View File

@@ -1,35 +1,24 @@
<!-- omit in toc -->
# Contributing to StartOS
# Contributing to Embassy OS
First off, thanks for taking the time to contribute! ❤️
All types of contributions are encouraged and valued. See the
[Table of Contents](#table-of-contents) for different ways to help and details
about how this project handles them. Please make sure to read the relevant
section before making your contribution. It will make it a lot easier for us
maintainers and smooth out the experience for all involved. The community looks
forward to your contributions. 🎉
All types of contributions are encouraged and valued. See the [Table of Contents](#table-of-contents) for different ways to help and details about how this project handles them. Please make sure to read the relevant section before making your contribution. It will make it a lot easier for us maintainers and smooth out the experience for all involved. The community looks forward to your contributions. 🎉
> And if you like the project, but just don't have time to contribute, that's
> fine. There are other easy ways to support the project and show your
> appreciation, which we would also be very happy about:
>
> And if you like the project, but just don't have time to contribute, that's fine. There are other easy ways to support the project and show your appreciation, which we would also be very happy about:
> - Star the project
> - Tweet about it
> - Refer this project in your project's readme
> - Mention the project at local meetups and tell your friends/colleagues
> - Buy a [Start9 server](https://start9.com)
> - Buy an [Embassy](https://start9labs.com)
<!-- omit in toc -->
## Table of Contents
- [I Have a Question](#i-have-a-question)
- [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)
@@ -43,21 +32,17 @@ forward to your contributions. 🎉
- [Join The Discussion](#join-the-discussion)
- [Join The Project Team](#join-the-project-team)
## I Have a Question
> If you want to ask a question, we assume that you have read the available
> [Documentation](https://docs.start9labs.com).
> If you want to ask a question, we assume that you have read the available [Documentation](https://docs.start9labs.com).
Before you ask a question, it is best to search for existing
[Issues](https://github.com/Start9Labs/start-os/issues) that might help you.
In case you have found a suitable issue and still need clarification, you can
write your question in this issue. It is also advisable to search the internet
for answers first.
Before you ask a question, it is best to search for existing [Issues](https://github.com/Start9Labs/embassy-os/issues) that might help you. In case you have found a suitable issue and still need clarification, you can write your question in this issue. It is also advisable to search the internet for answers first.
If you then still feel the need to ask a question and need clarification, we
recommend the following:
If you then still feel the need to ask a question and need clarification, we recommend the following:
- Open an [Issue](https://github.com/Start9Labs/start-os/issues/new).
- Open an [Issue](https://github.com/Start9Labs/embassy-os/issues/new).
- Provide as much context as you can about what you're running into.
- Provide project and platform versions, depending on what seems relevant.
@@ -81,259 +66,172 @@ Depending on how large the project is, you may want to outsource the questioning
## I Want To Contribute
> ### Legal Notice <!-- omit in toc -->
>
> When contributing to this project, you must agree that you have authored 100%
> of the content, that you have the necessary rights to the content and that the
> content you contribute may be provided under the project license.
> When contributing to this project, you must agree that you have authored 100% of the content, that you have the necessary rights to the content and that the content you contribute may be provided under the project license.
### Reporting Bugs
<!-- omit in toc -->
#### Before Submitting a Bug Report
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.
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://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/start-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.
- 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-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)
- Client OS, Platform and Version (Windows/Linux/macOS/iOS/Android,
Firefox/Tor Browser/Consulate)
- Version of the interpreter, compiler, SDK, runtime environment, package
manager, depending on what seems relevant.
- Client OS, Platform and Version (Windows/Linux/macOS/iOS/Android, Firefox/Tor Browser/Consulate)
- Version of the interpreter, compiler, SDK, runtime environment, package manager, depending on what seems relevant.
- Possibly your input and the output
- Can you reliably reproduce the issue? And can you also reproduce it with
older versions?
- Can you reliably reproduce the issue? And can you also reproduce it with older versions?
<!-- omit in toc -->
#### How Do I Submit a Good Bug Report?
> You must never report security related issues, vulnerabilities or bugs to the
> issue tracker, or elsewhere in public. Instead sensitive bugs must be sent by
> email to <security@start9labs.com>.
> You must never report security related issues, vulnerabilities or bugs to the issue tracker, or elsewhere in public. Instead sensitive bugs must be sent by email to <security@start9labs.com>.
<!-- You may add a PGP key to allow the messages to be sent encrypted as well. -->
We use GitHub issues to track bugs and errors. If you run into an issue with the
project:
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/start-os/issues/new/choose)
selecting the appropriate type.
- 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.)
- 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.
- 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.
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 `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).
- 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).
<!-- 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. -->
### Suggesting Enhancements
This section guides you through submitting an enhancement suggestion for StartOS, **including completely new features and minor improvements to existing
functionality**. Following these guidelines will help maintainers and the
community to understand your suggestion and find related suggestions.
This section guides you through submitting an enhancement suggestion for Embassy OS, **including completely new features and minor improvements to existing functionality**. Following these guidelines will help maintainers and the community to understand your suggestion and find related suggestions.
<!-- omit in toc -->
#### Before Submitting an Enhancement
- Make sure that you are using the latest version.
- 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/start-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.
- Read the [documentation](https://docs.start9labs.com) 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.
<!-- omit in toc -->
#### How Do I Submit a Good Enhancement Suggestion?
Enhancement suggestions are tracked as
[GitHub issues](https://github.com/Start9Labs/start-os/issues).
Enhancement suggestions are tracked as [GitHub issues](https://github.com/Start9Labs/embassy-os/issues).
- Use a **clear and descriptive title** for the issue to identify the
suggestion.
- Provide a **step-by-step description of the suggested enhancement** in as many
details as possible.
- **Describe the current behavior** and **explain which behavior you expected to
see instead** and why. At this point you can also tell which alternatives do
not work for you.
- You may want to **include screenshots and animated GIFs** which help you
demonstrate the steps or point out the part which the suggestion is related
to. You can use [this tool](https://www.cockos.com/licecap/) to record GIFs on
macOS and Windows, and [this tool](https://github.com/colinkeenan/silentcast)
or [this tool](https://github.com/GNOME/byzanz) on Linux.
<!-- this should only be included if the project has a GUI -->
- **Explain why this enhancement would be useful** to most StartOS users. You
may also want to point out the other projects that solved it better and which
could serve as inspiration.
- Use a **clear and descriptive title** for the issue to identify the suggestion.
- Provide a **step-by-step description of the suggested enhancement** in as many details as possible.
- **Describe the current behavior** and **explain which behavior you expected to see instead** and why. At this point you can also tell which alternatives do not work for you.
- You may want to **include screenshots and animated GIFs** which help you demonstrate the steps or point out the part which the suggestion is related to. You can use [this tool](https://www.cockos.com/licecap/) to record GIFs on macOS and Windows, and [this tool](https://github.com/colinkeenan/silentcast) or [this tool](https://github.com/GNOME/byzanz) on Linux. <!-- this should only be included if the project has a GUI -->
- **Explain why this enhancement would be useful** to most Embassy OS users. You may also want to point out the other projects that solved it better and which could serve as inspiration.
<!-- 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
StartOS is composed of the following components. Please visit the README for
each component to understand the dependency requirements and installation
instructions.
- [`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 StartOS.
- [`build`](build/README.md) contains scripts and necessary for deploying
StartOS to a debian/raspbian system.
- [`frontend`](frontend/README.md) (Typescript Ionic Angular) is the code that
is deployed to the browser to provide the user interface for StartOS.
- `projects/ui` - Code for the user interface that is displayed when StartOS
is running normally.
- `projects/setup-wizard`(frontend/README.md) - Code for the user interface
that is displayed during the setup and recovery process for StartOS.
- `projects/diagnostic-ui` - Code for the user interface that is displayed
when something has gone wrong with starting up StartOS, which provides
helpful debugging tools.
- `libs` (Rust) is a set of standalone crates that were separated out of
`backend` for the purpose of portability
- `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.
- `system-images` - (Docker, Rust) A suite of utility Docker images that are
preloaded with StartOS to assist with functions relating to services (eg.
configuration, backups, health checks).
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.
### Your First Code Contribution
#### Setting Up Your Development Environment
#### 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)
First, clone the StartOS repository and from the project root, pull in the
submodules for dependent libraries.
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.
```sh
git clone https://github.com/Start9Labs/start-os.git
git submodule update --init --recursive
```
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.
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))
Once you have done these things, you simply need to `cd` into the embassy-os project and then run `make agent`.
#### Building The Raspberry Pi Image
##### 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.
This step is for setting up an environment in which to test your code changes if
you do not yet have a StartOS.
##### appmgr
- [Install Rust](https://rustup.rs)
- Recommended: [rust-analyzer](https://rust-analyzer.github.io/)
#### Building The Image
- Requirements
- `ext4fs` (available if running on the Linux kernel)
- [Docker](https://docs.docker.com/get-docker/)
- GNU Make
- Building
- see setup instructions [here](build/README.md)
- run `make startos-raspi.img ARCH=aarch64` from the project root
- build the [agent](#agent)
- make sure resulting artifact is agent/dist/agent
- run `make`
### 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.
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
Each component of StartOS 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.
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)
### 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.
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. `backend: update to tokio v0.3`.
If a commit touches only 1 component, prefix the message with the affected component. i.e. `appmgr: 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/start-os/issues).
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.
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](https://matrix.to/#/#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](https://matrix.to/#/#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>
Interested in becoming a part of the Start9 Labs team? Send an email to <jobs@start9labs.com>
<!-- omit in toc -->
## Attribution
This guide is based on the **contributing-gen**.
[Make your own](https://github.com/bttger/contributing-gen)!
This guide is based on the **contributing-gen**. [Make your own](https://github.com/bttger/contributing-gen)!

21
LICENSE
View File

@@ -1,21 +0,0 @@
MIT License
Copyright (c) 2023 Start9 Labs, Inc.
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.

25
LICENSE.md Normal file
View File

@@ -0,0 +1,25 @@
# START9 PERSONAL USE LICENSE v1.0
This license governs the use of the accompanying Software. If you use the Software, you accept this license. If you do not accept the license, do not use the Software.
1. **Definitions.**
1. “Licensor” means the copyright owner, Start9 Labs, Inc, or its successor(s) in interest, or a future assignee of the copyright.
2. “Source Code” means the preferred form of the Software for making modifications to it.
3. “Object Code” means any non-source form of the Software, including the machine-language output by a compiler or assembler.
4. “Distribute” means to convey or to publish and generally has the same meaning here as under U.S. Copyright law.
5. “Sell” means practicing any or all of the rights granted to you under the License to provide to third parties, for a fee or other consideration (including without limitation fees for hosting or consulting/support services related to the Software), a product or service whose value derives, entirely or substantially, from the functionality of the Software.
2. **Grant of Rights.** Subject to the terms of this license, the Licensor grants you, the licensee, a non-exclusive, worldwide, royalty-free copyright license to:
1. Access, audit, copy, modify, compile, or distribute the Source Code or modifications to the Source Code.
2. Run, test, or otherwise use the Object Code.
3. **Limitations.**
1. The grant of rights under the License will NOT include, and the License does NOT grant you the right to:
1. Sell the Software or any derivative works based thereon.
2. Distribute the Object Code.
2. If you Distribute the Source Code, or if permission is separately granted to Distribute the Object Code, you expressly undertake not to remove, or modify, in any manner, the copyright notices attached to the Source Code, and displayed in any output of the Object Code when run, and to reproduce these notices, in an identical manner, in any distributed copies of the Software together with a copy of this license. If you Distribute a modified copy of the Software, or a derivative work based thereon, the work must carry prominent notices stating that you modified it, and giving a relevant date.
3. The terms of this license will apply to anyone who comes into possession of a copy of the Software, and any modifications or derivative works based thereon, made by anyone.
4. **Contributions.** You hereby grant to Licensor a perpetual, irrevocable, worldwide, non-exclusive, royalty-free license to use and exploit any modifications or derivative works based on the Source Code of which you are the author.
5. **Disclaimer.** THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. LICENSOR HAS NO OBLIGATION TO SUPPORT RECIPIENTS OF THE SOFTWARE.

273
Makefile
View File

@@ -1,230 +1,75 @@
PLATFORM_FILE := $(shell ./check-platform.sh)
ENVIRONMENT_FILE := $(shell ./check-environment.sh)
GIT_HASH_FILE := $(shell ./check-git-hash.sh)
VERSION_FILE := $(shell ./check-version.sh)
BASENAME := $(shell ./basename.sh)
PLATFORM := $(shell if [ -f ./PLATFORM.txt ]; then cat ./PLATFORM.txt; else echo unknown; fi)
ARCH := $(shell if [ "$(PLATFORM)" = "raspberrypi" ]; then echo aarch64; else echo $(PLATFORM) | sed 's/-nonfree$$//g'; fi)
IMAGE_TYPE=$(shell if [ "$(PLATFORM)" = raspberrypi ]; then echo img; else echo iso; fi)
EMBASSY_BINS := backend/target/$(ARCH)-unknown-linux-gnu/release/startbox libs/target/aarch64-unknown-linux-musl/release/embassy_container_init libs/target/x86_64-unknown-linux-musl/release/embassy_container_init
EMBASSY_UIS := frontend/dist/raw/ui frontend/dist/raw/setup-wizard frontend/dist/raw/diagnostic-ui frontend/dist/raw/install-wizard
BUILD_SRC := $(shell git ls-files build) build/lib/depends build/lib/conflicts
DEBIAN_SRC := $(shell git ls-files debian/)
IMAGE_RECIPE_SRC := $(shell git ls-files image-recipe/)
EMBASSY_SRC := backend/startd.service $(BUILD_SRC)
COMPAT_SRC := $(shell git ls-files system-images/compat/)
UTILS_SRC := $(shell git ls-files system-images/utils/)
BINFMT_SRC := $(shell git ls-files system-images/binfmt/)
BACKEND_SRC := $(shell git ls-files backend) $(shell git ls-files --recurse-submodules patch-db) $(shell git ls-files libs) frontend/dist/static
FRONTEND_SHARED_SRC := $(shell git ls-files frontend/projects/shared) $(shell ls -p frontend/ | grep -v / | sed 's/^/frontend\//g') frontend/node_modules frontend/config.json patch-db/client/dist frontend/patchdb-ui-seed.json
FRONTEND_UI_SRC := $(shell git ls-files frontend/projects/ui)
FRONTEND_SETUP_WIZARD_SRC := $(shell git ls-files frontend/projects/setup-wizard)
FRONTEND_DIAGNOSTIC_UI_SRC := $(shell git ls-files frontend/projects/diagnostic-ui)
FRONTEND_INSTALL_WIZARD_SRC := $(shell git ls-files frontend/projects/install-wizard)
PATCH_DB_CLIENT_SRC := $(shell git ls-files --recurse-submodules patch-db/client)
GZIP_BIN := $(shell which pigz || which gzip)
TAR_BIN := $(shell which gtar || which tar)
COMPILED_TARGETS := $(EMBASSY_BINS) system-images/compat/docker-images/$(ARCH).tar system-images/utils/docker-images/$(ARCH).tar system-images/binfmt/docker-images/$(ARCH).tar
ALL_TARGETS := $(EMBASSY_SRC) $(ENVIRONMENT_FILE) $(GIT_HASH_FILE) $(VERSION_FILE) $(COMPILED_TARGETS) $(shell if [ "$(PLATFORM)" = "raspberrypi" ]; then echo cargo-deps/aarch64-unknown-linux-gnu/release/pi-beep; fi) $(shell /bin/bash -c 'if [[ "${ENVIRONMENT}" =~ (^|-)unstable($$|-) ]]; then echo cargo-deps/$(ARCH)-unknown-linux-gnu/release/tokio-console; fi') $(PLATFORM_FILE)
UNAME := $(shell uname -m)
ifeq ($(REMOTE),)
mkdir = mkdir -p $1
rm = rm -rf $1
cp = cp -r $1 $2
ln = ln -sf $1 $2
else
ifeq ($(SSHPASS),)
ssh = ssh $(REMOTE) $1
else
ssh = sshpass -p $(SSHPASS) ssh $(REMOTE) $1
endif
mkdir = $(call ssh,'sudo mkdir -p $1')
rm = $(call ssh,'sudo rm -rf $1')
ln = $(call ssh,'sudo ln -sf $1 $2')
define cp
$(TAR_BIN) --transform "s|^$1|x|" -czv -f- $1 | $(call ssh,"sudo tar --transform 's|^x|$2|' -xzv -f- -C /")
endef
EMBASSY_SRC := 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
APPMGR_RELEASE_SRC := appmgr/target/armv7-unknown-linux-gnueabihf/release/appmgr
LIFELINE_RELEASE_SRC := lifeline/target/armv7-unknown-linux-gnueabihf/release/lifeline
ifeq ($(UNAME), armv7l)
EMBASSY_SRC := buster.img product_key appmgr/target/release/appmgr ui/www agent/dist/agent agent/config/agent.service lifeline/target/release/lifeline lifeline/lifeline.service setup.sh setup.service docker-daemon.json
APPMGR_RELEASE_SRC := appmgr/target/release/appmgr
LIFELINE_RELEASE_SRC := lifeline/target/release/lifeline
endif
.DELETE_ON_ERROR:
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
.PHONY: all metadata install clean format sdk snapshots frontends ui backend reflash deb $(IMAGE_TYPE) squashfs sudo wormhole docker-buildx
all: embassy.img
all: $(ALL_TARGETS)
embassy.img: $(EMBASSY_SRC)
chmod +x make_image.sh
sudo ./make_image.sh
metadata: $(VERSION_FILE) $(PLATFORM_FILE) $(ENVIRONMENT_FILE) $(GIT_HASH_FILE)
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
sudo:
sudo true
product_key:
echo "X\c" > product_key
cat /dev/random | base32 | head -c11 | tr '[:upper:]' '[:lower:]' >> product_key
clean:
rm -f system-images/**/*.tar
rm -rf system-images/compat/target
rm -rf backend/target
rm -rf frontend/.angular
rm -f frontend/config.json
rm -rf frontend/node_modules
rm -rf frontend/dist
rm -rf libs/target
rm -rf patch-db/client/node_modules
rm -rf patch-db/client/dist
rm -rf patch-db/target
rm -rf cargo-deps
rm -rf dpkg-workdir
rm -rf image-recipe/deb
rm -rf results
rm -f ENVIRONMENT.txt
rm -f PLATFORM.txt
rm -f GIT_HASH.txt
rm -f VERSION.txt
$(APPMGR_RELEASE_SRC): $(APPMGR_SRC)
ifeq ($(UNAME), armv7l)
cd appmgr && cargo update && cargo build --release --features=production
arm-linux-gnueabihf-strip appmgr/target/release/appmgr
else
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
endif
format:
cd backend && cargo +nightly fmt
cd libs && cargo +nightly fmt
appmgr: $(APPMGR_RELEASE_SRC)
sdk:
cd backend/ && ./install-sdk.sh
agent/dist/agent: $(AGENT_SRC)
(cd agent && ./build.sh)
deb: results/$(BASENAME).deb
agent: agent/dist/agent
debian/control: build/lib/depends build/lib/conflicts
./debuild/control.sh
ui/node_modules: ui/package.json
npm --prefix ui install
results/$(BASENAME).deb: dpkg-build.sh $(DEBIAN_SRC) $(VERSION_FILE) $(PLATFORM_FILE) $(ENVIRONMENT_FILE) $(GIT_HASH_FILE)
PLATFORM=$(PLATFORM) ./dpkg-build.sh
ui/www: $(UI_SRC) ui/node_modules
npm --prefix ui run build-prod
$(IMAGE_TYPE): results/$(BASENAME).$(IMAGE_TYPE)
ui: ui/www
squashfs: results/$(BASENAME).squashfs
$(LIFELINE_RELEASE_SRC): $(LIFELINE_SRC)
ifeq ($(UNAME), armv7l)
cd lifeline && cargo build --release
arm-linux-gnueabihf-strip lifeline/target/release/lifeline
else
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
endif
results/$(BASENAME).$(IMAGE_TYPE) results/$(BASENAME).squashfs: $(IMAGE_RECIPE_SRC) results/$(BASENAME).deb
./image-recipe/run-local-build.sh "results/$(BASENAME).deb"
# For creating os images. DO NOT USE
install: $(ALL_TARGETS)
$(call mkdir,$(DESTDIR)/usr/bin)
$(call cp,backend/target/$(ARCH)-unknown-linux-gnu/release/startbox,$(DESTDIR)/usr/bin/startbox)
$(call ln,/usr/bin/startbox,$(DESTDIR)/usr/bin/startd)
$(call ln,/usr/bin/startbox,$(DESTDIR)/usr/bin/start-cli)
$(call ln,/usr/bin/startbox,$(DESTDIR)/usr/bin/start-sdk)
$(call ln,/usr/bin/startbox,$(DESTDIR)/usr/bin/start-deno)
$(call ln,/usr/bin/startbox,$(DESTDIR)/usr/bin/avahi-alias)
$(call ln,/usr/bin/startbox,$(DESTDIR)/usr/bin/embassy-cli)
if [ "$(PLATFORM)" = "raspberrypi" ]; then $(call cp,cargo-deps/aarch64-unknown-linux-gnu/release/pi-beep,$(DESTDIR)/usr/bin/pi-beep); fi
if /bin/bash -c '[[ "${ENVIRONMENT}" =~ (^|-)unstable($$|-) ]]'; then $(call cp,cargo-deps/$(ARCH)-unknown-linux-gnu/release/tokio-console,$(DESTDIR)/usr/bin/tokio-console); fi
$(call mkdir,$(DESTDIR)/lib/systemd/system)
$(call cp,backend/startd.service,$(DESTDIR)/lib/systemd/system/startd.service)
$(call mkdir,$(DESTDIR)/usr/lib)
$(call rm,$(DESTDIR)/usr/lib/startos)
$(call cp,build/lib,$(DESTDIR)/usr/lib/startos)
$(call cp,PLATFORM.txt,$(DESTDIR)/usr/lib/startos/PLATFORM.txt)
$(call cp,ENVIRONMENT.txt,$(DESTDIR)/usr/lib/startos/ENVIRONMENT.txt)
$(call cp,GIT_HASH.txt,$(DESTDIR)/usr/lib/startos/GIT_HASH.txt)
$(call cp,VERSION.txt,$(DESTDIR)/usr/lib/startos/VERSION.txt)
$(call mkdir,$(DESTDIR)/usr/lib/startos/container)
$(call cp,libs/target/aarch64-unknown-linux-musl/release/embassy_container_init,$(DESTDIR)/usr/lib/startos/container/embassy_container_init.arm64)
$(call cp,libs/target/x86_64-unknown-linux-musl/release/embassy_container_init,$(DESTDIR)/usr/lib/startos/container/embassy_container_init.amd64)
$(call mkdir,$(DESTDIR)/usr/lib/startos/system-images)
$(call cp,system-images/compat/docker-images/$(ARCH).tar,$(DESTDIR)/usr/lib/startos/system-images/compat.tar)
$(call cp,system-images/utils/docker-images/$(ARCH).tar,$(DESTDIR)/usr/lib/startos/system-images/utils.tar)
$(call cp,system-images/binfmt/docker-images/$(ARCH).tar,$(DESTDIR)/usr/lib/startos/system-images/binfmt.tar)
update-overlay: $(ALL_TARGETS)
@echo "\033[33m!!! THIS WILL ONLY REFLASH YOUR DEVICE IN MEMORY !!!\033[0m"
@echo "\033[33mALL CHANGES WILL BE REVERTED IF YOU RESTART THE DEVICE\033[0m"
@if [ -z "$(REMOTE)" ]; then >&2 echo "Must specify REMOTE" && false; fi
@if [ "`ssh $(REMOTE) 'cat /usr/lib/startos/VERSION.txt'`" != "`cat ./VERSION.txt`" ]; then >&2 echo "StartOS requires migrations: update-overlay is unavailable." && false; fi
$(call ssh,"sudo systemctl stop startd")
$(MAKE) install REMOTE=$(REMOTE) SSHPASS=$(SSHPASS) PLATFORM=$(PLATFORM)
$(call ssh,"sudo systemctl start startd")
wormhole: backend/target/$(ARCH)-unknown-linux-gnu/release/startbox
@wormhole send backend/target/$(ARCH)-unknown-linux-gnu/release/startbox 2>&1 | awk -Winteractive '/wormhole receive/ { printf "sudo /usr/lib/startos/scripts/chroot-and-upgrade \"cd /usr/bin && rm startbox && wormhole receive --accept-file %s && chmod +x startbox\"\n", $$3 }'
update: $(ALL_TARGETS)
@if [ -z "$(REMOTE)" ]; then >&2 echo "Must specify REMOTE" && false; fi
$(call ssh,"sudo rsync -a --delete --force --info=progress2 /media/embassy/embassyfs/current/ /media/embassy/next/")
$(MAKE) install REMOTE=$(REMOTE) SSHPASS=$(SSHPASS) DESTDIR=/media/embassy/next PLATFORM=$(PLATFORM)
$(call ssh,'sudo NO_SYNC=1 /media/embassy/next/usr/lib/startos/scripts/chroot-and-upgrade "apt-get install -y $(shell cat ./build/lib/depends)"')
emulate-reflash: $(ALL_TARGETS)
@if [ -z "$(REMOTE)" ]; then >&2 echo "Must specify REMOTE" && false; fi
$(call ssh,"sudo rsync -a --delete --force --info=progress2 /media/embassy/embassyfs/current/ /media/embassy/next/")
$(MAKE) install REMOTE=$(REMOTE) SSHPASS=$(SSHPASS) DESTDIR=/media/embassy/next PLATFORM=$(PLATFORM)
$(call ssh,"sudo touch /media/embassy/config/upgrade && sudo rm -f /media/embassy/config/disk.guid && sudo sync && sudo reboot")
upload-ota: results/$(BASENAME).squashfs
TARGET=$(TARGET) KEY=$(KEY) ./upload-ota.sh
build/lib/depends build/lib/conflicts: build/dpkg-deps/*
build/dpkg-deps/generate.sh
system-images/compat/docker-images/$(ARCH).tar: $(COMPAT_SRC) backend/Cargo.lock | docker-buildx
cd system-images/compat && make docker-images/$(ARCH).tar && touch docker-images/$(ARCH).tar
system-images/utils/docker-images/$(ARCH).tar: $(UTILS_SRC) | docker-buildx
cd system-images/utils && make docker-images/$(ARCH).tar && touch docker-images/$(ARCH).tar
system-images/binfmt/docker-images/$(ARCH).tar: $(BINFMT_SRC) | docker-buildx
cd system-images/binfmt && make docker-images/$(ARCH).tar && touch docker-images/$(ARCH).tar
snapshots: libs/snapshot_creator/Cargo.toml
cd libs/ && ./build-v8-snapshot.sh
cd libs/ && ./build-arm-v8-snapshot.sh
$(EMBASSY_BINS): $(BACKEND_SRC) $(ENVIRONMENT_FILE) $(GIT_HASH_FILE) frontend/patchdb-ui-seed.json
cd backend && ARCH=$(ARCH) ./build-prod.sh
touch $(EMBASSY_BINS)
frontend/node_modules: frontend/package.json
npm --prefix frontend ci
frontend/dist/raw/ui: $(FRONTEND_UI_SRC) $(FRONTEND_SHARED_SRC)
npm --prefix frontend run build:ui
frontend/dist/raw/setup-wizard: $(FRONTEND_SETUP_WIZARD_SRC) $(FRONTEND_SHARED_SRC)
npm --prefix frontend run build:setup
frontend/dist/raw/diagnostic-ui: $(FRONTEND_DIAGNOSTIC_UI_SRC) $(FRONTEND_SHARED_SRC)
npm --prefix frontend run build:dui
frontend/dist/raw/install-wizard: $(FRONTEND_INSTALL_WIZARD_SRC) $(FRONTEND_SHARED_SRC)
npm --prefix frontend run build:install-wiz
frontend/dist/static: $(EMBASSY_UIS) $(ENVIRONMENT_FILE)
./compress-uis.sh
frontend/config.json: $(GIT_HASH_FILE) frontend/config-sample.json
jq '.useMocks = false' frontend/config-sample.json | jq '.gitHash = "$(shell cat GIT_HASH.txt)"' > frontend/config.json
frontend/patchdb-ui-seed.json: frontend/package.json
jq '."ack-welcome" = $(shell jq '.version' frontend/package.json)' frontend/patchdb-ui-seed.json > ui-seed.tmp
mv ui-seed.tmp frontend/patchdb-ui-seed.json
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
npm --prefix frontend run build:deps
# used by github actions
compiled-$(ARCH).tar: $(COMPILED_TARGETS) $(ENVIRONMENT_FILE) $(GIT_HASH_FILE) $(VERSION_FILE)
tar -cvf $@ $^
# 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/raw/ui
cargo-deps/aarch64-unknown-linux-gnu/release/pi-beep:
ARCH=aarch64 ./build-cargo-dep.sh pi-beep
cargo-deps/$(ARCH)-unknown-linux-gnu/release/tokio-console:
ARCH=$(ARCH) ./build-cargo-dep.sh tokio-console
lifeline: $(LIFELINE_RELEASE_SRC)

113
README.md
View File

@@ -1,84 +1,47 @@
<div align="center">
<img src="frontend/projects/shared/assets/img/icon.png" alt="StartOS Logo" width="16%" />
<h1 style="margin-top: 0;">StartOS</h1>
<a href="https://github.com/Start9Labs/start-os/releases">
<img alt="GitHub release (with filter)" src="https://img.shields.io/github/v/release/start9labs/start-os?logo=github">
</a>
<a href="https://github.com/Start9Labs/start-os/actions/workflows/startos-iso.yaml">
<img src="https://github.com/Start9Labs/start-os/actions/workflows/startos-iso.yaml/badge.svg">
</a>
<a href="https://heyapollo.com/product/startos">
<img alt="Static Badge" src="https://img.shields.io/badge/apollo-review%20%E2%AD%90%E2%AD%90%E2%AD%90%E2%AD%90%E2%AD%90%20-slateblue">
</a>
<a href="https://twitter.com/start9labs">
<img alt="X (formerly Twitter) Follow" src="https://img.shields.io/twitter/follow/start9labs">
</a>
<a href="https://mastodon.start9labs.com">
<img src="https://img.shields.io/mastodon/follow/000000001?domain=https%3A%2F%2Fmastodon.start9labs.com&label=Follow&style=social">
</a>
<a href="https://matrix.to/#/#community:matrix.start9labs.com">
<img alt="Static Badge" src="https://img.shields.io/badge/community-matrix-yellow?logo=matrix">
</a>
<a href="https://t.me/start9_labs">
<img alt="Static Badge" src="https://img.shields.io/badge/community-telegram-blue?logo=telegram">
</a>
<a href="https://docs.start9.com">
<img alt="Static Badge" src="https://img.shields.io/badge/docs-orange?label=%F0%9F%91%A4%20support">
</a>
<a href="https://matrix.to/#/#community-dev:matrix.start9labs.com">
<img alt="Static Badge" src="https://img.shields.io/badge/developer-matrix-darkcyan?logo=matrix">
</a>
<a href="https://start9.com">
<img alt="Website" src="https://img.shields.io/website?up_message=online&down_message=offline&url=https%3A%2F%2Fstart9.com&logo=website&label=%F0%9F%8C%90%20website">
</a>
</div>
<br />
<div align="center">
<h3>
Welcome to the era of Sovereign Computing
</h3>
<p>
StartOS is an open source Linux distribution optimized for running a personal server. It facilitates the discovery, installation, network configuration, service configuration, data backup, dependency management, and health monitoring of self-hosted software services.
</p>
</div>
<br />
<p align="center">
<img src="assets/StartOS.png" alt="StartOS" width="85%">
</p>
<br />
# 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=green&up_message=online&url=https%3A%2F%2Fstart9labs.com)](https://start9labs.com)
## Running StartOS
There are multiple ways to get started with StartOS:
[![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)
### 💰 Buy a Start9 server
This is the most convenient option. Simply [buy a server](https://store.start9.com) from Start9 and plug it in.
### _Anyone can do it. No one can stop it._ ###
### 👷 Build your own server
This option is easier than you might imagine, and there are 4 reasons why you might prefer it:
1. You already have hardware
1. You want to save on shipping costs
1. You prefer not to divulge your physical address
1. You just like building things
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.
To pursue this option, follow one of our [DIY guides](https://start9.com/latest/diy).
<img src="assets/eos.png" width="100%">
## ❤️ Contributing
There are multiple ways to contribute: work directly on StartOS, package a service for the marketplace, or help with documentation and guides. To learn more about contributing, see [here](https://start9.com/contribute/).
## :warning: 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 lose. Be #reckless at your own risk.
To report security issues, please email our security team - security@start9.com.
## Running EmbassyOS
There are multiple ways to obtain and begin using EmbassyOS.
## 🌎 Marketplace
There are dozens of services available for StartOS, and new ones are being added all the time. Check out the full list of available services [here](https://marketplace.start9.com/marketplace). To read more about the Marketplace ecosystem, check out this [blog post](https://blog.start9.com/start9-marketplace-strategy/)
### :moneybag: 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.
## 🖥️ User Interface Screenshots
### :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 just like building things.
<p align="center">
<img src="assets/registry.png" alt="StartOS Marketplace" width="49%">
<img src="assets/community.png" alt="StartOS Community Registry" width="49%">
<img src="assets/c-lightning.png" alt="StartOS NextCloud Service" width="49%">
<img src="assets/btcpay.png" alt="StartOS BTCPay Service" width="49%">
<img src="assets/nextcloud.png" alt="StartOS System Settings" width="49%">
<img src="assets/system.png" alt="StartOS System Settings" width="49%">
<img src="assets/welcome.png" alt="StartOS System Settings" width="49%">
<img src="assets/logs.png" alt="StartOS System Settings" width="49%">
</p>
To pursue this option, follow this [guide](https://docs.start9labs.com/getting-started/diy.html).
### :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/BuildGuide.md).
## :heart: Contributing
To contribute to the development of EmbassyOS, see [here](https://github.com/Start9Labs/embassy-os/blob/master/CONTRIBUTING.md).
## UI Screenshots
<img src="assets/ServicesRunning.png" alt="Embassy Services" width="100%"> | <img src="assets/ServiceDetails.png" alt="Service Details" width="100%">
--- | ---
<img src="assets/Embassy.png" alt="EmbassyOS" width="100%"> | <img src="assets/Marketplace.png" alt="Marketplace" width="100%">

40
agent/.gitignore vendored Normal file
View File

@@ -0,0 +1,40 @@
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
\#*
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

252
agent/.stylish-haskell.yaml Normal file
View File

@@ -0,0 +1,252 @@
# 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

12
agent/Changelog.md Normal file
View File

@@ -0,0 +1,12 @@
# 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

7
agent/README.md Normal file
View File

@@ -0,0 +1,7 @@
# 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

3
agent/TODO.md Normal file
View File

@@ -0,0 +1,3 @@
* 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.

View File

@@ -0,0 +1,519 @@
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.34.4.
--
-- see: https://github.com/sol/hpack
name: ambassador-agent
version: 0.2.14
build-type: Simple
extra-source-files:
./migrations/0.1.0::0.1.0
./migrations/0.1.0::0.1.1
./migrations/0.1.1::0.1.2
./migrations/0.1.2::0.1.3
./migrations/0.1.3::0.1.4
./migrations/0.1.4::0.1.5
./migrations/0.1.5::0.2.0
./migrations/0.2.0::0.2.1
./migrations/0.2.10::0.2.11
./migrations/0.2.11::0.2.12
./migrations/0.2.12::0.2.13
./migrations/0.2.13::0.2.14
./migrations/0.2.1::0.2.2
./migrations/0.2.2::0.2.3
./migrations/0.2.3::0.2.4
./migrations/0.2.4::0.2.5
./migrations/0.2.5::0.2.6
./migrations/0.2.6::0.2.7
./migrations/0.2.7::0.2.8
./migrations/0.2.8::0.2.9
./migrations/0.2.9::0.2.10
flag dev
description: Turn on development settings, like auto-reload templates.
manual: False
default: False
flag disable-auth
description: disable authorization checks
manual: False
default: False
flag library-only
description: Build for use with "yesod devel"
manual: False
default: False
library
exposed-modules:
Application
Auth
Constants
Daemon.AppNotifications
Daemon.RefreshProcDev
Daemon.SslRenew
Daemon.TorHealth
Daemon.ZeroConf
Foundation
Handler.Apps
Handler.Authenticate
Handler.Backups
Handler.Hosts
Handler.Icons
Handler.Login
Handler.Network
Handler.Notifications
Handler.PasswordUpdate
Handler.PowerOff
Handler.Register
Handler.Register.Nginx
Handler.Register.Tor
Handler.SelfUpdate
Handler.SshKeys
Handler.Status
Handler.Tor
Handler.Types.Apps
Handler.Types.HmacSig
Handler.Types.Hosts
Handler.Types.Metrics
Handler.Types.Parse
Handler.Types.Register
Handler.Types.V0.Base
Handler.Types.V0.Specs
Handler.Types.V0.Ssh
Handler.Types.V0.Wifi
Handler.Util
Handler.V0
Handler.Wifi
Lib.Algebra.Domain.AppMgr
Lib.Algebra.Domain.AppMgr.TH
Lib.Algebra.Domain.AppMgr.Types
Lib.Algebra.State.RegistryUrl
Lib.Avahi
Lib.Background
Lib.ClientManifest
Lib.Crypto
Lib.Database
Lib.Error
Lib.External.AppManifest
Lib.External.AppMgr
Lib.External.Metrics.Df
Lib.External.Metrics.Iotop
Lib.External.Metrics.ProcDev
Lib.External.Metrics.Temperature
Lib.External.Metrics.Top
Lib.External.Metrics.Types
Lib.External.Registry
Lib.External.Specs.Common
Lib.External.Specs.CPU
Lib.External.Specs.Memory
Lib.External.Util
Lib.External.WpaSupplicant
Lib.IconCache
Lib.Metrics
Lib.Migration
Lib.Notifications
Lib.Password
Lib.ProductKey
Lib.SelfUpdate
Lib.Sound
Lib.Ssh
Lib.Ssl
Lib.Synchronizers
Lib.SystemCtl
Lib.SystemPaths
Lib.Tor
Lib.TyFam.ConditionalData
Lib.Types.Core
Lib.Types.Emver
Lib.Types.Emver.Orphans
Lib.Types.NetAddress
Lib.Types.ServerApp
Lib.Types.Url
Lib.WebServer
Model
Orphans.Digest
Orphans.UUID
Settings
Startlude
Startlude.ByteStream
Startlude.ByteStream.Char8
Util.Conduit
Util.File
Util.Function
Util.Text
other-modules:
Paths_ambassador_agent
hs-source-dirs:
src
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
build-depends:
aeson
, aeson-flatten
, attoparsec
, base >=4.9.1.0 && <5
, 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
, regex-compat
, resourcet
, 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
, unliftio-core
, unordered-containers
, uuid
, wai
, wai-cors
, wai-extra
, warp
, yaml
, yesod
, yesod-auth
, yesod-core
, yesod-form
, yesod-persistent
if (flag(dev)) || (flag(library-only))
ghc-options: -Wall -Wunused-packages -fwarn-tabs -O0 -fdefer-typed-holes
cpp-options: -DDEVELOPMENT
else
ghc-options: -Wall -Wunused-packages -fwarn-tabs -O2 -fdefer-typed-holes
if (flag(disable-auth))
cpp-options: -DDISABLE_AUTH
default-language: Haskell2010
executable agent
main-is: main.hs
hs-source-dirs:
app
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
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fdefer-typed-holes
build-depends:
aeson
, aeson-flatten
, ambassador-agent
, attoparsec
, base >=4.9.1.0 && <5
, 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
, regex-compat
, resourcet
, 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
, unliftio-core
, unordered-containers
, uuid
, wai
, wai-cors
, wai-extra
, warp
, yaml
, yesod
, yesod-auth
, yesod-core
, yesod-form
, yesod-persistent
if flag(library-only)
buildable: False
default-language: Haskell2010
test-suite agent-test
type: exitcode-stdio-1.0
main-is: Main.hs
other-modules:
ChecklistSpec
Lib.External.AppManifestSpec
Lib.SoundSpec
Lib.Types.EmverProp
Live.Metrics
Live.Serialize
Spec
hs-source-dirs:
test
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
ghc-options: -Wall -fdefer-typed-holes
build-depends:
aeson
, aeson-flatten
, ambassador-agent
, attoparsec
, base >=4.9.1.0 && <5
, 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
, hedgehog
, hspec >=2.0.0
, hspec-expectations
, 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
, random
, regex-compat
, resourcet
, 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
, unliftio-core
, unordered-containers
, uuid
, wai
, wai-cors
, wai-extra
, warp
, yaml
, yesod
, yesod-auth
, yesod-core
, yesod-form
, yesod-persistent
, yesod-test
default-language: Haskell2010

5
agent/app/main.hs Normal file
View File

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

60
agent/brittany.yaml Normal file
View File

@@ -0,0 +1,60 @@
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

6
agent/build.sh Executable file
View File

@@ -0,0 +1,6 @@
#!/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

23
agent/cabal.project Normal file
View File

@@ -0,0 +1,23 @@
-- Generated by stackage-to-hackage
index-state: 2021-04-26T18:08:38Z
with-compiler: ghc-8.10.2
packages:
./
source-repository-package
type: git
location: https://github.com/ProofOfKeags/persistent.git
tag: 3b52b13d9ce79cdef14bb1c37cc527657a529462
subdir: persistent-sqlite
allow-older: *
allow-newer: *
package *
ghc-options: -haddock
package ambassador-agent
ghc-options: -fwrite-ide-info

2513
agent/cabal.project.freeze Normal file

File diff suppressed because it is too large Load Diff

View File

@@ -0,0 +1,14 @@
[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

View File

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

29
agent/config/nginx.conf Normal file
View File

@@ -0,0 +1,29 @@
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/*;
}

View File

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

View File

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

61
agent/config/routes Normal file
View File

@@ -0,0 +1,61 @@
/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

37
agent/config/settings.yml Normal file
View File

@@ -0,0 +1,37 @@
# 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.14"
#analytics: UA-YOURCODE

5
agent/config/torrc Normal file
View File

@@ -0,0 +1,5 @@
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

13
agent/hie.yaml Normal file
View File

@@ -0,0 +1,13 @@
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"

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

185
agent/package.yaml Normal file
View File

@@ -0,0 +1,185 @@
name: ambassador-agent
version: 0.2.14
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
extra-source-files: ./migrations/*

247
agent/src/Application.hs Normal file
View File

@@ -0,0 +1,247 @@
{-# 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

19
agent/src/Auth.hs Normal file
View File

@@ -0,0 +1,19 @@
{-# 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
|]

16
agent/src/Constants.hs Normal file
View File

@@ -0,0 +1,16 @@
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

View File

@@ -0,0 +1,48 @@
{-# 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 ()

View File

@@ -0,0 +1,20 @@
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)

View File

@@ -0,0 +1,83 @@
{-# 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

View File

@@ -0,0 +1,50 @@
{-# 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

View File

@@ -0,0 +1,65 @@
{-# 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'

226
agent/src/Foundation.hs Normal file
View File

@@ -0,0 +1,226 @@
{-# 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
[auth] | auth == "auth" -> m
(_:ssh:_) | ssh == "sshKeys" -> 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

839
agent/src/Handler/Apps.hs Normal file
View File

@@ -0,0 +1,839 @@
{-# 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)
( Labelled
"lanThread"
(ReaderT (MVar ThreadId))
(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 (appLanThread ctx)
. runLabelled @"lanThread"
. 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.AppIndexRes apps, serverApps) <- LAsync.concurrently Reg.getAppIndex (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.AppIndexRes storeApps, serverApps), AppManifest.AppManifest { appManifestLicenseName, appManifestLicenseLink }) <-
LAsync.concurrently (LAsync.concurrently Reg.getAppIndex (AppMgr2.list [AppMgr2.flags|-s -d|]))
(Reg.getAppManifest appId)
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))
, appAvailableFullLicenseName = appManifestLicenseName
, appAvailableFullLicenseLink = appManifestLicenseLink
, 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)
, appInstalledFullLicenseName = Nothing
, appInstalledFullLicenseLink = Nothing
, 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.getAppIndex
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.AppIndexRes 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)
, appInstalledFullLicenseName = AppManifest.appManifestLicenseName manifest
, appInstalledFullLicenseLink = AppManifest.appManifestLicenseLink manifest
, 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
, HasLabelled "lanThread" (Reader (MVar ThreadId)) 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 "lanThread" (Reader (MVar ThreadId)) 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.AppIndexRes storeApps <- Reg.getAppIndex
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"

View File

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

View File

@@ -0,0 +1,244 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
module Handler.Backups where
import Startlude hiding ( Reader
, ask
, runReader
)
import Control.Carrier.Error.Church
import Control.Carrier.Lift
import Control.Carrier.Reader ( runReader )
import Control.Effect.Labelled hiding ( Handler )
import Control.Effect.Reader.Labelled
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 Control.Concurrent.STM
import Exinst
import Foundation
import Handler.Network
import Handler.Util
import qualified Lib.Algebra.Domain.AppMgr as AppMgr2
import Lib.Background
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
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
& runLabelled @"lanThread"
& runReader appLanThread
& 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
, HasLabelled "lanThread" (Reader (MVar ThreadId)) sig m
, Has (Error S9Error) sig m
, Has AppMgr2.AppMgr sig m
, MonadIO m
)
=> AppId
-> RestoreBackupReq
-> m ()
restoreBackupLogic appId RestoreBackupReq {..} = do
lanThread <- ask @"lanThread"
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
resetRes <- runExceptT @S9Error $ runReader lanThread . runLabelled @"lanThread" $ postResetLanLogic
case resetRes of
Left _ -> pure () -- temporarily forbidden is the only possible thing here so ignore it
Right () -> pure ()
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]

View File

@@ -0,0 +1,56 @@
{-# 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

106
agent/src/Handler/Icons.hs Normal file
View File

@@ -0,0 +1,106 @@
{-# 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 Control.Carrier.Reader hiding ( asks )
import Control.Concurrent.STM ( modifyTVar
, readTVarIO
)
import Control.Effect.Labelled ( runLabelled )
import Crypto.Hash.Conduit ( hashFile )
import qualified Data.HashMap.Strict as HM
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.Emver
import Lib.Types.ServerApp
import Settings
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.getAppIndex >>= \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.getAppIndex >>= \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

View File

@@ -0,0 +1,75 @@
{-# 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'

View File

@@ -0,0 +1,36 @@
module Handler.Network where
import Startlude hiding ( Reader
, ask
, asks
, runReader
)
import Control.Carrier.Lift ( runM )
import Control.Effect.Error
import Lib.Error
import Yesod.Core ( getYesod )
import Control.Carrier.Reader ( runReader )
import Control.Effect.Labelled ( runLabelled )
import Control.Effect.Reader.Labelled
import Foundation
import qualified Lib.Algebra.Domain.AppMgr as AppMgr2
import Lib.Types.Core
postResetLanR :: Handler ()
postResetLanR = do
ctx <- getYesod
runM . handleS9ErrC . runReader (appLanThread ctx) . runLabelled @"lanThread" $ postResetLanLogic
postResetLanLogic :: (MonadIO m, HasLabelled "lanThread" (Reader (MVar ThreadId)) sig m, Has (Error S9Error) sig m)
=> m ()
postResetLanLogic = do
threadVar <- ask @"lanThread"
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

View File

@@ -0,0 +1,32 @@
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)

View File

@@ -0,0 +1,36 @@
{-# 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')

View File

@@ -0,0 +1,28 @@
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 ()

View File

@@ -0,0 +1,166 @@
{-# 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 { .. }

View File

@@ -0,0 +1,158 @@
{-# 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

View File

@@ -0,0 +1,44 @@
{-# 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

View File

@@ -0,0 +1,51 @@
{-# 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

View File

@@ -0,0 +1,39 @@
{-# 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

View File

@@ -0,0 +1,81 @@
{-# 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"

24
agent/src/Handler/Tor.hs Normal file
View File

@@ -0,0 +1,24 @@
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

View File

@@ -0,0 +1,213 @@
{-# 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
, appAvailableFullLicenseName :: Maybe Text
, appAvailableFullLicenseLink :: Maybe Text
, 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
[ "licenseName" .= appAvailableFullLicenseName
, "licenseLink" .= appAvailableFullLicenseLink
, "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
, appInstalledFullLicenseName :: Maybe Text
, appInstalledFullLicenseLink :: Maybe Text
, 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
, "licenseName" .= appInstalledFullLicenseName
, "licenseLink" .= appInstalledFullLicenseLink
, "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]

View File

@@ -0,0 +1,28 @@
{-# 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

View File

@@ -0,0 +1,44 @@
{-# 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

View File

@@ -0,0 +1,26 @@
{-# 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 }

View File

@@ -0,0 +1,32 @@
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

View File

@@ -0,0 +1,65 @@
{-# 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

View File

@@ -0,0 +1,82 @@
{-# 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

View File

@@ -0,0 +1,48 @@
{-# 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

View File

@@ -0,0 +1,25 @@
{-# 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

View File

@@ -0,0 +1,32 @@
{-# 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

16
agent/src/Handler/Util.hs Normal file
View File

@@ -0,0 +1,16 @@
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

144
agent/src/Handler/V0.hs Normal file
View File

@@ -0,0 +1,144 @@
{-# 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

76
agent/src/Handler/Wifi.hs Normal file
View File

@@ -0,0 +1,76 @@
{-# 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

View File

@@ -0,0 +1,483 @@
{-# 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 Control.Monad.Base ( MonadBase(..) )
import Control.Monad.Fail ( MonadFail(fail) )
import Control.Monad.Trans.Class ( MonadTrans )
import Control.Monad.Trans.Control ( MonadBaseControl(..)
, MonadTransControl(..)
, defaultLiftBaseWith
, defaultRestoreM
)
import Control.Monad.Trans.Resource ( MonadResource(..) )
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy as LBS
import Data.String.Interpolate.IsString
( i )
import Lib.Algebra.Domain.AppMgr.TH
import Lib.Algebra.Domain.AppMgr.Types
import Lib.Error
import qualified Lib.External.AppManifest as Manifest
import Lib.TyFam.ConditionalData
import Lib.Types.Core ( AppContainerStatus(..)
, AppId(..)
)
import Lib.Types.Emver
import Lib.Types.NetAddress
import System.Process
import System.Process.Typed
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
let runIt retryCount = do
(ec, out) <- readProcessInheritStderr "appmgr" args ""
case ec of
ExitSuccess -> case withSingI flags $ eitherDecodeStrict out of
Left e -> throwError $ AppMgrParseE (toS $ String.unwords args) (decodeUtf8 out) e
Right x -> pure $ ctx $> x
ExitFailure 6 ->
if retryCount > 0 then runIt (retryCount - 1) else throwError $ AppMgrE "list" 6
ExitFailure n -> throwError $ AppMgrE "list" n
runIt (1 :: Word) -- with 1 retry
(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)

View File

@@ -0,0 +1,43 @@
{-# 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"
}

View File

@@ -0,0 +1,29 @@
{-# 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) |])

View File

@@ -0,0 +1,84 @@
{-# 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

68
agent/src/Lib/Avahi.hs Normal file
View File

@@ -0,0 +1,68 @@
{-# 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

View File

@@ -0,0 +1,46 @@
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

Some files were not shown because too many files have changed in this diff Show More