0.2.5 initial commit

Makefile incomplete

.gitignore

@@ -0,0 +1,3 @@
+/*.img
+/buster.zip
+/product_key

LICENSE.md

@@ -0,0 +1,18 @@
+# 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**
+    a. "Licensor" means the copyright owner, Start9 Labs, Inc, or its successor(s) in interest, or a future assignee of the copyright.
+    b. "Source Code" means the code made available to you by the Licensor pursuant to the terms of this license and any derivative works based thereon.
+    c. "Object Code" means any non-source form of the Source Code, including the machine-language output by a compiler or assembler.
+    d. "Distribute" means to convey or to publish and generally has the same meaning here as under U.S. Copyright law.
+    e. "Personal Use" means accessing, copying, reviewing, auditing, running, testing, or modifying the Source Code.
+2. **Grant of Rights**
+    a. Subject to the terms of this license, the Licensor grants you, the licensee, a non-exclusive, worldwide, royalty-free copyright license to the Source Code for Personal Use only.
+    b. Subject to the terms of this license, the Licensor grants you, the licensee, the right to Distribute the Source Code or modifications to the Source Code.
+    c. Distributing the Object Code, or any Object Code created based on your modifications to the Source Code, is not permitted under the terms of this license without express written consent of the Licensor.
+    d. If you Distribute the Source Code, or if permission is 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 Source Code or Object Code 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.
+    e. The terms of this license will apply to anyone who comes into possession of a copy of the Source Code or Object Code, and any modifications or derivative works based thereon, made by anyone.
+3. **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 Source Code or Object Code.
+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.

Makefile

@@ -0,0 +1,22 @@
+APPMGR_SRC := $(shell find appmgr/src) appmgr/Cargo.toml appmgr/Cargo.lock
+
+.DELETE_ON_ERROR:
+
+all: embassy.img
+
+embassy.img: buster.img product_key appmgr/target/armv7-unknown-linux-musleabihf/release/appmgr ui/www agent/dist/agent agent/config/agent.service
+	./make_image.sh
+
+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
+
+product_key:
+	echo "X\c" > product_key
+	cat /dev/random | base32 | head -c11 | tr '[:upper:]' '[:lower:]' >> product_key
+
+appmgr/target/armv7-unknown-linux-musleabihf/release/appmgr: $(APPMGR_SRC)
+	docker run --rm -it -v ~/.cargo/registry:/root/.cargo/registry -v "$(shell pwd)"/appmgr:/home/rust/src start9/rust-arm-cross:latest cargo build --release --features=production
+	docker run --rm -it -v ~/.cargo/registry:/root/.cargo/registry -v "$(shell pwd)"/appmgr:/home/rust/src start9/rust-arm-cross:latest arm-linux-gnueabi-strip target/armv7-unknown-linux-gnueabihf/release/appmgr

README.md

@@ -0,0 +1 @@
+# Embassy OS

agent/.gitignore

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

agent/.stylish-haskell.yaml

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

agent/Changelog.md

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

agent/README.md

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

agent/TODO.md

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

agent/app/main.hs

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

agent/brittany.yaml

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

agent/build.sh

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

agent/config/agent.service

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

agent/config/journald.conf

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

agent/config/nginx.conf

@@ -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/*;
+}

agent/config/routes

@@ -0,0 +1,54 @@
+/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/specs                             SpecsR                   GET
+/v0/metrics                           MetricsR                 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/disks                             ListDisksR               GET
+
+/v0/update                            UpdateAgentR             POST
+/v0/wifi                              WifiR                    GET POST
+/v0/wifi/#Text                        WifiBySsidR              POST DELETE
+
+/v0/notifications                     NotificationsR           GET
+/v0/notifications/#UUID               NotificationR            DELETE
+
+/v0/shutdown                          ShutdownR                POST
+/v0/restart                           RestartR                 POST
+
+/v0/register                          RegisterR                POST               !noAuth
+/v0/hosts                             HostsR                   GET                !noAuth
+/v0/certificate                       CertificateR             GET

agent/config/settings.yml

@@ -0,0 +1,39 @@
+# 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
+cors-override-star: "_env:CORS_OVERRIDE_STAR:"
+filesystem-base: "_env:FILESYSTEM_BASE:/"
+database:
+  database: "start9_agent.sqlite3"
+  poolsize: "_env:YESOD_SQLITE_POOLSIZE:10"
+
+app-mgr-version-spec: "=0.2.5"
+
+#analytics: UA-YOURCODE

agent/config/torrc

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

agent/hie.yaml

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

agent/migrations/0.1.0::0.1.0

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

agent/migrations/0.1.0::0.1.1

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

agent/migrations/0.1.1::0.1.2

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

agent/migrations/0.1.2::0.1.3

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

agent/migrations/0.1.3::0.1.4

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

agent/migrations/0.1.4::0.1.5

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

agent/migrations/0.1.5::0.2.0

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

agent/migrations/0.2.0::0.2.1

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

agent/migrations/0.2.1::0.2.2

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

agent/migrations/0.2.2::0.2.3

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

agent/migrations/0.2.3::0.2.4

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

agent/migrations/0.2.4::0.2.5

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

agent/package.yaml

@@ -0,0 +1,181 @@
+name: ambassador-agent
+version: 0.2.5
+
+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
+- 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
+- lens
+- lens-aeson
+- lifted-async
+- lifted-base
+- memory
+- mime-types
+- monad-control
+- monad-logger
+- persistent
+- persistent-sqlite
+- persistent-template
+- process
+- process-extras
+- protolude
+- resourcet
+- regex-compat # TODO: trim this dep
+- shell-conduit
+- singletons
+- stm
+- streaming
+- streaming-bytestring
+- streaming-conduit
+- streaming-utils
+- tar-conduit
+- template-haskell
+- text >=0.11 && <2.0
+- time
+- transformers
+- transformers-base
+- typed-process
+- unix
+- unliftio # TODO: trim this dep
+- unliftio-core # TODO: trim this dep
+- unordered-containers
+- uuid
+- wai
+- wai-cors
+- wai-extra
+- warp
+- yaml
+- yesod
+- yesod-auth
+- yesod-core
+- yesod-form
+- yesod-persistent
+
+flags:
+  library-only:
+    manual: false
+    default: false
+    description: Build for use with "yesod devel"
+  dev:
+    manual: false
+    default: false
+    description: Turn on development settings, like auto-reload templates.
+  disable-auth:
+    manual: false
+    default: false
+    description: disable authorization checks
+library:
+  source-dirs: src
+  when:
+  - condition: (flag(dev)) || (flag(library-only))
+    then:
+      cpp-options: -DDEVELOPMENT
+      ghc-options:
+      - -Wall
+      - -Wunused-packages
+      - -fwarn-tabs
+      - -O0
+      - -fdefer-typed-holes
+    else:
+      ghc-options:
+      - -Wall
+      - -Wunused-packages
+      - -fwarn-tabs
+      - -O2
+      - -fdefer-typed-holes
+  - condition: (flag(disable-auth))
+    cpp-options: -DDISABLE_AUTH
+tests:
+  agent-test:
+    source-dirs: test
+    main: Main.hs
+    ghc-options:
+    - -Wall
+    - -fdefer-typed-holes
+    dependencies:
+    - ambassador-agent
+    - hspec >=2.0.0
+    - hspec-expectations
+    - hedgehog
+    - yesod-test
+    - random
+    when:
+    - condition: false
+      other-modules: Paths_ambassador_agent
+
+executables:
+  agent:
+    source-dirs: app
+    main: main.hs
+    ghc-options:
+    - -Wall
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    - -fdefer-typed-holes
+    dependencies:
+    - ambassador-agent
+    when:
+    - buildable: false
+      condition: flag(library-only)
+    - condition: false
+      other-modules: Paths_ambassador_agent

agent/src/Application.hs

@@ -0,0 +1,227 @@
+{-# 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
+    )
+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           Daemon.ZeroConf
+import           Foundation
+import           Lib.Algebra.State.RegistryUrl
+import           Lib.Database
+import           Lib.External.Metrics.ProcDev
+import           Lib.SelfUpdate
+import           Lib.Sound
+import           Lib.SystemPaths
+import           Lib.WebServer
+import           Model
+import           Settings
+import Lib.Background
+
+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
+            exitWith ExitSuccess
+        ["--version"] -> do
+            putStrLn @Text (show agentVersion)
+            exitWith 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
+    appWebServerThreadId        <- newIORef Nothing
+    appSelfUpdateSpecification  <- newEmptyMVar
+    appIsUpdating               <- newIORef Nothing
+    appIsUpdateFailed           <- newIORef Nothing
+    appBackgroundJobs           <- newTVarIO (JobCache HM.empty)
+    def                         <- getDefaultProcDevMetrics
+    appProcDevMomentCache       <- newIORef (now, mempty, def)
+
+    -- 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"
+
+        -- 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
+
+--------------------------------------------------------------
+-- Functions for DevelMain.hs (a way to run the AgentCtx from GHCi)
+--------------------------------------------------------------
+
+getApplicationRepl :: IO (Int, AgentCtx, Application)
+getApplicationRepl = do
+    foundation <- getAppSettings >>= makeFoundation
+    wsettings  <- getDevSettings $ warpSettings foundation
+    app1       <- makeApplication foundation
+    return (getPort wsettings, foundation, app1)
+
+getAgentCtx :: IO AgentCtx
+getAgentCtx = getAppSettings >>= makeFoundation
+
+---------------------------------------------
+-- Functions for use in development with GHCi
+---------------------------------------------
+
+-- | Run a handler
+handler :: Handler a -> IO a
+handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h
+
+-- | Run DB queries
+runDb :: ReaderT SqlBackend Handler a -> IO a
+runDb = handler . runDB
+

agent/src/Auth.hs

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

agent/src/Constants.hs

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

agent/src/Daemon/AppNotifications.hs

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

agent/src/Daemon/RefreshProcDev.hs

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

agent/src/Daemon/ZeroConf.hs

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

agent/src/Foundation.hs

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

agent/src/Handler/Apps.hs

@@ -0,0 +1,760 @@
+{-# LANGUAGE NamedFieldPuns   #-}
+{-# LANGUAGE QuasiQuotes      #-}
+{-# LANGUAGE RecordWildCards  #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell  #-}
+{-# LANGUAGE TupleSections    #-}
+{-# LANGUAGE TypeApplications #-}
+module Handler.Apps where
+
+import           Startlude               hiding ( modify
+                                                , execState
+                                                , asks
+                                                , Reader
+                                                , runReader
+                                                , catchError
+                                                , forkFinally
+                                                , empty
+                                                )
+
+import           Control.Carrier.Reader
+import           Control.Carrier.Error.Church
+import           Control.Carrier.Lift
+import qualified Control.Concurrent.Async.Lifted
+                                               as LAsync
+import qualified Control.Concurrent.Lifted     as Lifted
+import qualified Control.Exception.Lifted      as Lifted
+import           Control.Concurrent.STM.TVar
+import           Control.Effect.Empty    hiding ( guard )
+import           Control.Effect.Labelled        ( HasLabelled
+                                                , Labelled
+                                                , runLabelled
+                                                )
+import           Control.Lens            hiding ( (??) )
+import           Control.Monad.Logger
+import           Control.Monad.Trans.Control    ( MonadBaseControl )
+import           Data.Aeson
+import           Data.Aeson.Lens
+import qualified Data.ByteString.Lazy          as LBS
+import           Data.IORef
+import qualified Data.HashMap.Lazy             as HML
+import qualified Data.HashMap.Strict           as HM
+import qualified Data.List.NonEmpty            as NE
+import           Data.Singletons
+import           Data.Singletons.Prelude.Bool   ( SBool(..)
+                                                , If
+                                                )
+import           Data.Singletons.Prelude.List   ( Elem )
+
+import           Database.Persist
+import           Database.Persist.Sql           ( ConnectionPool )
+import           Database.Persist.Sqlite        ( runSqlPool )
+import           Exinst
+import           Network.HTTP.Types
+import           Yesod.Core.Content
+import           Yesod.Core.Json
+import           Yesod.Core.Handler      hiding ( cached )
+import           Yesod.Core.Types               ( JSONResponse(..) )
+import           Yesod.Persist.Core
+
+import           Foundation
+import           Handler.Backups
+import           Handler.Icons
+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.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.ServerApp
+import           Model
+import           Settings
+import           Crypto.Hash
+
+pureLog :: Show a => a -> Handler a
+pureLog = liftA2 (*>) ($logInfo . show) pure
+
+logRet :: ToJSON a => Handler a -> Handler a
+logRet = (>>= liftA2 (*>) ($logInfo . decodeUtf8 . LBS.toStrict . encode) pure)
+
+mkAppStatus :: HM.HashMap AppId (BackupJobType, a) -> AppId -> AppContainerStatus -> AppStatus
+mkAppStatus hm appId status = case HM.lookup appId hm of
+    Nothing                 -> AppStatusAppMgr status
+    Just (CreateBackup , _) -> AppStatusTmp CreatingBackup
+    Just (RestoreBackup, _) -> AppStatusTmp RestoringBackup
+
+
+type AllEffects m
+    = AppMgr2.AppMgrCliC
+          ( RegistryUrlIOC
+                ( Labelled
+                      "iconTagCache"
+                      (ReaderT (TVar (HM.HashMap AppId (Digest MD5))))
+                      ( Labelled
+                            "filesystemBase"
+                            (ReaderT Text)
+                            ( Labelled
+                                  "databaseConnection"
+                                  (ReaderT ConnectionPool)
+                                  (ReaderT AgentCtx (ErrorC S9Error (LiftC m)))
+                            )
+                      )
+                )
+          )
+
+intoHandler :: AllEffects Handler x -> Handler x
+intoHandler m = do
+    ctx <- getYesod
+    let fsbase = appFilesystemBase . appSettings $ ctx
+    runM
+        . handleS9ErrC
+        . flip runReaderT ctx
+        . flip runReaderT (appConnPool ctx)
+        . runLabelled @"databaseConnection"
+        . flip runReaderT fsbase
+        . runLabelled @"filesystemBase"
+        . flip runReaderT (appIconTags ctx)
+        . runLabelled @"iconTagCache"
+        . runRegistryUrlIOC
+        . AppMgr2.runAppMgrCliC
+        $ m
+{-# INLINE intoHandler #-}
+
+-- TODO nasty. Also, note that if AppMgr.getInstalledApp fails for any app we will not return available apps res.
+getAvailableAppsR :: Handler (JSONResponse [AppAvailablePreview])
+getAvailableAppsR = disableEndpointOnFailedUpdate . intoHandler $ JSONResponse <$> getAvailableAppsLogic
+
+getAvailableAppsLogic :: ( Has (Reader AgentCtx) sig m
+                         , Has (Error S9Error) sig m
+                         , Has RegistryUrl sig m
+                         , Has AppMgr2.AppMgr sig m
+                         , MonadIO m
+                         , MonadBaseControl IO m
+                         )
+                      => m [AppAvailablePreview]
+getAvailableAppsLogic = do
+    jobCache <- asks appBackgroundJobs >>= liftIO . readTVarIO
+    let installCache = inspect SInstalling jobCache
+    (Reg.AppManifestRes apps, serverApps) <- LAsync.concurrently Reg.getAppManifest
+                                                                 (AppMgr2.list [AppMgr2.flags|-s -d|])
+    let remapped = remapAppMgrInfo jobCache serverApps
+    pure $ foreach apps $ \app@StoreApp { storeAppId } ->
+        let installing =
+                (   (storeAppVersionInfoVersion . snd . installInfo &&& const (AppStatusTmp Installing))
+                .   fst
+                <$> HM.lookup storeAppId installCache
+                )
+            installed = ((view _2 &&& view _1) <$> HM.lookup storeAppId remapped)
+        in  storeAppToAvailablePreview app $ installing <|> installed
+
+getAvailableAppByIdR :: AppId -> Handler (JSONResponse AppAvailableFull)
+getAvailableAppByIdR appId =
+    disableEndpointOnFailedUpdate . intoHandler $ JSONResponse <$> getAvailableAppByIdLogic appId
+
+getAvailableAppByIdLogic :: ( Has (Reader AgentCtx) sig m
+                            , Has (Error S9Error) sig m
+                            , Has RegistryUrl sig m
+                            , Has AppMgr2.AppMgr sig m
+                            , MonadIO m
+                            , MonadBaseControl IO m
+                            )
+                         => AppId
+                         -> m AppAvailableFull
+getAvailableAppByIdLogic appId = do
+    let storeAppId' = storeAppId
+    jobCache <- asks appBackgroundJobs >>= liftIO . readTVarIO
+    let installCache = inspect SInstalling jobCache
+    (Reg.AppManifestRes storeApps, serverApps) <- LAsync.concurrently Reg.getAppManifest
+                                                                      (AppMgr2.list [AppMgr2.flags|-s -d|])
+    StoreApp {..} <- pure (find ((== appId) . storeAppId) storeApps) `orThrowM` NotFoundE "appId" (show appId)
+    let remapped = remapAppMgrInfo jobCache serverApps
+    let installingInfo =
+            (   (storeAppVersionInfoVersion . snd . installInfo &&& const (AppStatusTmp Installing))
+                .   fst
+                <$> HM.lookup appId installCache
+                )
+                <|> ((view _2 &&& view _1) <$> HM.lookup appId remapped)
+    let latest = extract storeAppVersions
+    dependencies <- AppMgr2.checkDependencies (AppMgr2.LocalOnly False)
+                                              appId
+                                              (Just . exactly $ storeAppVersionInfoVersion latest)
+    enrichedDeps <- maybe (throwError (NotFoundE "dependencyId for" (show appId))) pure $ flip
+        HML.traverseWithKey
+        dependencies
+        \depId depInfo ->
+            let
+                base = storeAppToAppBase <$> find ((== depId) . storeAppId') storeApps
+                status =
+                    (HM.lookup depId installCache $> AppStatusTmp Installing) <|> (view _1 <$> HM.lookup depId remapped)
+            in
+                (, status, depInfo) <$> base
+    let dependencyRequirements = fmap (dependencyInfoToDependencyRequirement (AsInstalled SFalse)) enrichedDeps
+    pure AppAvailableFull
+        { appAvailableFullBase                   = AppBase
+                                                       appId
+                                                       storeAppTitle
+                                                       (storeIconUrl appId (storeAppVersionInfoVersion $ extract storeAppVersions))
+        , appAvailableFullInstallInfo            = installingInfo
+        , appAvailableFullVersionLatest          = storeAppVersionInfoVersion latest
+        , appAvailableFullDescriptionShort       = storeAppDescriptionShort
+        , appAvailableFullDescriptionLong        = storeAppDescriptionLong
+        , appAvailableFullReleaseNotes           = storeAppVersionInfoReleaseNotes latest
+        , appAvailableFullDependencyRequirements = HM.elems dependencyRequirements
+        , appAvailableFullVersions               = storeAppVersionInfoVersion <$> storeAppVersions
+        }
+
+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|]
+    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
+                }
+        installedPreviews = flip
+            HML.mapWithKey
+            remapped
+            \appId (s, v, AppMgr2.InfoRes {..}) -> AppInstalledPreview
+                { appInstalledPreviewBase             = AppBase appId infoResTitle (iconUrl appId v)
+                , appInstalledPreviewStatus           = s
+                , appInstalledPreviewVersionInstalled = v
+                , appInstalledPreviewTorAddress       = infoResTorAddress
+                }
+
+    pure $ HML.elems $ HML.union installingPreviews installedPreviews
+
+getInstalledAppByIdR :: AppId -> Handler (JSONResponse AppInstalledFull)
+getInstalledAppByIdR appId =
+    disableEndpointOnFailedUpdate . intoHandler $ JSONResponse <$> getInstalledAppByIdLogic appId
+
+getInstalledAppByIdLogic :: ( Has (Reader AgentCtx) sig m
+                            , Has RegistryUrl sig m
+                            , Has (Error S9Error) sig m
+                            , Has AppMgr2.AppMgr sig m
+                            , MonadIO m
+                            , MonadBaseControl IO m
+                            )
+                         => AppId
+                         -> m AppInstalledFull
+getInstalledAppByIdLogic appId = do
+    jobCache <- asks appBackgroundJobs >>= liftIO . readTVarIO
+    let installCache = installInfo . fst <$> inspect SInstalling jobCache
+    db          <- asks appConnPool
+    backupTime' <- LAsync.async $ liftIO $ flip runSqlPool db $ getLastSuccessfulBackup appId
+    let installing = do
+            backupTime <- lift $ LAsync.wait backupTime'
+            hoistMaybe $ HM.lookup appId installCache <&> \(StoreApp {..}, StoreAppVersionInfo {..}) -> AppInstalledFull
+                { appInstalledFullBase = AppBase appId storeAppTitle (iconUrl appId storeAppVersionInfoVersion)
+                , appInstalledFullStatus                 = AppStatusTmp Installing
+                , appInstalledFullVersionInstalled       = storeAppVersionInfoVersion
+                , appInstalledFullInstructions           = Nothing
+                , appInstalledFullLastBackup             = backupTime
+                , appInstalledFullTorAddress             = Nothing
+                , appInstalledFullConfiguredRequirements = []
+                }
+    serverApps <- AppMgr2.list [AppMgr2.flags|-s -d|]
+    let remapped = remapAppMgrInfo jobCache serverApps
+    appManifestFetchCached <- cached Reg.getAppManifest
+    let
+        installed = do
+            (status, version, AppMgr2.InfoRes {..}) <- hoistMaybe (HM.lookup appId remapped)
+            instructions'                           <- lift $ LAsync.async $ AppMgr2.instructions appId
+            requirements                            <- LAsync.runConcurrently $ flip
+                HML.traverseWithKey
+                (HML.filter AppMgr2.dependencyInfoRequired infoResDependencies)
+                \depId depInfo -> LAsync.Concurrently $ do
+                    let
+                        fromInstalled = (AppMgr2.infoResTitle &&& AppMgr2.infoResVersion)
+                            <$> hoistMaybe (HM.lookup depId serverApps)
+                    let fromStore = do
+                            Reg.AppManifestRes res <- lift appManifestFetchCached
+                            (storeAppTitle &&& storeAppVersionInfoVersion . extract . storeAppVersions)
+                                <$> hoistMaybe (find ((== depId) . storeAppId) res)
+                    (title, v) <- fromInstalled <|> fromStore
+                    let base = AppBase depId title (iconUrl depId v)
+                    let
+                        depStatus =
+                            (HM.lookup depId installCache $> AppStatusTmp Installing)
+                                <|> (view _1 <$> HM.lookup depId remapped)
+                    pure $ dependencyInfoToDependencyRequirement (AsInstalled STrue) (base, depStatus, depInfo)
+            instructions <- lift $ LAsync.wait instructions'
+            backupTime   <- lift $ LAsync.wait backupTime'
+            pure AppInstalledFull { appInstalledFullBase = AppBase appId infoResTitle (iconUrl appId version)
+                                  , appInstalledFullStatus                 = status
+                                  , appInstalledFullVersionInstalled       = version
+                                  , appInstalledFullInstructions           = instructions
+                                  , appInstalledFullLastBackup             = backupTime
+                                  , appInstalledFullTorAddress             = infoResTorAddress
+                                  , appInstalledFullConfiguredRequirements = HM.elems requirements
+                                  }
+    runMaybeT (installing <|> installed) `orThrowM` NotFoundE "appId" (show appId)
+
+postUninstallAppR :: AppId -> Handler (JSONResponse (WithBreakages ()))
+postUninstallAppR appId = do
+    dry <- AppMgr2.DryRun . isJust <$> lookupGetParam "dryrun"
+    disableEndpointOnFailedUpdate . intoHandler $ JSONResponse <$> postUninstallAppLogic appId dry
+
+postUninstallAppLogic :: ( HasFilesystemBase sig m
+                         , Has (Reader AgentCtx) sig m
+                         , Has (Error S9Error) sig m
+                         , Has AppMgr2.AppMgr sig m
+                         , MonadIO m
+                         , HasLabelled "databaseConnection" (Reader ConnectionPool) sig m
+                         , HasLabelled "iconTagCache" (Reader (TVar (HM.HashMap AppId (Digest MD5)))) sig m
+                         )
+                      => AppId
+                      -> AppMgr2.DryRun
+                      -> m (WithBreakages ())
+postUninstallAppLogic appId dryrun = do
+    jobCache <- asks appBackgroundJobs >>= liftIO . readTVarIO
+    let tmpStatuses = statuses jobCache
+    serverApps <- AppMgr2.list [AppMgr2.flags| |]
+    when (not $ HM.member appId serverApps) $ throwError (AppNotInstalledE appId)
+    case HM.lookup appId tmpStatuses of
+        Just Installing      -> throwError (TemporarilyForbiddenE appId "uninstall" (show Installing))
+        Just CreatingBackup  -> throwError (TemporarilyForbiddenE appId "uninstall" (show CreatingBackup))
+        Just RestoringBackup -> throwError (TemporarilyForbiddenE appId "uninstall" (show RestoringBackup))
+        _                    -> pure ()
+    let flags = if coerce dryrun then Left dryrun else Right (AppMgr2.Purge True)
+    breakageIds <- HM.keys . AppMgr2.unBreakageMap <$> AppMgr2.remove flags appId
+    bs <- pure (traverse (hydrate $ (AppMgr2.infoResTitle &&& AppMgr2.infoResVersion) <$> serverApps) breakageIds)
+        `orThrowM` InternalE "Reported app breakage for app that isn't installed, contact support"
+    when (not $ coerce dryrun) $ clearIcon appId
+    pure $ WithBreakages bs ()
+
+type InstallResponse :: Bool -> Type
+data InstallResponse a = InstallResponse (If a (WithBreakages ()) AppInstalledFull)
+instance ToJSON (Some1 InstallResponse) where
+    toJSON (Some1 STrue  (InstallResponse a)) = toJSON a
+    toJSON (Some1 SFalse (InstallResponse a)) = toJSON a
+postInstallNewAppR :: AppId -> Handler (JSONResponse (Some1 InstallResponse))
+postInstallNewAppR appId = do
+    dryrun <- isJust <$> lookupGetParam "dryrun"
+    InstallNewAppReq { installNewAppVersion } <- requireCheckJsonBody
+    disableEndpointOnFailedUpdate . intoHandler $ JSONResponse <$> do
+        withSomeSing dryrun $ \sb -> Some1 sb . InstallResponse <$> postInstallNewAppLogic appId installNewAppVersion sb
+
+postInstallNewAppLogic :: forall sig m a
+                        . ( Has (Reader AgentCtx) sig m
+                          , HasLabelled "databaseConnection" (Reader ConnectionPool) sig m
+                          , HasLabelled "iconTagCache" (Reader (TVar (HM.HashMap AppId (Digest MD5)))) sig m
+                          , Has (Error S9Error) sig m
+                          , Has RegistryUrl sig m
+                          , Has AppMgr2.AppMgr sig m
+                          , HasFilesystemBase sig m
+                          , MonadIO m
+                          , MonadBaseControl IO m
+                          )
+                       => AppId
+                       -> Version
+                       -> SBool a
+                       -> m (If a (WithBreakages ()) AppInstalledFull)
+postInstallNewAppLogic appId appVersion dryrun = do
+    db   <- asks appConnPool
+    full <- (Just <$> getInstalledAppByIdLogic appId) `catchError` \case
+        NotFoundE "appId" appId' ->
+            if AppId appId' == appId then pure Nothing else throwError (NotFoundE "appId" appId')
+        other -> throwError other
+    case full of
+        Just aif@AppInstalledFull{} -> if appInstalledFullVersionInstalled aif == appVersion
+            then pure $ case dryrun of
+                STrue  -> WithBreakages [] ()
+                SFalse -> aif
+            else installIt db True
+        Nothing -> installIt db False
+    where
+        installIt :: ConnectionPool -> Bool -> m (If a (WithBreakages ()) AppInstalledFull)
+        installIt db isUpdate = do
+            jobCacheTVar                <- asks appBackgroundJobs
+            store@StoreApp {..}         <- Reg.getStoreAppInfo appId `orThrowM` NotFoundE "appId" (show appId)
+            vinfo@StoreAppVersionInfo{} <-
+                find ((== appVersion) . storeAppVersionInfoVersion) storeAppVersions
+                    `orThrowPure` NotFoundE "version" (show appVersion)
+            -- if it is a dry run of an update we don't want to modify the cache
+            case dryrun of
+                STrue -> if not isUpdate
+                    then pure $ WithBreakages [] ()
+                    else do
+                        serverApps' <- LAsync.async $ AppMgr2.list [AppMgr2.flags| |]
+                        hm          <- AppMgr2.update (AppMgr2.DryRun True) appId (Just $ exactly appVersion)
+                        (serverApps :: HM.HashMap AppId (AppMgr2.InfoRes ( 'Right '[]))) <- LAsync.wait serverApps'
+                        breakages   <-
+                            traverse (hydrate ((AppMgr2.infoResTitle &&& AppMgr2.infoResVersion) <$> serverApps))
+                                     (HM.keys $ AppMgr2.unBreakageMap hm)
+                                `orThrowPure` InternalE
+                                                  "Breakage reported for app that isn't installed, contact support"
+                        pure $ WithBreakages breakages ()
+                SFalse -> do
+                    let
+                        action = do
+                            iconAction <- LAsync.async $ saveIcon (toS storeAppIconUrl)
+                            let install = if isUpdate
+                                    then void $ AppMgr2.update (AppMgr2.DryRun False) appId (Just $ exactly appVersion)
+                                    else AppMgr2.install (AppMgr2.NoCache True) appId (Just $ exactly appVersion)
+                            let
+                                success = liftIO $ void $ flip runSqlPool db $ Notifications.emit
+                                    appId
+                                    appVersion
+                                    Notifications.InstallSuccess
+                            let failure e = liftIO $ do
+                                    let notif = case e of
+                                            AppMgrE _ ec -> Notifications.InstallFailedAppMgrExitCode ec
+                                            _            -> Notifications.InstallFailedS9Error e
+                                    void $ flip runSqlPool db $ Notifications.emit appId appVersion notif
+                                    putStrLn @Text (show e)
+                            let todo = do
+                                    install
+                                    () <- LAsync.wait iconAction
+                                    success
+                            todo `catchError` failure
+                    tid <- action `Lifted.forkFinally` const postInstall
+                    liftIO $ atomically $ modifyTVar' jobCacheTVar (insertJob appId (Install store vinfo) tid)
+                    getInstalledAppByIdLogic appId
+        postInstall :: m ()
+        postInstall = do
+            jobCache <- asks appBackgroundJobs
+            pool     <- asks appConnPool
+            liftIO . atomically $ modifyTVar jobCache (deleteJob appId)
+            ls <- AppMgr2.list [AppMgr2.flags| |]
+            LAsync.forConcurrently_ (HM.toList ls) $ \(k, AppMgr2.InfoRes {..}) -> when
+                infoResNeedsRestart
+                (            postRestartServerAppLogic k
+                `catchError` \e -> liftIO $ runSqlPool
+                                 (void $ Notifications.emit k infoResVersion (Notifications.RestartFailed e))
+                                 pool
+                )
+
+
+postStartServerAppR :: AppId -> Handler ()
+postStartServerAppR appId = disableEndpointOnFailedUpdate . intoHandler $ postStartServerAppLogic appId
+
+postStartServerAppLogic :: (Has (Error S9Error) sig m, Has AppMgr2.AppMgr sig m, Has (Reader AgentCtx) sig m, MonadIO m)
+                        => AppId
+                        -> m ()
+postStartServerAppLogic appId = do
+    jobCache       <- asks appBackgroundJobs >>= liftIO . readTVarIO
+    info           <- AppMgr2.info [AppMgr2.flags|-s -d|] appId `orThrowM` AppNotInstalledE appId
+    (status, _, _) <- (HM.lookup appId $ remapAppMgrInfo jobCache (HM.singleton appId info))
+        `orThrowPure` InternalE "Remapping magically deleted keys between source and target structures"
+    case status of
+        AppStatusAppMgr Stopped -> AppMgr2.start appId
+        other                   -> throwError $ AppStateActionIncompatibleE appId other Start
+
+postRestartServerAppR :: AppId -> Handler ()
+postRestartServerAppR appId = disableEndpointOnFailedUpdate . intoHandler $ postRestartServerAppLogic appId
+
+postRestartServerAppLogic :: ( Has (Reader AgentCtx) sig m
+                             , Has AppMgr2.AppMgr sig m
+                             , Has (Error S9Error) sig m
+                             , MonadBaseControl IO m
+                             , MonadIO m
+                             )
+                          => AppId
+                          -> m ()
+postRestartServerAppLogic appId = do
+    jobCache <- asks appBackgroundJobs
+    answer   <- Lifted.newEmptyMVar
+    void . Lifted.fork $ do
+        tid     <- Lifted.myThreadId
+        problem <- liftIO . atomically $ do
+            JobCache jobs <- readTVar jobCache
+            case HM.lookup appId jobs of
+                Just (Some1 s _, _) -> pure (Just . throwError $ TemporarilyForbiddenE appId "restart" (show s))
+                Nothing             -> do
+                    modifyTVar jobCache (insertJob appId RestartApp tid)
+                    pure Nothing
+        case problem of
+            Nothing -> do
+                AppMgr2.restart appId `Lifted.finally` (liftIO . atomically) (modifyTVar jobCache (deleteJob appId))
+                Lifted.putMVar answer Nothing
+            Just p -> Lifted.putMVar answer (Just p)
+    Lifted.takeMVar answer >>= \case
+        Nothing -> pure ()
+        Just p  -> p
+
+
+postStopServerAppR :: AppId -> Handler (JSONResponse (WithBreakages ()))
+postStopServerAppR appId = disableEndpointOnFailedUpdate do
+    dryrun <- isJust <$> lookupGetParam "dryrun"
+    mRes   <- intoHandler $ runMaybeT (JSONResponse <$> postStopServerAppLogic appId (AppMgr2.DryRun dryrun))
+    case mRes of
+        Nothing -> sendResponseStatus status200 ()
+        Just x  -> pure x
+
+postStopServerAppLogic :: ( Has Empty sig m
+                          , Has (Reader AgentCtx) sig m
+                          , Has (Error S9Error) sig m
+                          , Has AppMgr2.AppMgr sig m
+                          , MonadIO m
+                          , MonadBaseControl IO m
+                          )
+                       => AppId
+                       -> AppMgr2.DryRun
+                       -> m (WithBreakages ())
+postStopServerAppLogic appId dryrun = do
+    jobCache <- asks appBackgroundJobs
+    titles   <- (AppMgr2.infoResTitle &&& AppMgr2.infoResVersion) <<$>> AppMgr2.list [AppMgr2.flags| |]
+    let stopIt = do
+            breakages <- AppMgr2.stop dryrun appId
+            bases     <- traverse (hydrate titles) (HM.keys $ AppMgr2.unBreakageMap breakages)
+                `orThrowPure` InternalE "Breakages reported for app that isn't installed, contact support"
+            pure $ WithBreakages bases ()
+    status <- AppMgr2.infoResStatus <<$>> AppMgr2.info [AppMgr2.flags|-S|] appId
+    case (dryrun, status) of
+        (_                   , Nothing     ) -> throwError $ NotFoundE "appId" (show appId)
+        (AppMgr2.DryRun False, Just Running) -> do
+            tid <- (void stopIt)
+                `Lifted.forkFinally` const ((liftIO . atomically) (modifyTVar jobCache (deleteJob appId)))
+            liftIO . atomically $ modifyTVar jobCache (insertJob appId StopApp tid)
+            empty
+        (AppMgr2.DryRun True , Just Running   ) -> stopIt
+        (AppMgr2.DryRun False, Just Restarting) -> do
+            tid <- (void stopIt)
+                `Lifted.forkFinally` const ((liftIO . atomically) (modifyTVar jobCache (deleteJob appId)))
+            liftIO . atomically $ modifyTVar jobCache (insertJob appId StopApp tid)
+            empty
+        (AppMgr2.DryRun True, Just Restarting) -> stopIt
+        (_, Just other) -> throwError $ AppStateActionIncompatibleE appId (AppStatusAppMgr other) Stop
+
+getAppConfigR :: AppId -> Handler TypedContent
+getAppConfigR =
+    disableEndpointOnFailedUpdate
+        . handleS9ErrT
+        . fmap (TypedContent typeJson . toContent)
+        . AppMgr.getConfigurationAndSpec
+
+patchAppConfigR :: AppId -> Handler (JSONResponse (WithBreakages ()))
+patchAppConfigR appId = disableEndpointOnFailedUpdate $ do
+    dryrun  <- isJust <$> lookupGetParam "dryrun"
+    value   <- requireCheckJsonBody @_ @Value
+    realVal <-
+        runM . handleS9ErrC $ ((value ^? key "config") `orThrowPure` (InvalidRequestE value "Missing 'config' key"))
+    intoHandler $ JSONResponse <$> patchAppConfigLogic appId (AppMgr2.DryRun dryrun) realVal
+
+patchAppConfigLogic :: ( Has (Reader AgentCtx) sig m
+                       , Has (Error S9Error) sig m
+                       , Has AppMgr2.AppMgr sig m
+                       , MonadBaseControl IO m
+                       , MonadIO m
+                       )
+                    => AppId
+                    -> AppMgr2.DryRun
+                    -> Value
+                    -> m (WithBreakages ())
+patchAppConfigLogic appId dryrun cfg = do
+    serverApps                <- AppMgr2.list [AppMgr2.flags| |]
+    AppMgr2.ConfigureRes {..} <- AppMgr2.configure dryrun appId (Just cfg)
+    when (not $ coerce dryrun) $ for_ configureResNeedsRestart postRestartServerAppLogic
+    breakages <-
+        traverse (hydrate ((AppMgr2.infoResTitle &&& AppMgr2.infoResVersion) <$> serverApps))
+                 (HM.keys configureResStopped)
+            `orThrowPure` InternalE "Breakage reported for app that is not installed, contact support"
+    pure $ WithBreakages breakages ()
+
+
+getAppNotificationsR :: AppId -> Handler (JSONResponse [Entity Notification])
+getAppNotificationsR appId = disableEndpointOnFailedUpdate $ runDB $ do
+    page     <- lookupGetParam "page" `orDefaultTo` 1
+    pageSize <- lookupGetParam "perPage" `orDefaultTo` 20
+    evs      <- selectList [NotificationAppId ==. appId]
+                           [Desc NotificationCreatedAt, LimitTo pageSize, OffsetBy ((page - 1) * pageSize)]
+    let toArchive = fmap entityKey $ filter ((== Nothing) . notificationArchivedAt . entityVal) evs
+    void $ Notifications.archive toArchive
+    pure $ JSONResponse evs
+    where
+        orDefaultTo :: (Monad m, Read a) => m (Maybe Text) -> a -> m a
+        orDefaultTo m a = do
+            m' <- m
+            case m' >>= readMaybe . toS of
+                Nothing -> pure a
+                Just x  -> pure x
+
+getAppMetricsR :: AppId -> Handler TypedContent
+getAppMetricsR appId =
+    disableEndpointOnFailedUpdate . handleS9ErrT $ fmap (TypedContent typeJson . toContent) $ AppMgr.stats appId
+
+getAvailableAppVersionInfoR :: AppId -> VersionRange -> Handler (JSONResponse AppVersionInfo)
+getAvailableAppVersionInfoR appId version =
+    disableEndpointOnFailedUpdate . intoHandler $ JSONResponse <$> getAvailableAppVersionInfoLogic appId version
+
+getAvailableAppVersionInfoLogic :: ( Has (Reader AgentCtx) sig m
+                                   , Has (Error S9Error) sig m
+                                   , Has RegistryUrl sig m
+                                   , Has AppMgr2.AppMgr sig m
+                                   , MonadIO m
+                                   , MonadBaseControl IO m
+                                   )
+                                => AppId
+                                -> VersionRange
+                                -> m AppVersionInfo
+getAvailableAppVersionInfoLogic appId appVersionSpec = do
+    jobCache                     <- asks appBackgroundJobs >>= liftIO . readTVarIO
+    Reg.AppManifestRes storeApps <- Reg.getAppManifest
+    let titles =
+            (storeAppTitle &&& storeAppVersionInfoVersion . extract . storeAppVersions) <$> indexBy storeAppId storeApps
+    StoreApp {..} <- find ((== appId) . storeAppId) storeApps `orThrowPure` NotFoundE "appId" (show appId)
+    serverApps    <- AppMgr2.list [AppMgr2.flags|-s -d|]
+    let remapped = remapAppMgrInfo jobCache serverApps
+    StoreAppVersionInfo {..} <-
+        maximumMay (NE.filter ((<|| appVersionSpec) . storeAppVersionInfoVersion) storeAppVersions)
+            `orThrowPure` NotFoundE "version spec " (show appVersionSpec)
+    dependencies <- AppMgr2.checkDependencies (AppMgr2.LocalOnly False)
+                                              appId
+                                              (Just $ exactly storeAppVersionInfoVersion)
+    requirements <- flip HML.traverseWithKey dependencies $ \depId depInfo -> do
+        base <- hydrate titles depId `orThrowPure` NotFoundE "metadata for" (show depId)
+        let status =
+                (HM.lookup depId (inspect SInstalling jobCache) $> AppStatusTmp Installing)
+                    <|> (view _1 <$> HM.lookup depId remapped)
+        pure $ dependencyInfoToDependencyRequirement (AsInstalled SFalse) (base, status, depInfo)
+    pure AppVersionInfo { appVersionInfoVersion                = storeAppVersionInfoVersion
+                        , appVersionInfoReleaseNotes           = storeAppVersionInfoReleaseNotes
+                        , appVersionInfoDependencyRequirements = HM.elems requirements
+                        }
+
+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))
+                    <|> (guard (infoResStatus == Restarting) $> (Crashed, 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
+
+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 { .. }

agent/src/Handler/Authenticate.hs

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

agent/src/Handler/Backups.hs

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

agent/src/Handler/Hosts.hs

@@ -0,0 +1,85 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+module Handler.Hosts where
+
+import           Startlude               hiding ( ask )
+
+import           Control.Carrier.Lift           ( runM )
+import           Control.Carrier.Error.Church
+import           Data.Conduit
+import qualified Data.Conduit.Binary           as CB
+import           Data.Time.ISO8601
+import           Yesod.Core              hiding ( expiresAt )
+
+import           Foundation
+import           Daemon.ZeroConf
+import           Handler.Register               ( produceProofOfKey
+                                                , checkExistingPasswordRegistration
+                                                )
+import           Handler.Types.Hosts
+import           Handler.Types.Register
+import           Lib.Crypto
+import           Lib.Error
+import           Lib.Password                   ( rootAccountName )
+import           Lib.ProductKey
+import           Lib.Ssl
+import           Lib.SystemPaths
+import           Lib.Tor
+import           Settings
+
+getHostsR :: Handler HostsRes
+getHostsR = handleS9ErrT $ do
+    settings   <- getsYesod appSettings
+    productKey <- liftIO . getProductKey . appFilesystemBase $ settings
+    hostParams <- extractHostsQueryParams
+
+    verifyHmac productKey hostParams
+    verifyTimestampNotExpired $ hostsParamsExpiration 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"
+
+verifyTimestampNotExpired :: MonadIO m => Text -> S9ErrT m ()
+verifyTimestampNotExpired expirationTimestamp = do
+    now <- liftIO getCurrentTime
+    case parseISO8601 . toS $ expirationTimestamp of
+        Nothing         -> throwE $ TTLExpirationE "invalid timestamp"
+        Just expiration -> when (expiration < now) (throwE $ TTLExpirationE "expired")
+
+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 { .. }
+
+getCertificateR :: Handler TypedContent
+getCertificateR = do
+    base <- getsYesod $ appFilesystemBase . appSettings
+    respondSource "application/x-x509-ca-cert"
+        $  CB.sourceFile (toS $ rootCaCertPath `relativeTo` base)
+        .| awaitForever sendChunkBS

agent/src/Handler/Icons.hs

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

agent/src/Handler/Login.hs

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

agent/src/Handler/Notifications.hs

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

agent/src/Handler/PasswordUpdate.hs

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

agent/src/Handler/PowerOff.hs

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

agent/src/Handler/Register.hs

@@ -0,0 +1,140 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+module Handler.Register where
+
+import           Startlude               hiding ( ask )
+
+import           Control.Carrier.Error.Either   ( runError )
+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           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 _  -> sendResponseStatus (Status 209 "Preexisting") ()
+
+    -- 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

agent/src/Handler/Register/Nginx.hs

@@ -0,0 +1,158 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE QuasiQuotes #-}
+module Handler.Register.Nginx where
+
+import           Startlude               hiding ( ask
+                                                , catchError
+                                                )
+
+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` "/") <> ".csr"
+        , rootCaCertPath
+        , intermediateCaKeyPath
+        , relBase $ (intermediateCaCertPath `relativeTo` "/") <> ".csr"
+        , intermediateCaCertPath
+        , entityKeyPath host
+        , relBase $ (entityCertPath host `relativeTo` "/") <> ".csr"
+        , entityCertPath host
+        , entityConfPath host
+        , nginxSitesAvailable nginxSslConf
+        ]
+    liftIO $ do
+        withCurrentDirectory (toS $ flip relativeTo base $ rootCaDirectory <> "/newcerts")
+            $   listDirectory "."
+            >>= traverse_ removePathForcibly
+        withCurrentDirectory (toS $ flip relativeTo base $ intermediateCaDirectory <> "/newcerts")
+            $   listDirectory "."
+            >>= traverse_ removePathForcibly
+        writeFile (toS $ flip relativeTo base $ rootCaDirectory <> "/index.txt")         ""
+        writeFile (toS $ flip relativeTo base $ intermediateCaDirectory <> "/index.txt") ""
+    _ <- liftIO $ try @SomeException . removeLink . toS $ (nginxSitesEnabled nginxSslConf) `relativeTo` base
+    pure ()
+
+
+bootupHttpNginx :: (HasFilesystemBase sig m, MonadIO m) => m ()
+bootupHttpNginx = installAmbassadorUiNginxHTTP "start9-ambassador.conf"
+
+writeSslKeyAndCert :: (MonadIO m, HasFilesystemBase sig m, Has (Error S9Error) sig m) => ByteString -> m Text
+writeSslKeyAndCert rsaKeyFileContents = do
+    directory     <- toS <$> getAbsoluteLocationFor sslDirectory
+    caKeyPath     <- toS <$> getAbsoluteLocationFor rootCaKeyPath
+    caConfPath    <- toS <$> getAbsoluteLocationFor rootCaOpenSslConfPath
+    caCertPath    <- toS <$> getAbsoluteLocationFor rootCaCertPath
+    intCaKeyPath  <- toS <$> getAbsoluteLocationFor intermediateCaKeyPath
+    intCaConfPath <- toS <$> getAbsoluteLocationFor intermediateCaOpenSslConfPath
+    intCaCertPath <- toS <$> getAbsoluteLocationFor intermediateCaCertPath
+    sid           <- getStart9AgentHostname
+    entKeyPath    <- toS <$> getAbsoluteLocationFor (entityKeyPath sid)
+    entConfPath   <- toS <$> getAbsoluteLocationFor (entityConfPath sid)
+    entCertPath   <- toS <$> getAbsoluteLocationFor (entityCertPath sid)
+    torAddr       <- getAgentHiddenServiceUrl
+
+    let hostname = sid <> ".local"
+
+    liftIO $ createDirectoryIfMissing False directory
+    liftIO $ BS.writeFile caKeyPath rsaKeyFileContents
+
+    (exit, str1, str2) <- writeRootCaCert caConfPath caKeyPath caCertPath
+    liftIO $ do
+        putStrLn @Text "openssl logs"
+        putStrLn @Text "exit code: "
+        print exit
+        putStrLn @String $ "stdout: " <> str1
+        putStrLn @String $ "stderr: " <> str2
+    case exit of
+        ExitSuccess    -> pure ()
+        ExitFailure ec -> throwError $ OpenSslE "root" ec str1 str2
+
+    (exit', str1', str2') <- writeIntermediateCert $ DeriveCertificate { applicantConfPath = intCaConfPath
+                                                                       , applicantKeyPath  = intCaKeyPath
+                                                                       , applicantCertPath = intCaCertPath
+                                                                       , signingConfPath   = caConfPath
+                                                                       , signingKeyPath    = caKeyPath
+                                                                       , signingCertPath   = caCertPath
+                                                                       , duration          = 3650
+                                                                       }
+    liftIO $ do
+        putStrLn @Text "openssl logs"
+        putStrLn @Text "exit code: "
+        print exit'
+        putStrLn @String $ "stdout: " <> str1'
+        putStrLn @String $ "stderr: " <> str2'
+    case exit' of
+        ExitSuccess    -> pure ()
+        ExitFailure ec -> throwError $ OpenSslE "intermediate" ec str1' str2'
+
+
+    liftIO $ BS.writeFile entConfPath (domain_CSR_CONF hostname)
+
+    (exit'', str1'', str2'') <- writeLeafCert
+        DeriveCertificate { applicantConfPath = entConfPath
+                          , applicantKeyPath  = entKeyPath
+                          , applicantCertPath = entCertPath
+                          , signingConfPath   = intCaConfPath
+                          , signingKeyPath    = intCaKeyPath
+                          , signingCertPath   = intCaCertPath
+                          , duration          = 365
+                          }
+        hostname
+        torAddr
+
+    liftIO $ do
+        putStrLn @Text "openssl logs"
+        putStrLn @Text "exit code: "
+        print exit''
+        putStrLn @String $ "stdout: " <> str1''
+        putStrLn @String $ "stderr: " <> str2''
+    case exit'' of
+        ExitSuccess    -> pure ()
+        ExitFailure ec -> throwError $ OpenSslE "leaf" ec str1' str2'
+
+    readSystemPath' rootCaCertPath

agent/src/Handler/Register/Tor.hs

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

agent/src/Handler/SelfUpdate.hs

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

agent/src/Handler/SshKeys.hs

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

agent/src/Handler/Status.hs

@@ -0,0 +1,71 @@
+{-# 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 )
+
+getVersionR :: Handler AppVersionRes
+getVersionR = pure . AppVersionRes $ agentVersion
+
+getVersionLatestR :: Handler VersionLatestRes
+getVersionLatestR = handleS9ErrT $ do
+    s <- getsYesod appSettings
+    v <- interp s $ Reg.getLatestAgentVersion
+    pure $ VersionLatestRes v
+    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
+
+    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
+

agent/src/Handler/Tor.hs

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

agent/src/Handler/Types/Apps.hs

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

agent/src/Handler/Types/HmacSig.hs

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

agent/src/Handler/Types/Hosts.hs

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

agent/src/Handler/Types/Metrics.hs

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

agent/src/Handler/Types/Parse.hs

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

agent/src/Handler/Types/Register.hs

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

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

@@ -0,0 +1,77 @@
+{-# 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
+    }
+    deriving (Eq, Show)
+instance ToJSON VersionLatestRes where
+    toJSON VersionLatestRes {..} = object $ ["versionLatest" .= versionLatestVersion]
+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
+    }
+    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
+        , "versionLatest" .= Null
+        , "notifications" .= serverNotifications
+        , "wifi" .= serverWifi
+        , "ssh" .= serverSsh
+        , "alternativeRegistryUrl" .= serverAlternativeRegistryUrl
+        , "specs" .= serverSpecs
+        ]
+instance ToTypedContent ServerRes where
+    toTypedContent = toTypedContent . toJSON
+instance ToContent ServerRes where
+    toContent = toContent . toJSON
+
+newtype AppVersionRes = AppVersionRes
+    { unAppVersionRes :: Version } deriving (Eq, Show)
+instance ToJSON AppVersionRes where
+    toJSON AppVersionRes { unAppVersionRes } = object ["version" .= unAppVersionRes]
+instance FromJSON AppVersionRes where
+    parseJSON = withObject "app version response" $ \o -> do
+        av <- o .: "version"
+        pure $ AppVersionRes av
+instance ToContent AppVersionRes where
+    toContent = toContent . toJSON
+instance ToTypedContent AppVersionRes where
+    toTypedContent = toTypedContent . toJSON

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

@@ -0,0 +1,45 @@
+{-# 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
+    }
+    deriving (Eq, Show)
+
+instance ToJSON SpecsRes where
+    toJSON SpecsRes {..} = object
+        [ "EmbassyOS Version" .= specsAgentVersion
+        , "Tor Address" .= specsTorAddress
+        , "Network ID" .= specsNetworkId
+        , "CPU" .= specsCPU
+        , "Memory" .= specsMem
+        , "Disk" .= specsDisk
+        ]
+    toEncoding SpecsRes {..} =
+        pairs
+            . fold
+            $ [ "EmbassyOS Version" .= specsAgentVersion
+              , "Tor Address" .= specsTorAddress
+              , "Network ID" .= specsNetworkId
+              , "CPU" .= specsCPU
+              , "Memory" .= specsMem
+              , "Disk" .= specsDisk
+              ]
+
+instance ToTypedContent SpecsRes where
+    toTypedContent = toTypedContent . toJSON
+instance ToContent SpecsRes where
+    toContent = toContent . toJSON

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

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

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

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

agent/src/Handler/Util.hs

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

agent/src/Handler/V0.hs

@@ -0,0 +1,120 @@
+{-# 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
+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           Model
+import           Settings
+import           Util.Function
+
+
+getServerR :: Handler (JsonEncoding ServerRes)
+getServerR = handleS9ErrT $ do
+    settings   <- getsYesod appSettings
+    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
+    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
+                         }
+    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
+
+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
+
+    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"
+
+patchNameR :: Handler ()
+patchNameR = patchFile serverNamePath
+
+patchFile :: SystemPath -> Handler ()
+patchFile path = do
+    settings     <- getsYesod appSettings
+    PatchReq val <- requireCheckJsonBody
+    runM $ injectFilesystemBaseFromContext settings $ writeSystemPath path val
+
+patchNullableFile :: SystemPath -> Handler ()
+patchNullableFile path = do
+    settings              <- getsYesod appSettings
+    NullablePatchReq mVal <- requireCheckJsonBody
+    runM $ injectFilesystemBaseFromContext settings $ case mVal of
+        Just val -> writeSystemPath path $ T.strip val
+        Nothing  -> deleteSystemPath path

agent/src/Handler/Wifi.hs

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

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

@@ -0,0 +1,469 @@
+{-# 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           Exinst
+
+import           Lib.Algebra.Domain.AppMgr.Types
+import           Lib.Algebra.Domain.AppMgr.TH
+import           Lib.Error
+import           Lib.External.AppManifest
+import           Lib.TyFam.ConditionalData
+import           Lib.Types.Core                 ( AppId(..)
+                                                , AppContainerStatus(..)
+                                                )
+import           Lib.Types.NetAddress
+import           Lib.Types.Emver
+import           Control.Monad.Trans.Class      ( MonadTrans )
+import qualified Data.ByteString.Lazy          as LBS
+import           System.Process.Typed
+import           Data.String.Interpolate.IsString
+                                                ( i )
+import           Control.Monad.Base             ( MonadBase(..) )
+import           Control.Monad.Fail             ( MonadFail(fail) )
+import           Control.Monad.Trans.Resource   ( MonadResource(..) )
+import           Control.Monad.Trans.Control    ( defaultLiftBaseWith
+                                                , defaultRestoreM
+                                                , MonadTransControl(..)
+                                                , MonadBaseControl(..)
+                                                )
+import qualified Data.ByteString.Char8         as C8
+
+
+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) (Some1 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 ::_
+makeSmartConstructors ''AppMgr
+
+newtype AppMgrCliC m a = AppMgrCliC { runAppMgrCliC :: m a }
+    deriving newtype (Functor, Applicative, Monad, MonadIO)
+instance MonadTrans AppMgrCliC where
+    lift = AppMgrCliC
+instance MonadResource m => MonadResource (AppMgrCliC m) where
+    liftResourceT = lift . liftResourceT
+instance MonadBase IO m => MonadBase IO (AppMgrCliC m) where
+    liftBase = AppMgrCliC . liftBase
+instance MonadTransControl AppMgrCliC where
+    type StT AppMgrCliC a = a
+    liftWith f = AppMgrCliC $ f $ runAppMgrCliC
+    restoreT = AppMgrCliC
+instance MonadBaseControl IO m => MonadBaseControl IO (AppMgrCliC m) where
+    type StM (AppMgrCliC m) a = StM m a
+    liftBaseWith = defaultLiftBaseWith
+    restoreM     = defaultRestoreM
+
+instance (Has (Error S9Error) sig m, Algebra sig m, MonadIO m) => Algebra (AppMgr :+: sig) (AppMgrCliC m) where
+    alg hdl sig ctx = case sig of
+        (L (CheckDependencies (LocalOnly b) appId version)) -> do
+            let local = if b then ("--local-only" :) else id
+                args  = "check-dependencies" : local [versionSpec version (show appId), "--json"]
+            (ec, out) <- readProcessInheritStderr "appmgr" args ""
+            res       <- case ec of
+                ExitSuccess -> case eitherDecodeStrict out of
+                    Left  e -> throwError $ AppMgrParseE (toS $ String.unwords args) (decodeUtf8 out) e
+                    Right x -> pure x
+                ExitFailure 6 -> throwError $ NotFoundE "appId@version" (versionSpec version (show appId))
+                ExitFailure n -> throwError $ AppMgrE "check-dependencies" n
+            pure $ ctx $> res
+        (L (Configure (DryRun b) appId cfg)) -> do
+            let dryrun = if b then ("--dry-run" :) else id
+            let input = case cfg of
+                    Nothing -> ""
+                    Just x  -> LBS.toStrict $ encode x
+            let args = "configure" : dryrun [show appId, "--json", "--stdin"]
+            (ec, out, e) <- readProcessWithExitCode' "appmgr" args input
+            res          <- case ec of
+                ExitSuccess -> case eitherDecodeStrict out of
+                    Left  e -> throwError $ AppMgrParseE (toS $ String.unwords args) (decodeUtf8 out) e
+                    Right x -> pure x
+                ExitFailure 4 -> throwError $ (AppMgrInvalidConfigE . decodeUtf8) e -- doesn't match spec
+                ExitFailure 5 -> throwError $ (AppMgrInvalidConfigE . decodeUtf8) e -- doesn't match rules
+                ExitFailure n -> throwError $ AppMgrE "configure" n
+            pure $ ctx $> res
+        (L (Autoconfigure (DryRun dry) dependent dependency)) -> do
+            let flags = (if dry then ("--dry-run" :) else id) . ("--json" :)
+            let args  = "autoconfigure-dependency" : flags [show dependent, show dependency]
+            (ec, out) <- readProcessInheritStderr "appmgr" args ""
+            res       <- case ec of
+                ExitSuccess -> case eitherDecodeStrict out of
+                    Left  e -> throwError $ AppMgrParseE (toS $ String.unwords args) (decodeUtf8 out) e
+                    Right a -> pure a
+                ExitFailure n -> throwError $ AppMgrE "autoconfigure-dependency" n
+            pure $ ctx $> res
+        (L (Info fs appId)) -> do
+            let args = case fromSing fs of
+                    Left  o  -> ["info", genExclusiveFlag o, show appId, "--json"]
+                    Right ls -> "info" : ((genInclusiveFlag <$> ls) <> [show appId, "--json"])
+            (ec, out) <- readProcessInheritStderr "appmgr" args ""
+            res       <- case ec of
+                ExitSuccess -> case withSingI fs $ eitherDecodeStrict out of
+                    Left  e -> throwError $ AppMgrParseE (show args) (decodeUtf8 out) e
+                    Right x -> pure $ Just x
+                ExitFailure 6 -> pure Nothing
+                ExitFailure n -> throwError $ AppMgrE "info" n
+            pure $ ctx $> res
+        (L (InfoRaw f appId)) -> do
+            let args = ["info", genExclusiveFlag f, show appId, "--json"]
+            (ec, out) <- readProcessInheritStderr "appmgr" args ""
+            res       <- case ec of
+                ExitSuccess   -> pure (Just $ decodeUtf8 out)
+                ExitFailure 6 -> pure Nothing
+                ExitFailure n -> throwError $ AppMgrE "info (raw)" n
+            pure $ ctx $> res
+        (L (Install (NoCache b) appId version)) -> do
+            let nocache = if b then ("--no-cache" :) else id
+            let versionSpec :: (IsString a, Semigroup a, ConvertText String a) => a -> a
+                versionSpec = case version of
+                    Nothing -> id
+                    Just x  -> (<> [i|@#{x}|])
+            let args = "install" : nocache [versionSpec (show appId)]
+            (ec, _) <- readProcessInheritStderr "appmgr" args ""
+            case ec of
+                ExitSuccess   -> pure ctx
+                ExitFailure 6 -> throwError $ NotFoundE "appId" (show appId)
+                ExitFailure n -> throwError $ AppMgrE "install" n
+        (L (Instructions appId)) -> do
+            (ec, out) <- readProcessInheritStderr "appmgr" ["instructions", show appId] ""
+            case ec of
+                ExitSuccess   -> pure $ ctx $> Just (decodeUtf8 out)
+                ExitFailure 6 -> pure $ ctx $> Nothing
+                ExitFailure n -> throwError $ AppMgrE "instructions" n
+        (L (List (SRight flags))) -> do
+            let renderedFlags = (genInclusiveFlag <$> fromSing flags) <> ["--json"]
+            let args          = "list" : renderedFlags
+            (ec, out) <- readProcessInheritStderr "appmgr" args ""
+            res       <- case ec of
+                ExitSuccess -> case withSingI flags $ eitherDecodeStrict out of
+                    Left  e -> throwError $ AppMgrParseE (toS $ String.unwords args) (decodeUtf8 out) e
+                    Right x -> pure x
+                ExitFailure n -> throwError $ AppMgrE "list" n
+            pure $ ctx $> res
+        (L (Remove dryorpurge appId)) -> do
+            let args = "remove" : case dryorpurge of
+                    Left  (DryRun True) -> ["--dry-run", show appId, "--json"]
+                    Right (Purge  True) -> ["--purge", show appId, "--json"]
+                    _                   -> [show appId]
+            (ec, out) <- readProcessInheritStderr "appmgr" args ""
+            res       <- case ec of
+                ExitSuccess -> case eitherDecodeStrict out of
+                    Left  e -> throwError $ AppMgrParseE (toS $ String.unwords args) (decodeUtf8 out) e
+                    Right x -> pure x
+                ExitFailure 6 -> throwError $ NotFoundE "appId" (show appId)
+                ExitFailure n -> throwError $ AppMgrE (toS $ String.unwords args) n
+            pure $ ctx $> res
+        (L (Restart appId)) -> do
+            (ec, _) <- readProcessInheritStderr "appmgr" ["restart", show appId] ""
+            case ec of
+                ExitSuccess   -> pure ctx
+                ExitFailure 6 -> throwError $ NotFoundE "appId" (show appId)
+                ExitFailure n -> throwError $ AppMgrE "restart" n
+        (L (Start appId)) -> do
+            (ec, _) <- readProcessInheritStderr "appmgr" ["start", show appId] ""
+            case ec of
+                ExitSuccess   -> pure ctx
+                ExitFailure 6 -> throwError $ NotFoundE "appId" (show appId)
+                ExitFailure n -> throwError $ AppMgrE "start" n
+        (L (Stop (DryRun dry) appId)) -> do
+            let args = "stop" : (if dry then ("--dry-run" :) else id) [show appId, "--json"]
+            (ec, out) <- readProcessInheritStderr "appmgr" args ""
+            case ec of
+                ExitSuccess -> case eitherDecodeStrict out of
+                    Left  e -> throwError $ AppMgrParseE (toS $ String.unwords args) (decodeUtf8 out) e
+                    Right x -> pure $ ctx $> x
+                ExitFailure 6 -> throwError $ NotFoundE "appId" (show appId)
+                ExitFailure n -> throwError $ AppMgrE (toS $ String.unwords args) n
+        (L (Update (DryRun dry) appId version)) -> do
+            let args = "update" : (if dry then ("--dry-run" :) else id) [versionSpec version (show appId), "--json"]
+            (ec, out) <- readProcessInheritStderr "appmgr" args ""
+            case ec of
+                ExitSuccess ->
+                    let output = if not dry then fromMaybe "" $ lastMay (C8.lines out) else out
+                    in  case eitherDecodeStrict output of
+                            Left  e -> throwError $ AppMgrParseE (toS $ String.unwords args) (decodeUtf8 out) e
+                            Right x -> pure $ ctx $> x
+                ExitFailure 6 ->
+                    throwError $ NotFoundE "appId@version" ([i|#{appId}#{maybe "" (('@':) . show) version}|])
+                ExitFailure n -> throwError $ AppMgrE (toS $ String.unwords args) n
+        R other -> AppMgrCliC $ alg (runAppMgrCliC . hdl) other ctx
+        where
+            versionSpec :: (IsString a, Semigroup a, ConvertText String a) => Maybe VersionRange -> a -> a
+            versionSpec v = case v of
+                Nothing -> id
+                Just x  -> (<> [i|@#{x}|])
+    {-# INLINE alg #-}
+
+genInclusiveFlag :: IncludeInfoFlag -> String
+genInclusiveFlag = \case
+    IncludeConfig       -> "-c"
+    IncludeDependencies -> "-d"
+    IncludeManifest     -> "-m"
+    IncludeStatus       -> "-s"
+
+genExclusiveFlag :: OnlyInfoFlag -> String
+genExclusiveFlag = \case
+    OnlyConfig       -> "-C"
+    OnlyDependencies -> "-D"
+    OnlyManifest     -> "-M"
+    OnlyStatus       -> "-S"
+
+readProcessInheritStderr :: MonadIO m => String -> [String] -> ByteString -> m (ExitCode, ByteString)
+readProcessInheritStderr a b c = liftIO $ do
+    let pc =
+            setStdin (byteStringInput $ LBS.fromStrict c)
+                $ setStderr inherit
+                $ setEnvInherit
+                $ setStdout byteStringOutput
+                $ (System.Process.Typed.proc a b)
+    withProcessWait pc
+        $ \process -> atomically $ liftA2 (,) (waitExitCodeSTM process) (fmap LBS.toStrict $ getStdout process)
+
+readProcessWithExitCode' :: MonadIO m => String -> [String] -> ByteString -> m (ExitCode, ByteString, ByteString)
+readProcessWithExitCode' a b c = liftIO $ do
+    let pc =
+            setStdin (byteStringInput $ LBS.fromStrict c)
+                $ setStderr byteStringOutput
+                $ setEnvInherit
+                $ setStdout byteStringOutput
+                $ (System.Process.Typed.proc a b)
+    withProcessWait pc $ \process -> atomically $ liftA3 (,,)
+                                                         (waitExitCodeSTM process)
+                                                         (fmap LBS.toStrict $ getStdout process)
+                                                         (fmap LBS.toStrict $ getStderr process)

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

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

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

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

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

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

agent/src/Lib/Avahi.hs

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

agent/src/Lib/Background.hs

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

agent/src/Lib/ClientManifest.hs

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

agent/src/Lib/Crypto.hs

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

agent/src/Lib/Database.hs

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

agent/src/Lib/Error.hs

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

agent/src/Lib/External/AppManifest.hs

@@ -0,0 +1,100 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Lib.External.AppManifest where
+
+import           Startlude               hiding ( ask )
+
+import           Control.Effect.Reader.Labelled
+import           Data.Aeson
+import           Data.Singletons.TypeLits
+import qualified Data.HashMap.Strict           as HM
+import qualified Data.Yaml                     as Yaml
+import           Exinst
+
+import           Lib.Error
+import           Lib.SystemPaths
+import           Lib.Types.Core
+import           Lib.Types.Emver
+import           Lib.Types.Emver.Orphans        ( )
+import           Control.Monad.Fail             ( MonadFail(fail) )
+
+data ImageType = ImageTypeTar
+    deriving (Eq, Show)
+
+instance FromJSON ImageType where
+    parseJSON = withText "Image Type" $ \case
+        "tar" -> pure ImageTypeTar
+        wat   -> fail $ "Unknown Image Type: " <> toS wat
+
+data OnionVersion = OnionV2 | OnionV3
+    deriving (Eq, Ord, Show)
+
+instance FromJSON OnionVersion where
+    parseJSON = withText "Onion Version" $ \case
+        "v2" -> pure OnionV2
+        "v3" -> pure OnionV3
+        wat  -> fail $ "Unknown Onion Version: " <> toS wat
+
+data AssetMapping = AssetMapping
+    { assetMappingSource    :: FilePath
+    , assetMappingDest      :: FilePath
+    , assetMappingOverwrite :: Bool
+    }
+    deriving (Eq, Show)
+
+instance FromJSON AssetMapping where
+    parseJSON = withObject "Asset Mapping" $ \o -> do
+        assetMappingSource    <- o .: "src"
+        assetMappingDest      <- o .: "dst"
+        assetMappingOverwrite <- o .: "overwrite"
+        pure $ AssetMapping { .. }
+
+data AppManifest (n :: Nat) where
+    AppManifestV0 ::{ appManifestV0Id :: AppId
+                    , appManifestV0Version :: Version
+                    , appManifestV0Title :: Text
+                    , appManifestV0DescShort :: Text
+                    , appManifestV0DescLong :: Text
+                    , appManifestV0ReleaseNotes :: Text
+                    , appManifestV0PortMapping :: HM.HashMap Word16 Word16
+                    , appManifestV0ImageType :: ImageType
+                    , appManifestV0Mount :: FilePath
+                    , appManifestV0Assets :: [AssetMapping]
+                    , appManifestV0OnionVersion :: OnionVersion
+                    , appManifestV0Dependencies :: HM.HashMap AppId VersionRange
+                    } -> AppManifest 0
+
+instance FromJSON (Some1 AppManifest) where
+    parseJSON = withObject "App Manifest" $ \o -> do
+        o .: "compat" >>= \case
+            ("v0" :: Text) -> Some1 (SNat @0) <$> parseJSON (Object o)
+            compat         -> fail $ "Unknown Manifest Version: " <> toS compat
+
+instance FromJSON (AppManifest 0) where
+    parseJSON = withObject "App Manifest V0" $ \o -> do
+        appManifestV0Id           <- o .: "id"
+        appManifestV0Version      <- o .: "version"
+        appManifestV0Title        <- o .: "title"
+        appManifestV0DescShort    <- o .: "description" >>= (.: "short")
+        appManifestV0DescLong     <- o .: "description" >>= (.: "long")
+        appManifestV0ReleaseNotes <- o .: "release-notes"
+        appManifestV0PortMapping  <- o .: "ports" >>= fmap HM.fromList . traverse parsePortMapping
+        appManifestV0ImageType    <- o .: "image" >>= (.: "type")
+        appManifestV0Mount        <- o .: "mount"
+        appManifestV0Assets       <- o .: "assets" >>= traverse parseJSON
+        appManifestV0OnionVersion <- o .: "hidden-service-version"
+        appManifestV0Dependencies <- o .:? "dependencies" .!= HM.empty >>= traverse parseDepInfo
+        pure $ AppManifestV0 { .. }
+        where
+            parsePortMapping = withObject "Port Mapping" $ \o -> liftA2 (,) (o .: "tor") (o .: "internal")
+            parseDepInfo     = withObject "Dep Info" $ (.: "version")
+
+getAppManifest :: (MonadIO m, HasFilesystemBase sig m) => AppId -> S9ErrT m (Maybe (Some1 AppManifest))
+getAppManifest appId = do
+    base <- ask @"filesystemBase"
+    ExceptT $ first (ManifestParseE appId) <$> liftIO
+        (Yaml.decodeFileEither . toS $ (appMgrAppPath appId <> "manifest.yaml") `relativeTo` base)
+
+uiAvailable :: AppManifest n -> Bool
+uiAvailable = \case
+    AppManifestV0 { appManifestV0PortMapping } -> elem 80 (HM.keys appManifestV0PortMapping)

agent/src/Lib/External/AppMgr.hs

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

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

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

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

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

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

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

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

@@ -0,0 +1,22 @@
+module Lib.External.Metrics.Temperature where
+
+import           Startlude
+
+import qualified Data.Attoparsec.Text          as A
+import qualified Data.Text                     as T
+import           Lib.External.Metrics.Types
+import           System.Process.Text
+
+-- Pi4 Specific
+getTemperature :: MonadIO m => m (Maybe Celsius)
+getTemperature = liftIO $ do
+    (ec, tempString, errlog) <- readProcessWithExitCode "/opt/vc/bin/vcgencmd" ["measure_temp"] ""
+    unless (T.null errlog) $ putStrLn errlog
+    case ec of
+        ExitFailure _ -> pure Nothing
+        ExitSuccess   -> case A.parse tempParser tempString of
+            A.Done _ c -> pure $ Just c
+            _          -> pure Nothing
+
+tempParser :: A.Parser Celsius
+tempParser = A.asciiCI "temp=" *> fmap Celsius A.double <* "'C" <* A.endOfLine

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

@@ -0,0 +1,114 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE QuasiQuotes      #-}
+{-# LANGUAGE RecordWildCards  #-}
+
+module Lib.External.Metrics.Top where
+
+import           Startlude
+
+import qualified Data.HashMap.Strict           as HM
+import           System.Process
+
+import           Lib.Error
+import           Lib.External.Metrics.Types
+import           Lib.External.Util
+import           Util.Text
+
+data TopMetrics = TopMetrics
+    { metricMemPercentageUsed :: Maybe Percentage
+    , metricMemFree           :: Maybe MebiBytes
+    , metricMemUsed           :: Maybe MebiBytes
+
+    , metricSwapTotal         :: Maybe MebiBytes
+    , metricSwapUsed          :: Maybe MebiBytes
+
+    , metricCpuIdle           :: Maybe Percentage
+    , metricCpuUserSpace      :: Maybe Percentage
+    , metricWait              :: Maybe Percentage
+    , metricCpuPercentageUsed :: Maybe Percentage
+    } deriving (Eq, Show)
+
+getTopMetrics :: MonadIO m => S9ErrT m TopMetrics
+getTopMetrics = fmap parseTop runTop
+
+runTop :: MonadIO m => S9ErrT m Text
+runTop = do
+    (_, output, err') <- liftIO $ readProcessWithExitCode "top" ["-bn1"] ""
+    unless (null err') $ throwE . MetricE $ "top command failed with " <> toS err'
+    pure $ toS output
+
+parseTop :: Text -> TopMetrics
+parseTop t = TopMetrics { metricMemPercentageUsed = getMemPercentageUsed <$> mem
+                        , metricMemFree           = MebiBytes . memFree <$> mem
+                        , metricMemUsed           = MebiBytes . memUsed <$> mem
+                        , metricSwapTotal         = MebiBytes . memTotal <$> swapS
+                        , metricSwapUsed          = MebiBytes . memUsed <$> swapS
+                        , metricCpuIdle           = cpuId <$> cpu
+                        , metricCpuUserSpace      = cpuUs <$> cpu
+                        , metricWait              = cpuWa <$> cpu
+                        , metricCpuPercentageUsed = getCpuPercentageUsed <$> cpu
+                        }
+    where
+        topLines = lines t
+        cpu      = getCpuAggregates topLines
+        mem      = getMemAggregates memHeader topLines
+        swapS    = getMemAggregates swapHeader topLines
+
+memHeader :: Text
+memHeader = "MiB Mem"
+
+swapHeader :: Text
+swapHeader = "MiB Swap"
+
+data TopMemAggregates = TopMemAggregates
+    { memTotal :: Double
+    , memFree  :: Double
+    , memUsed  :: Double
+    } deriving (Eq, Show)
+
+cpuHeader :: Text
+cpuHeader = "%Cpu(s)"
+
+data TopCpuAggregates = TopCpuAggregates
+    { cpuUs :: Percentage
+    , cpuSy :: Percentage
+    , cpuNi :: Percentage
+    , cpuId :: Percentage
+    , cpuWa :: Percentage
+    , cpuHi :: Percentage
+    , cpuSi :: Percentage
+    , cpuSt :: Percentage
+    } deriving (Eq, Show)
+
+getMemAggregates :: Text -> [Text] -> Maybe TopMemAggregates
+getMemAggregates header topRes = do
+    memLine <- getLineByHeader header topRes
+    let stats = HM.fromList $ getStats readMaybe memLine
+    memTotal <- HM.lookup "total" stats
+    memFree  <- HM.lookup "free" stats
+    memUsed  <- HM.lookup "used" stats
+    pure TopMemAggregates { .. }
+
+getCpuAggregates :: [Text] -> Maybe TopCpuAggregates
+getCpuAggregates topRes = do
+    memLine <- getLineByHeader cpuHeader topRes
+    let stats = HM.fromList $ getStats (mkPercentage <=< readMaybe) memLine
+    cpuUs <- HM.lookup "us" stats
+    cpuSy <- HM.lookup "sy" stats
+    cpuNi <- HM.lookup "ni" stats
+    cpuId <- HM.lookup "id" stats
+    cpuWa <- HM.lookup "wa" stats
+    cpuHi <- HM.lookup "hi" stats
+    cpuSi <- HM.lookup "si" stats
+    cpuSt <- HM.lookup "st" stats
+    pure TopCpuAggregates { .. }
+
+getCpuPercentageUsed :: TopCpuAggregates -> Percentage
+getCpuPercentageUsed TopCpuAggregates {..} = Percentage (100 - unPercent cpuId)
+
+getMemPercentageUsed :: TopMemAggregates -> Percentage
+getMemPercentageUsed TopMemAggregates {..} = Percentage . truncateTo @Double 10 . (* 100) $ memUsed / memTotal
+
+getStats :: (Text -> Maybe a) -> Text -> [(Text, a)]
+getStats parseData = mapMaybe (parseToPair parseData) . fmap (words . toS) . getMatches statRegex . toS
+    where statRegex = "[0-9]+(.[0-9][0-9]?)? ([\x21-\x7E][^(,|.)]+)"

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

@@ -0,0 +1,89 @@
+module Lib.External.Metrics.Types where
+
+import           Startlude
+
+import           Data.Aeson
+import qualified GHC.Read                       ( Read(..)
+                                                , readsPrec
+                                                )
+import qualified GHC.Show                       ( Show(..) )
+
+import           Lib.External.Util
+
+class Metric a where
+    mUnit :: a -> Text
+    mValue :: a -> Double
+
+toMetricJson :: Metric a => a -> Value
+toMetricJson x = object ["value" .= truncateToS 2 (mValue x), "unit" .= mUnit x]
+toMetricShow :: Metric a => a -> String
+toMetricShow a = show (mValue a) <> " " <> toS (mUnit a)
+
+newtype Percentage = Percentage { unPercent :: Double } deriving (Eq)
+instance Metric Percentage where
+    mValue (Percentage p) = p
+    mUnit _ = "%"
+instance ToJSON Percentage where
+    toJSON = toMetricJson
+instance Show Percentage where
+    show = toMetricShow
+instance Read Percentage where
+    readsPrec _ s = case reverse s of
+        '%' : rest -> case GHC.Read.readsPrec 0 (reverse rest) of
+            [(result, "")] -> case mkPercentage result of
+                Just p -> [(p, "")]
+                _      -> []
+            _ -> []
+        _ -> []
+
+mkPercentage :: Double -> Maybe Percentage
+mkPercentage s | 0 <= s && s <= 100 = Just $ Percentage s
+               | otherwise          = Nothing
+
+newtype MebiBytes = MebiBytes Double
+    deriving stock Eq
+    deriving newtype Num
+
+instance Metric MebiBytes where
+    mValue (MebiBytes p) = p
+    mUnit _ = "MiB"
+instance ToJSON MebiBytes where
+    toJSON = toMetricJson
+instance Show MebiBytes where
+    show = toMetricShow
+
+newtype BytesPerSecond = BytesPerSecond Double
+    deriving stock Eq
+    deriving newtype Num
+
+instance Metric BytesPerSecond where
+    mValue (BytesPerSecond p) = p
+    mUnit _ = "B/s"
+instance ToJSON BytesPerSecond where
+    toJSON = toMetricJson
+instance Show BytesPerSecond where
+    show = toMetricShow
+
+newtype Gigabytes = Gigabytes Double
+    deriving stock Eq
+    deriving newtype Num
+
+instance Metric Gigabytes where
+    mValue (Gigabytes p) = p
+    mUnit _ = "Gb"
+instance ToJSON Gigabytes where
+    toJSON = toMetricJson
+instance Show Gigabytes where
+    show = toMetricShow
+
+newtype Celsius = Celsius { unCelsius :: Double }
+    deriving stock Eq
+    deriving newtype Num
+
+instance Metric Celsius where
+    mValue (Celsius c) = c
+    mUnit _ = "°C"
+instance ToJSON Celsius where
+    toJSON = toMetricJson
+instance Show Celsius where
+    show = toMetricShow

agent/src/Lib/External/Registry.hs

@@ -0,0 +1,196 @@
+{-# LANGUAGE QuasiQuotes     #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Lib.External.Registry where
+
+import           Startlude               hiding ( (<.>)
+                                                , Reader
+                                                , ask
+                                                , runReader
+                                                )
+import           Startlude.ByteStream    hiding ( count )
+
+import           Conduit
+import           Control.Algebra
+import           Control.Effect.Lift
+import           Control.Effect.Error
+import           Control.Effect.Reader.Labelled
+import           Control.Monad.Fail             ( fail )
+import           Control.Monad.Trans.Resource
+import qualified Data.ByteString.Streaming.HTTP
+                                               as S
+import qualified Data.HashMap.Strict           as HM
+import           Data.Maybe                     ( fromJust )
+import           Data.String.Interpolate.IsString
+import           Data.Yaml
+import           Network.HTTP.Client.Conduit    ( Manager )
+import           Network.HTTP.Simple
+import           System.Directory
+import           System.Process
+
+import           Constants
+import           Lib.Algebra.State.RegistryUrl
+import           Lib.Error
+import           Lib.SystemPaths
+import           Lib.Types.Core
+import           Lib.Types.Emver
+import           Lib.Types.ServerApp
+
+newtype AppManifestRes = AppManifestRes
+    { storeApps :: [StoreApp] } deriving (Eq, Show)
+
+newtype RegistryVersionForSpecRes = RegistryVersionForSpecRes
+    { registryVersionForSpec :: Maybe Version } deriving (Eq, Show)
+
+instance FromJSON RegistryVersionForSpecRes where
+    parseJSON Null       = pure (RegistryVersionForSpecRes Nothing)
+    parseJSON (Object o) = do
+        registryVersionForSpec <- o .:? "version"
+        pure . RegistryVersionForSpecRes $ registryVersionForSpec
+    parseJSON _ = fail "expected null or object"
+
+tmpAgentFileName :: Text
+tmpAgentFileName = "agent-tmp"
+
+agentFileName :: Text
+agentFileName = "agent"
+
+userAgentHeader :: ByteString
+userAgentHeader = [i|EmbassyOS/#{agentVersion}|]
+
+setUserAgent :: Request -> Request
+setUserAgent = setRequestHeader "User-Agent" [userAgentHeader]
+
+getYoungAgentBinary :: (Has RegistryUrl sig m, HasLabelled "filesystemBase" (Reader Text) sig m, Has (Lift IO) sig m)
+                    => VersionRange
+                    -> m ()
+getYoungAgentBinary avs = do
+    base <- ask @"filesystemBase"
+    let tmpAgentPath = toS $ executablePath `relativeTo` base </> tmpAgentFileName
+    tmpExists <- sendIO $ doesPathExist tmpAgentPath
+    when tmpExists $ sendIO $ removeFile tmpAgentPath
+    url     <- registryAppAgentUrl avs
+    request <- sendIO . fmap setUserAgent . parseRequestThrow $ toS url
+    sendIO $ runConduitRes $ httpSource request getResponseBody .| sinkFile tmpAgentPath
+    sendIO $ void $ readProcessWithExitCode "chmod" ["700", tmpAgentPath] ""
+
+getLifelineBinary :: (Has RegistryUrl sig m, HasFilesystemBase sig m, MonadIO m) => VersionRange -> m ()
+getLifelineBinary avs = do
+    base <- ask @"filesystemBase"
+    let lifelineTarget = lifelineBinaryPath `relativeTo` base
+    url     <- registryUrl
+    request <- liftIO . fmap setUserAgent . parseRequestThrow $ toS (url </> "sys/lifeline?spec=" <> show avs)
+    liftIO $ runConduitRes $ httpSource request getResponseBody .| sinkFile (toS lifelineTarget)
+    liftIO $ void $ readProcessWithExitCode "chmod" ["700", toS lifelineTarget] ""
+
+getAppManifest :: (MonadIO m, Has (Error S9Error) sig m, Has RegistryUrl sig m) => m AppManifestRes
+getAppManifest = do
+    manifestPath <- registryManifestUrl
+    req          <- liftIO $ fmap setUserAgent . parseRequestThrow $ toS manifestPath
+    val          <- (liftIO . try @SomeException) (httpBS req) >>= \case
+        Left  _ -> throwError RegistryUnreachableE
+        Right a -> pure $ getResponseBody a
+    parseBsManifest val >>= \case
+        Left  e -> throwError $ RegistryParseE manifestPath . toS $ e
+        Right a -> pure a
+
+
+getStoreAppInfo :: (MonadIO m, Has RegistryUrl sig m, Has (Error S9Error) sig m) => AppId -> m (Maybe StoreApp)
+getStoreAppInfo name = find ((== name) . storeAppId) . storeApps <$> getAppManifest
+
+parseBsManifest :: Has RegistryUrl sig m => ByteString -> m (Either String AppManifestRes)
+parseBsManifest bs = do
+    parseRegistryRes' <- parseRegistryRes
+    pure $ parseEither parseRegistryRes' . fromJust . decodeThrow $ bs
+
+parseRegistryRes :: Has RegistryUrl sig m => m (Value -> Parser AppManifestRes)
+parseRegistryRes = do
+    parseAppData' <- parseAppData
+    pure $ withObject "app registry response" $ \obj -> do
+        let keyVals       = HM.toList obj
+        let mManifestApps = fmap (\(k, v) -> parseMaybe (parseAppData' (AppId k)) v) keyVals
+        pure . AppManifestRes . catMaybes $ mManifestApps
+
+registryUrl :: (Has RegistryUrl sig m) => m Text
+registryUrl = maybe "https://registry.start9labs.com:443" show <$> getRegistryUrl
+
+registryManifestUrl :: Has RegistryUrl sig m => m Text
+registryManifestUrl = registryUrl <&> (</> "apps")
+
+registryAppAgentUrl :: Has RegistryUrl sig m => VersionRange -> m Text
+registryAppAgentUrl avs = registryUrl <&> (</> ("sys/agent?spec=" <> show avs))
+
+registryCheckVersionForSpecUrl :: Has RegistryUrl sig m => VersionRange -> m Text
+registryCheckVersionForSpecUrl avs = registryUrl <&> (</> ("sys/version/agent?spec=" <> show avs))
+
+parseAppData :: Has RegistryUrl sig m => m (AppId -> Value -> Parser StoreApp)
+parseAppData = do
+    url <- registryUrl
+    pure $ \storeAppId -> withObject "appmgr app data" $ \ad -> do
+        storeAppTitle            <- ad .: "title"
+        storeAppDescriptionShort <- ad .: "description" >>= (.: "short")
+        storeAppDescriptionLong  <- ad .: "description" >>= (.: "long")
+        storeAppIconUrl          <- fmap (\typ -> toS $ url </> "icons" </> show storeAppId <.> typ) $ ad .: "icon-type"
+        storeAppVersions         <- ad .: "version-info" >>= \case
+            []       -> fail "No Valid Version Info"
+            (x : xs) -> pure $ x :| xs
+        pure StoreApp { .. }
+
+getAppVersionForSpec :: (Has RegistryUrl sig m, Has (Error S9Error) sig m, MonadIO m)
+                     => AppId
+                     -> VersionRange
+                     -> m Version
+getAppVersionForSpec appId spec = do
+    let path = "apps/version" </> show appId <> "?spec=" <> show spec
+    val <- registryRequest path
+    parseOrThrow path val $ withObject "version response" $ \o -> do
+        v <- o .: "version"
+        pure v
+
+getLatestAgentVersion :: (Has RegistryUrl sig m, Has (Error S9Error) sig m, MonadIO m) => m Version
+getLatestAgentVersion = do
+    val <- registryRequest agentVersionPath
+    parseOrThrow agentVersionPath val $ withObject "version response" $ \o -> do
+        v <- o .: "version"
+        pure v
+    where agentVersionPath = "sys/version/agent"
+
+getLatestAgentVersionForSpec :: (Has RegistryUrl sig m, Has (Lift IO) sig m, Has (Error S9Error) sig m)
+                             => VersionRange
+                             -> m (Maybe Version)
+getLatestAgentVersionForSpec avs = do
+    url <- registryUrl
+    req <- sendIO $ fmap setUserAgent . parseRequestThrow . toS $ url </> agentVersionPath
+    res <- fmap (first jsonToS9Exception) . sendIO $ try @JSONException $ parseRes req
+    case res of
+        Left  e -> throwError e
+        Right a -> pure a
+    where
+        parseRes r = registryVersionForSpec . getResponseBody <$> httpJSON r
+        agentVersionPath  = "sys/version/agent?spec=" <> show avs
+        jsonToS9Exception = RegistryParseE (toS agentVersionPath) . show
+
+getAmbassadorUiForSpec :: (Has RegistryUrl sig m, HasLabelled "httpManager" (Reader Manager) sig m, MonadResource m)
+                       => VersionRange
+                       -> ByteStream m ()
+getAmbassadorUiForSpec avs = do
+    url     <- lift registryUrl
+    manager <- lift $ ask @"httpManager"
+    let target = url </> "sys/ambassador-ui.tar.gz?spec=" <> show avs
+    req  <- liftResourceT $ lift $ fmap setUserAgent . parseRequestThrow . toS $ target
+    resp <- lift $ S.http req manager
+    getResponseBody resp
+
+registryRequest :: (Has RegistryUrl sig m, Has (Error S9Error) sig m, MonadIO m) => Text -> m Value
+registryRequest path = do
+    url <- registryUrl
+    req <- liftIO . fmap setUserAgent . parseRequestThrow . toS $ url </> path
+    (liftIO . try @SomeException) (httpJSON req) >>= \case
+        Left  _ -> throwError RegistryUnreachableE
+        Right a -> pure $ getResponseBody a
+
+parseOrThrow :: (Has (Error S9Error) sig m) => Text -> a -> (a -> Parser b) -> m b
+parseOrThrow path val parser = case parseEither parser val of
+    Left  e -> throwError (RegistryParseE path $ toS e)
+    Right a -> pure a

agent/src/Lib/External/Specs/CPU.hs

@@ -0,0 +1,32 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Lib.External.Specs.CPU
+    ( getCpuInfo
+    )
+where
+
+import           Startlude
+import           Protolude.Unsafe               ( unsafeFromJust )
+
+import           Data.String.Interpolate.IsString
+import           System.Process
+
+import           Lib.External.Specs.Common
+
+lscpu :: IO Text
+lscpu = toS <$> readProcess "lscpu" [] ""
+
+getModelName :: Text -> Text
+getModelName = unsafeFromJust . getSpec "Model name"
+
+getCores :: Text -> Text
+getCores = unsafeFromJust . getSpec "CPU(s)"
+
+getClockSpeed :: Text -> Text
+getClockSpeed = (<> "MHz") . unsafeFromJust . getSpec "CPU max"
+
+getCpuInfo :: IO Text
+getCpuInfo = lscpu <&> do
+    model <- getModelName
+    cores <- getCores
+    clock <- getClockSpeed
+    pure $ [i|#{model}: #{cores} cores @ #{clock}|]

agent/src/Lib/External/Specs/Common.hs

@@ -0,0 +1,13 @@
+module Lib.External.Specs.Common where
+
+import           Startlude
+
+import qualified Data.Text                     as T
+
+getSpec :: Text -> Text -> Maybe Text
+getSpec spec output = do
+    mi <- modelItem
+    fmap T.strip $ T.splitOn ":" mi `atMay` 1
+    where
+        items     = lines output
+        modelItem = find (spec `T.isPrefixOf`) items

agent/src/Lib/External/Specs/Memory.hs

@@ -0,0 +1,12 @@
+module Lib.External.Specs.Memory where
+
+import           Startlude
+import           Protolude.Unsafe               ( unsafeFromJust )
+
+import           Lib.External.Specs.Common
+
+catMem :: IO Text
+catMem = readFile "/proc/meminfo"
+
+getMem :: IO Text
+getMem = unsafeFromJust . getSpec "MemTotal" <$> catMem

agent/src/Lib/External/Util.hs

@@ -0,0 +1,17 @@
+{-# LANGUAGE TupleSections #-}
+module Lib.External.Util where
+
+import           Startlude
+
+getLineByHeader :: Text -> [Text] -> Maybe Text
+getLineByHeader t = find (isPrefixOf (toS t :: String) . toS)
+
+truncateTo :: RealFloat a => Int -> a -> Double
+truncateTo n x = realToFrac $ fromIntegral (floor (x * t) :: Integer) / t where t = 10 ^ n
+
+truncateToS :: Int -> Double -> Double
+truncateToS n x = fromIntegral (floor (x * t) :: Integer) / t where t = 10 ^ n
+
+parseToPair :: (Text -> Maybe a) -> [Text] -> Maybe (Text, a)
+parseToPair parse [k, v] = ((k, ) <$> parse v) <|> ((v, ) <$> parse k)
+parseToPair _     _      = Nothing

agent/src/Lib/External/WpaSupplicant.hs

@@ -0,0 +1,102 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Lib.External.WpaSupplicant where
+
+import           Startlude
+
+import           Data.Bitraversable
+import qualified Data.HashMap.Strict           as HM
+import           Data.String.Interpolate.IsString
+import qualified Data.Text                     as T
+import           System.Process
+import           Control.Concurrent.Async.Lifted
+                                               as LAsync
+import           Control.Monad.Trans.Control    ( MonadBaseControl )
+
+runWlan0 :: ReaderT Text m a -> m a
+runWlan0 = flip runReaderT "wlan0"
+
+isConnectedToEthernet :: MonadIO m => m Bool
+isConnectedToEthernet = do
+    liftIO $ not . null . filter (T.isInfixOf "inet ") . lines . toS <$> readProcess "ifconfig" ["eth0"] ""
+
+-- There be bug here: if you're in the US, and add a network in Sweden, you'll set your wpa supplicant to be looking for networks in Sweden.
+-- so you won't be autoconnecting to anything in the US till you add another US guy.
+addNetwork :: MonadIO m => Text -> Text -> Text -> ReaderT Interface m ()
+addNetwork ssid psk country = do
+    interface <- ask
+    networkId <- checkNetwork ssid >>= \case
+        -- If the network already exists, we will update its password.
+        Just nId -> do
+            void . liftIO $ readProcess "wpa_cli" ["-i", toS interface, "new_password", toS nId, [i|"#{psk}"|]] ""
+            pure nId
+
+        -- Otherwise we create the network in the wpa_supplicant
+        Nothing -> do
+            nId <- liftIO $ T.strip . toS <$> readProcess "wpa_cli" ["-i", toS interface, "add_network"] ""
+            void . liftIO $ readProcess "wpa_cli"
+                                        ["-i", toS interface, "set_network", toS nId, "ssid", [i|"#{ssid}"|]]
+                                        ""
+            void . liftIO $ readProcess "wpa_cli" ["-i", toS interface, "set_network", toS nId, "psk", [i|"#{psk}"|]] ""
+            void . liftIO $ readProcess "wpa_cli" ["-i", toS interface, "set_network", toS nId, "scan_ssid", "1"] ""
+            pure nId
+
+    void . liftIO $ readProcess "wpa_cli" ["-i", toS interface, "set", "country", toS country] ""
+    void . liftIO $ readProcess "wpa_cli" ["-i", toS interface, "enable_network", toS networkId] ""
+    void . liftIO $ readProcess "wpa_cli" ["-i", toS interface, "save_config"] ""
+
+removeNetwork :: MonadIO m => Text -> ReaderT Interface m ()
+removeNetwork ssid = do
+    interface <- ask
+    checkNetwork ssid >>= \case
+        Nothing -> pure ()
+        Just x  -> liftIO $ do
+            void $ readProcess "wpa_cli" ["-i", toS interface, "remove_network", [i|#{x}|]] ""
+            void $ readProcess "wpa_cli" ["-i", toS interface, "save_config"] ""
+            void $ readProcess "wpa_cli" ["-i", toS interface, "reconfigure"] ""
+
+listNetworks :: MonadIO m => ReaderT Interface m [Text]
+listNetworks = do
+    interface <- ask
+    liftIO $ mapMaybe (`atMay` 1) . drop 1 . fmap (T.splitOn "\t") . lines . toS <$> readProcess
+        "wpa_cli"
+        ["-i", toS interface, "list_networks"]
+        ""
+
+type Interface = Text
+getCurrentNetwork :: (MonadBaseControl IO m, MonadIO m) => ReaderT Interface m (Maybe Text)
+getCurrentNetwork = do
+    interface <- ask @Text
+    liftIO $ guarded (/= "") . T.init . toS <$> readProcess "iwgetid" [toS interface, "--raw"] ""
+
+selectNetwork :: (MonadBaseControl IO m, MonadIO m) => Text -> Text -> ReaderT Interface m Bool
+selectNetwork ssid country = checkNetwork ssid >>= \case
+    Nothing  -> putStrLn @Text "SSID Not Found" *> pure False
+    Just nId -> do
+        interface <- ask
+        void . liftIO $ readProcess "wpa_cli" ["-i", toS interface, "select_network", toS nId] ""
+        void . liftIO $ readProcess "wpa_cli" ["-i", toS interface, "set", "country", toS country] ""
+        void . liftIO $ readProcess "wpa_cli" ["-i", toS interface, "save_config"] ""
+        mNew <- join . hush <$> LAsync.race (liftIO $ threadDelay 20_000_000)
+                                            (runMaybeT . asum $ repeat (MaybeT getCurrentNetwork))
+        listNetworks >>= \nets ->
+            for_ nets $ \net -> liftIO $ readProcess "wpa_cli" ["-i", toS interface, "enable_network", toS net] ""
+        pure $ case mNew of
+            Nothing         -> False
+            Just newCurrent -> newCurrent == ssid
+
+type NetworkId = Text
+checkNetwork :: MonadIO m => Text -> ReaderT Interface m (Maybe NetworkId)
+checkNetwork ssid = do
+    interface <- ask
+    HM.lookup ssid
+        .   HM.fromList
+        .   mapMaybe (bisequenceA . ((`atMay` 1) &&& (`atMay` 0)))
+        .   drop 1
+        .   fmap (T.splitOn "\t")
+        .   lines
+        .   toS
+        <$> liftIO (readProcess "wpa_cli" ["-i", toS interface, "list_networks"] "")
+
+-- TODO: Live Testing in GHCI
+runWpa :: ReaderT Interface m a -> m a
+runWpa = flip runReaderT "wlp5s0"

agent/src/Lib/IconCache.hs

@@ -0,0 +1,94 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Lib.IconCache where
+
+import           Startlude               hiding ( ask
+                                                , catch
+                                                , throwIO
+                                                , Reader
+                                                )
+
+import           Conduit
+import           Control.Concurrent.STM.TVar
+import           Control.Effect.Reader.Labelled
+import           Crypto.Hash
+import qualified Data.Conduit.Binary           as CB
+import qualified Data.HashMap.Strict           as HM
+import           Data.String.Interpolate.IsString
+import           Network.HTTP.Simple
+import           System.Directory
+import           System.FilePath
+import           System.IO.Error
+import           UnliftIO.Exception
+
+import           Lib.Error
+import           Lib.SystemPaths         hiding ( (</>) )
+import           Lib.Types.Core
+import           Database.Persist.Sql           ( runSqlPool
+                                                , repsert
+                                                , ConnectionPool
+                                                , delete
+                                                )
+import           Model
+import           Control.Effect.Error
+import           Crypto.Hash.Conduit            ( hashFile )
+import           Util.File                      ( removeFileIfExists )
+
+type HasIconTags sig m = HasLabelled "iconTagCache" (Reader (TVar (HM.HashMap AppId (Digest MD5)))) sig m
+
+findIcon :: (HasFilesystemBase sig m, MonadIO m) => AppId -> m (Maybe FilePath)
+findIcon appId = do
+    bp    <- toS <$> getAbsoluteLocationFor iconBasePath
+    icons <- liftIO $ (listDirectory bp) `catch` \(e :: IOException) ->
+        if isDoesNotExistError e then createDirectoryIfMissing True bp *> pure [] else throwIO e
+    pure $ (bp </>) <$> find ((show appId ==) . takeBaseName) icons
+
+saveIcon :: ( HasFilesystemBase sig m
+            , HasIconTags sig m
+            , HasLabelled "databaseConnection" (Reader ConnectionPool) sig m
+            , Has (Error S9Error) sig m
+            , MonadIO m
+            )
+         => String
+         -> m ()
+saveIcon url = do
+    bp  <- toS <$> getAbsoluteLocationFor iconBasePath
+    req <- case parseRequest url of
+        Nothing -> throwError $ RegistryParseE (toS url) "invalid url"
+        Just x  -> pure x
+    let saveAction = runConduit $ httpSource req getResponseBody .| CB.sinkFileCautious (bp </> takeFileName url)
+    liftIO $ runResourceT $ saveAction `catch` \(e :: IOException) -> if isDoesNotExistError e
+        then do
+            liftIO $ createDirectoryIfMissing True bp
+            saveAction
+        else throwIO e
+    tag <- hashFile (bp </> takeFileName url)
+    saveTag (AppId . toS $ takeFileName url) tag
+
+saveTag :: (HasIconTags sig m, HasLabelled "databaseConnection" (Reader ConnectionPool) sig m, MonadIO m)
+        => AppId
+        -> Digest MD5
+        -> m ()
+saveTag appId tag = do
+    cache <- ask @"iconTagCache"
+    pool  <- ask @"databaseConnection"
+    liftIO $ runSqlPool (repsert (IconDigestKey appId) (IconDigest tag)) pool `catch` \(e :: SomeException) ->
+        putStrLn @Text [i|Icon Cache Insertion Failed!: #{appId}, #{tag}, #{e}|]
+    liftIO $ atomically $ modifyTVar cache $ HM.insert appId tag
+
+clearIcon :: ( MonadIO m
+             , HasLabelled "iconTagCache" (Reader (TVar (HM.HashMap AppId v0))) sig m
+             , HasLabelled "databaseConnection" (Reader ConnectionPool) sig m
+             , HasLabelled "filesystemBase" (Reader Text) sig m
+             )
+          => AppId
+          -> m ()
+clearIcon appId = do
+    db       <- ask @"databaseConnection"
+    iconTags <- ask @"iconTagCache"
+    liftIO . atomically $ modifyTVar iconTags (HM.delete appId)
+    liftIO $ runSqlPool (delete (IconDigestKey appId)) db
+    findIcon appId >>= \case
+        Nothing -> pure ()
+        Just x  -> removeFileIfExists x

agent/src/Lib/Metrics.hs

@@ -0,0 +1,158 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module Lib.Metrics where
+
+import           Startlude
+
+import           Data.Aeson
+import           Data.IORef
+
+import           Foundation
+import           Lib.Error
+import           Lib.External.Metrics.Df
+import           Lib.External.Metrics.Iotop
+import           Lib.External.Metrics.ProcDev
+import           Lib.External.Metrics.Temperature
+import           Lib.External.Metrics.Top
+import           Lib.External.Metrics.Types
+
+-- will throw only if one of '$ top', '$ iotop, '$ procDev' commands fails on the command line.
+getServerMetrics :: MonadIO m => AgentCtx -> S9ErrT m ServerMetrics
+getServerMetrics agentCtx = do
+    temp            <- getTemperature
+    df              <- getDfMetrics
+    top             <- getTopMetrics
+    iotop           <- getIotopMetrics
+    (_, _, procDev) <- liftIO . readIORef . appProcDevMomentCache $ agentCtx
+
+    pure $ fromCommandLineMetrics (temp, df, top, iotop, procDev)
+
+data ServerMetrics = ServerMetrics
+    { serverMetricsTemperature       :: Maybe Celsius
+
+    , serverMetricMemPercentageUsed  :: Maybe Percentage
+    , serverMetricMemFree            :: Maybe MebiBytes
+    , serverMetricMemUsed            :: Maybe MebiBytes
+    , serverMetricSwapTotal          :: Maybe MebiBytes
+    , serverMetricSwapUsed           :: Maybe MebiBytes
+
+    , serverMetricCpuIdle            :: Maybe Percentage
+    , serverMetricCpuUserSpace       :: Maybe Percentage
+    , serverMetricWait               :: Maybe Percentage
+    , serverMetricCpuPercentageUsed  :: Maybe Percentage
+
+    , serverMetricCurrentRead        :: Maybe BytesPerSecond
+    , serverMetricCurrentWrite       :: Maybe BytesPerSecond
+    , serverMetricTotalRead          :: Maybe BytesPerSecond
+    , serverMetricTotalWrite         :: Maybe BytesPerSecond
+
+    , serverMetricRBytesPerSecond    :: Maybe BytesPerSecond
+    , serverMetricRPacketsPerSecond  :: Maybe BytesPerSecond
+    , serverMetricRErrorsPerSecond   :: Maybe BytesPerSecond
+    , serverMetricTBytesPerSecond    :: Maybe BytesPerSecond
+    , serverMetricTPacketsPerSecond  :: Maybe BytesPerSecond
+    , serverMetricTErrorsPerSecond   :: Maybe BytesPerSecond
+
+    , serverMetricDiskSize           :: Maybe Gigabytes
+    , serverMetricDiskUsed           :: Maybe Gigabytes
+    , serverMetricDiskAvailable      :: Maybe Gigabytes
+    , serverMetricDiskUsedPercentage :: Maybe Percentage
+    } deriving (Eq, Show)
+
+instance ToJSON ServerMetrics where
+    toJSON ServerMetrics {..} = object
+        [ "GENERAL" .= object ["Temperature" .= serverMetricsTemperature]
+        , "MEMORY" .= object
+            [ "Percent Used" .= serverMetricMemPercentageUsed
+            , "Free" .= serverMetricMemFree
+            , "Used" .= serverMetricMemUsed
+            , "Swap Used" .= serverMetricSwapUsed
+            , "Swap Free" .= serverMetricSwapTotal ?-? serverMetricSwapUsed
+            ]
+        , "CPU" .= object
+            [ "Percent Used" .= serverMetricCpuPercentageUsed
+            , "Percent Free" .= serverMetricCpuIdle
+            , "Percent User Space" .= serverMetricCpuUserSpace
+            , "Percent IO Wait" .= serverMetricWait
+            ]
+        , "DISK" .= object
+            [ "Percent Used" .= serverMetricDiskUsedPercentage
+            , "Size" .= serverMetricDiskSize
+            , "Used" .= serverMetricDiskUsed
+            , "Free" .= serverMetricDiskAvailable
+            , "Total Read" .= serverMetricTotalRead
+            , "Total Write" .= serverMetricTotalWrite
+            , "Current Read" .= serverMetricCurrentRead
+            , "Current Write" .= serverMetricCurrentWrite
+            ]
+        , "NETWORK" .= object
+            [ "Bytes Received" .= serverMetricRBytesPerSecond
+            , "Packets Received" .= serverMetricRPacketsPerSecond
+            , "Errors Received" .= serverMetricRErrorsPerSecond
+            , "Bytes Transmitted" .= serverMetricTBytesPerSecond
+            , "Packets Transmitted" .= serverMetricTPacketsPerSecond
+            , "Errors Transmitted" .= serverMetricTErrorsPerSecond
+            ]
+        ]
+    toEncoding ServerMetrics {..} = (pairs . fold)
+        [ "GENERAL" .= object ["Temperature" .= serverMetricsTemperature]
+        , "MEMORY" .= object
+            [ "Percent Used" .= serverMetricMemPercentageUsed
+            , "Free" .= serverMetricMemFree
+            , "Used" .= serverMetricMemUsed
+            , "Swap Used" .= serverMetricSwapUsed
+            , "Swap Free" .= serverMetricSwapTotal ?-? serverMetricSwapUsed
+            ]
+        , "CPU" .= object
+            [ "Percent Used" .= serverMetricCpuPercentageUsed
+            , "Percent Free" .= serverMetricCpuIdle
+            , "Percent User Space" .= serverMetricCpuUserSpace
+            , "Percent IO Wait" .= serverMetricWait
+            ]
+        , "DISK" .= object
+            [ "Percent Used" .= serverMetricDiskUsedPercentage
+            , "Size" .= serverMetricDiskSize
+            , "Used" .= serverMetricDiskUsed
+            , "Free" .= serverMetricDiskAvailable
+            , "Total Read" .= serverMetricTotalRead
+            , "Total Write" .= serverMetricTotalWrite
+            , "Current Read" .= serverMetricCurrentRead
+            , "Current Write" .= serverMetricCurrentWrite
+            ]
+        , "NETWORK" .= object
+            [ "Bytes Received" .= serverMetricRBytesPerSecond
+            , "Packets Received" .= serverMetricRPacketsPerSecond
+            , "Errors Received" .= serverMetricRErrorsPerSecond
+            , "Bytes Transmitted" .= serverMetricTBytesPerSecond
+            , "Packets Transmitted" .= serverMetricTPacketsPerSecond
+            , "Errors Transmitted" .= serverMetricTErrorsPerSecond
+            ]
+        ]
+
+fromCommandLineMetrics :: (Maybe Celsius, DfMetrics, TopMetrics, IotopMetrics, ProcDevMetrics) -> ServerMetrics
+fromCommandLineMetrics (temp, DfMetrics {..}, TopMetrics {..}, IotopMetrics {..}, ProcDevMetrics {..}) = ServerMetrics
+    { serverMetricsTemperature       = temp
+    , serverMetricMemPercentageUsed  = metricMemPercentageUsed
+    , serverMetricMemFree            = metricMemFree
+    , serverMetricMemUsed            = metricMemUsed
+    , serverMetricSwapTotal          = metricSwapTotal
+    , serverMetricSwapUsed           = metricSwapUsed
+    , serverMetricCpuIdle            = metricCpuIdle
+    , serverMetricCpuUserSpace       = metricCpuUserSpace
+    , serverMetricWait               = metricWait
+    , serverMetricCpuPercentageUsed  = metricCpuPercentageUsed
+    , serverMetricCurrentRead        = metricCurrentRead
+    , serverMetricCurrentWrite       = metricCurrentWrite
+    , serverMetricTotalRead          = metricTotalRead
+    , serverMetricTotalWrite         = metricTotalWrite
+    , serverMetricRBytesPerSecond    = metricRBytesPerSecond
+    , serverMetricRPacketsPerSecond  = metricRPacketsPerSecond
+    , serverMetricRErrorsPerSecond   = metricRErrorsPerSecond
+    , serverMetricTBytesPerSecond    = metricTBytesPerSecond
+    , serverMetricTPacketsPerSecond  = metricTPacketsPerSecond
+    , serverMetricTErrorsPerSecond   = metricTErrorsPerSecond
+    , serverMetricDiskSize           = metricDiskSize
+    , serverMetricDiskUsed           = metricDiskUsed
+    , serverMetricDiskAvailable      = metricDiskAvailable
+    , serverMetricDiskUsedPercentage = metricDiskUsedPercentage
+    }

agent/src/Lib/Migration.hs

@@ -0,0 +1,96 @@
+{-# LANGUAGE NamedFieldPuns      #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE TypeApplications    #-}
+
+module Lib.Migration where
+
+import           Data.Aeson
+import           Data.Aeson.Types
+import           Data.FileEmbed
+import           Data.Text                      ( split
+                                                , splitOn
+                                                , strip
+                                                )
+import           Database.Persist.Sql
+import           Lib.Error
+import           Lib.Types.Emver
+import           Model
+import           Startlude
+
+ioMigrationDbVersion :: ConnectionPool -> Version -> Version -> IO ()
+ioMigrationDbVersion dbConn sourceVersion targetVersion = do
+    putStrLn @Text $ "Executing migrations from " <> show sourceVersion <> " to " <> show targetVersion
+    runSqlPool (migrateDbVersions sourceVersion targetVersion & handleS9ErrNuclear) dbConn
+
+getCurrentDbVersion :: MonadIO m => ReaderT SqlBackend m (Maybe Version)
+getCurrentDbVersion =
+    fmap (executedMigrationTgtVersion . entityVal) <$> selectFirst [] [Desc ExecutedMigrationCreatedAt]
+
+getMigrations :: [MigrationFile]
+getMigrations = mapMaybe toMigrationFile $(embedDir "./migrations")
+
+migrateDbVersions :: MonadIO m => Version -> Version -> S9ErrT (ReaderT SqlBackend m) ()
+migrateDbVersions sourceVersion targetVersion = case mkMigrationCollection sourceVersion targetVersion getMigrations of
+    Just (MigrationCollection migrations) -> lift $ traverse executeMigration migrations $> ()
+    Nothing ->
+        throwE . PersistentE $ "No path of migrations from " <> show sourceVersion <> " to " <> show targetVersion
+
+executeMigration :: MonadIO m => MigrationFile -> ReaderT SqlBackend m ()
+executeMigration mf = migrateSql mf >> insertMigration mf $> ()
+
+insertMigration :: MonadIO m => MigrationFile -> ReaderT SqlBackend m (Key ExecutedMigration)
+insertMigration (MigrationFile source target _) = do
+    now <- liftIO getCurrentTime
+    fmap entityKey . insertEntity $ ExecutedMigration now now source target
+
+migrateSql :: MonadIO m => MigrationFile -> ReaderT SqlBackend m ()
+migrateSql MigrationFile { sqlContent } = do
+    print sqlContent'
+    traverse_ runIt sqlContent'
+    where
+        runIt       = liftA2 (*>) (liftIO . putStrLn) $ flip (rawSql @(Single Int)) [] . (<> ";") . strip
+        sqlContent' = filter (/= "") . fmap strip . split (== ';') $ decodeUtf8 sqlContent
+
+toMigrationFile :: (FilePath, ByteString) -> Maybe MigrationFile
+toMigrationFile (fp, bs) = case splitOn "::" (toS fp) of
+    [source, target] -> do
+        sourceVersion <- parseMaybe parseJSON $ String source
+        targetVersion <- parseMaybe parseJSON $ String target
+        let sqlContent = bs
+        pure MigrationFile { .. }
+    _ -> Nothing
+
+newtype MigrationCollection = MigrationCollection { unMigrations :: [MigrationFile] } deriving (Eq, Show)
+mkMigrationCollection :: Version -> Version -> [MigrationFile] -> Maybe MigrationCollection
+mkMigrationCollection source target migrations
+    | null migrations
+    = Nothing
+    | source == target
+    = Just $ MigrationCollection []
+    | otherwise
+    = let mNext = maximumByMay targetVersion $ filter
+              (\m -> sourceVersion m == source && targetVersion m > source && targetVersion m <= target)
+              migrations
+      in  case mNext of
+              Nothing -> Nothing
+              Just nextMig ->
+                  MigrationCollection
+                      .   (nextMig :)
+                      .   unMigrations
+                      <$> mkMigrationCollection (targetVersion nextMig) target migrations
+    where
+        maximumByMay :: (Foldable t, Ord b) => (a -> b) -> t a -> Maybe a
+        maximumByMay f as =
+            let reducer x acc = case acc of
+                    Nothing -> Just x
+                    Just y  -> if f x > f y then Just x else Just y
+            in  foldr reducer Nothing as
+
+data MigrationFile = MigrationFile
+    { sourceVersion :: Version
+    , targetVersion :: Version
+    , sqlContent    :: ByteString
+    }
+    deriving (Eq, Show)

agent/src/Lib/Notifications.hs

@@ -0,0 +1,109 @@
+{-# LANGUAGE GADTs           #-}
+{-# LANGUAGE QuasiQuotes     #-}
+{-# LANGUAGE RecordWildCards #-}
+module Lib.Notifications where
+
+import           Startlude               hiding ( get )
+
+import           Data.String.Interpolate.IsString
+import           Data.UUID.V4
+import           Database.Persist
+import           Database.Persist.Sql
+
+import           Lib.Error
+import           Lib.Types.Core
+import           Lib.Types.Emver
+import           Model
+
+emit :: MonadIO m => AppId -> Version -> AgentNotification -> SqlPersistT m (Entity Notification)
+emit appId version ty = do
+    uuid <- liftIO nextRandom
+    now  <- liftIO getCurrentTime
+    let k = (NotificationKey uuid)
+    let v = (Notification now Nothing appId version (toCode ty) (toTitle ty) (toMessage appId version ty))
+    insertKey k v
+    putStrLn $ toMessage appId version ty
+    pure $ Entity k v
+
+archive :: MonadIO m => [Key Notification] -> SqlPersistT m [Entity Notification]
+archive eventIds = do
+    now    <- liftIO getCurrentTime
+    events <- for eventIds $ flip updateGet [NotificationArchivedAt =. Just now]
+    pure $ zipWith Entity eventIds events
+
+data AgentNotification =
+      InstallSuccess
+    | InstallFailedGetApp
+    | InstallFailedAppMgrExitCode Int
+    | InstallFailedS9Error S9Error
+    | BackupSucceeded
+    | BackupFailed S9Error
+    | RestoreSucceeded
+    | RestoreFailed S9Error
+    | RestartFailed S9Error
+    | DockerFuckening
+
+-- CODES
+-- RULES:
+-- The first digit indicates the call to action and the tone of the error code as follows
+-- 0: General Information, No Action Required, Neutral Tone
+-- 1: Success Message, No Action Required, Positive Tone
+-- 2: Warning, Action Possible but NOT Required, Negative Tone
+-- 3: Error, Action Required, Negative Tone
+--
+-- The second digit indicates where the error was originated from as follows
+-- 0: Originates from Agent
+-- 1: Originates from App (Not presently used)
+--
+-- The remaining section of the code may be as long as you want but must be at least one digit
+-- EXAMPLES:
+-- 100
+-- |||> Code "0"
+-- ||> Originates from Agent
+-- |> Success Message
+--
+-- 213
+-- |||> Code "3"
+-- ||> Originates from App
+-- |> Warning Message
+--
+toCode :: AgentNotification -> Text
+toCode InstallSuccess                  = "100"
+toCode BackupSucceeded                 = "101"
+toCode RestoreSucceeded                = "102"
+toCode InstallFailedGetApp             = "300"
+toCode (InstallFailedAppMgrExitCode _) = "301"
+toCode DockerFuckening                 = "302"
+toCode (InstallFailedS9Error _)        = "303"
+toCode (BackupFailed         _)        = "304"
+toCode (RestoreFailed        _)        = "305"
+toCode (RestartFailed        _)        = "306"
+
+toTitle :: AgentNotification -> Text
+toTitle InstallSuccess                  = "Install succeeded"
+toTitle BackupSucceeded                 = "Backup succeeded"
+toTitle RestoreSucceeded                = "Restore succeeded"
+toTitle InstallFailedGetApp             = "Install failed"
+toTitle (InstallFailedAppMgrExitCode _) = "Install failed"
+toTitle (InstallFailedS9Error        _) = "Install failed"
+toTitle (BackupFailed                _) = "Backup failed"
+toTitle (RestoreFailed               _) = "Restore failed"
+toTitle (RestartFailed               _) = "Restart failed"
+toTitle DockerFuckening                 = "App unstoppable"
+
+toMessage :: AppId -> Version -> AgentNotification -> Text
+toMessage appId version InstallSuccess = [i|Successfully installed #{appId} at version #{version}|]
+toMessage appId version n@InstallFailedGetApp =
+    [i|Failed to install #{appId} at version #{version}, this should be impossible, contact support and give them the code #{toCode n}|]
+toMessage appId version n@(InstallFailedAppMgrExitCode ec)
+    = [i|Failed to install #{appId} at version #{version}, many things could cause this, contact support and give them the code #{toCode n}.#{ec}|]
+toMessage appId version n@(InstallFailedS9Error e)
+    = [i|Failed to install #{appId} at version #{version}, the dependency reverse index could not be updated, contact support and give them the code #{toCode n}.#{errorCode $ toError e}|]
+toMessage appId _version DockerFuckening
+    = [i|Despite attempting to stop #{appId}, it is still running. This is a known issue that can only be solved by restarting the server|]
+toMessage appId _version BackupSucceeded        = [i|Successfully backed up #{appId}|]
+toMessage appId _version RestoreSucceeded       = [i|Successfully restored #{appId}|]
+toMessage appId _version (BackupFailed  reason) = [i|Failed to back up #{appId}: #{errorMessage $ toError reason}|]
+toMessage appId _version (RestoreFailed reason) = [i|Failed to restore #{appId}: #{errorMessage $ toError reason}|]
+toMessage appId _version (RestartFailed reason) =
+    [i|Failed to restart #{appId}: #{errorMessage $ toError reason}. Please manually restart|]

agent/src/Lib/Password.hs

@@ -0,0 +1,77 @@
+module Lib.Password where
+
+import           Startlude
+import           Yesod.Auth.Util.PasswordStore  ( makePassword
+                                                , verifyPassword
+                                                , passwordStrength
+                                                )
+import qualified Data.ByteString.Char8         as BS
+                                                ( pack
+                                                , unpack
+                                                )
+import           Data.Text                      ( pack
+                                                , unpack
+                                                )
+
+import           Model
+
+-- Root account identifier
+rootAccountName :: Text
+rootAccountName = "embassy-root"
+
+
+-- | Default strength used for passwords (see "Yesod.Auth.Util.PasswordStore"
+--   for details).
+defaultStrength :: Int
+defaultStrength = 17
+
+-- | The type representing account information stored in the database should
+--   be an instance of this class.  It just provides the getter and setter
+--   used by the functions in this module.
+class HasPasswordHash account where
+    getPasswordHash :: account -> Text
+    setPasswordHash :: Text -> account -> account
+
+    {-# MINIMAL getPasswordHash, setPasswordHash #-}
+
+
+-- | Calculate a new-style password hash using "Yesod.Auth.Util.PasswordStore".
+passwordHash :: MonadIO m => Int -> Text -> m Text
+passwordHash strength pwd = do
+    h <- liftIO $ makePassword (BS.pack $ unpack pwd) strength
+    return $ pack $ BS.unpack h
+
+-- | Set password for account, using the given strength setting. Use this
+--   function, or 'setPassword', to produce a account record containing the
+--   hashed password.  Unlike previous versions of this module, no separate
+--   salt field is required for new passwords (but it may still be required
+--   for compatibility while old password hashes remain in the database).
+--
+--   This function does not change the database; the calling application
+--   is responsible for saving the data which is returned.
+setPasswordStrength :: (MonadIO m, HasPasswordHash account) => Int -> Text -> account -> m account
+setPasswordStrength strength pwd u = do
+    hashed <- passwordHash strength pwd
+    return $ setPasswordHash hashed u
+
+-- | As 'setPasswordStrength', but using the 'defaultStrength'
+setPassword :: (MonadIO m, HasPasswordHash account) => Text -> account -> m account
+setPassword = setPasswordStrength defaultStrength
+
+validatePass :: HasPasswordHash u => u -> Text -> Bool
+validatePass account password = do
+    let h = getPasswordHash account
+    -- NB plaintext password characters are truncated to 8 bits here,
+    -- and also in passwordHash above (the hash is already 8 bit).
+    -- This is for historical compatibility, but in practice it is
+    -- unlikely to reduce the entropy of most users' alphabets by much.
+    let hash'     = BS.pack $ unpack h
+        password' = BS.pack $ unpack password
+    if passwordStrength hash' > 0
+        -- Will give >0 for valid hash format, else treat as if wrong password
+        then verifyPassword password' hash'
+        else False
+
+instance HasPasswordHash Account where
+    getPasswordHash = accountPassword
+    setPasswordHash h u = u { accountPassword = h }

agent/src/Lib/ProductKey.hs

@@ -0,0 +1,12 @@
+module Lib.ProductKey where
+
+import           Startlude
+import           Protolude.Unsafe               ( unsafeHead )
+
+import           System.FilePath
+
+productKeyPath :: FilePath -> FilePath
+productKeyPath rt = rt </> "root/agent/product_key"
+
+getProductKey :: Text -> IO Text
+getProductKey rt = unsafeHead . lines <$> readFile (productKeyPath $ toS rt)

agent/src/Lib/SelfUpdate.hs

@@ -0,0 +1,226 @@
+{-# LANGUAGE QuasiQuotes         #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE TupleSections       #-}
+module Lib.SelfUpdate where
+
+import           Startlude               hiding ( runReader )
+
+import           Control.Carrier.Error.Either
+import           Control.Lens
+import           Data.Aeson
+import qualified Data.ByteString.Char8         as B8
+import           Data.IORef
+import           Data.List
+import           Data.String.Interpolate.IsString
+import           System.Posix.Files
+import           System.Process
+
+import           Constants
+import           Foundation
+import           Handler.Types.V0.Base
+import           Lib.Algebra.State.RegistryUrl
+import           Lib.Error
+import           Lib.External.Registry
+import           Lib.Sound                     as Sound
+import           Lib.Synchronizers
+import           Lib.SystemPaths
+import           Lib.Types.Emver
+import           Lib.WebServer
+import           Settings
+
+youngAgentPort :: Word16
+youngAgentPort = 5960
+
+waitForUpdateSignal :: AgentCtx -> IO ()
+waitForUpdateSignal foundation = do
+    eNewVersion <- runS9ErrT $ do
+        spec <- lift . takeMVar . appSelfUpdateSpecification $ foundation
+        let settings = appSettings foundation
+        v <- interp settings (getLatestAgentVersionForSpec spec) >>= \case
+            Nothing -> throwE $ UpdateSelfE GetLatestCompliantVersion "Not Found"
+            Just v  -> pure v
+        liftIO $ writeIORef (appIsUpdating foundation) (Just v)
+        updateAgent foundation spec
+    case eNewVersion of
+        Right (newVersion, youngAgentProcess) -> do
+            putStrLn @Text $ "New agent up and running: " <> show newVersion
+            runReaderT replaceExecutableWithYoungAgent (appSettings foundation)
+            killYoungAgent youngAgentProcess
+            shutdownAll []
+        Left e@(UpdateSelfE GetYoungAgentBinary _) -> do
+            logerror e
+            writeIORef (appIsUpdating foundation) Nothing
+            waitForNextUpdateSignal
+        Left e@(UpdateSelfE ShutdownWeb _) -> do
+            logerror e
+            writeIORef (appIsUpdating foundation) Nothing
+            waitForNextUpdateSignal
+        Left e@(UpdateSelfE StartupYoungAgent _) -> do
+            logerror e
+            writeIORef (appIsUpdating foundation) Nothing
+            waitForNextUpdateSignal
+        Left e@(UpdateSelfE (PingYoungAgent youngAgentProcess) _) -> do
+            logerror e
+            killYoungAgent youngAgentProcess
+            writeIORef (appIsUpdating foundation) Nothing
+            waitForNextUpdateSignal
+        Left e -> do -- unreachable
+            logerror e
+            waitForNextUpdateSignal
+    where
+        waitForNextUpdateSignal = waitForUpdateSignal foundation
+        logerror                = putStrLn @Text . show
+        interp s = ExceptT . liftIO . runError . injectFilesystemBaseFromContext s . runRegistryUrlIOC
+
+
+updateAgent :: AgentCtx -> VersionRange -> S9ErrT IO (Version, ProcessHandle)
+updateAgent foundation avs = do
+    -- get and save the binary of the new agent app
+    putStrLn @Text $ "Acquiring young agent binary for specification: " <> show avs
+    (tryTo . interp settings . getYoungAgentBinary $ avs) >>= \case
+        Left  e -> throwE $ UpdateSelfE GetYoungAgentBinary (show e)
+        Right _ -> putStrLn @Text "Succeeded"
+
+    -- start the new agent app. This is non blocking as a success would block indefinitely
+    startupYoungAgentProcessHandle <- startup 5
+
+    putStrLn @Text $ "Beginning young agent ping attempts..."
+    let attemptPing = do
+            lift (threadDelay delayBetweenAttempts)
+            tryTo pingYoungAgent >>= \case
+                Left e -> do
+                    putStrLn @Text (show e)
+                    pure (Left e)
+                x -> pure x
+    retryAction attempts attemptPing >>= \case
+        Left  e  -> throwE $ UpdateSelfE (PingYoungAgent startupYoungAgentProcessHandle) (show e)
+        Right av -> putStrLn @Text "Succeeded" >> pure (av, startupYoungAgentProcessHandle)
+    where
+        tryTo                = lift . try @SomeException
+        settings             = appSettings foundation
+        attempts             = 8
+        delayBetweenAttempts = 5 * 1000000 :: Int -- 5 seconds
+        startup :: Int -> S9ErrT IO ProcessHandle
+        startup startupAttempts = do
+            putStrLn @Text $ "Starting up young agent..."
+            tryTo (runReaderT startupYoungAgent $ appSettings foundation) >>= \case
+                Left e -> if "busy" `isInfixOf` show e && startupAttempts > 0-- sometimes the file handle hasn't closed yet
+                    then do
+                        putStrLn @Text "agent-tmp busy, reattempting in 500ms"
+                        liftIO (threadDelay 500_000)
+                        startup (startupAttempts - 1)
+                    else do
+                        putStrLn @Text (show e)
+                        throwE $ UpdateSelfE StartupYoungAgent (show e)
+                Right ph -> putStrLn @Text "Succeeded" >> pure ph
+        interp s = liftIO . injectFilesystemBaseFromContext s . injectFilesystemBaseFromContext s . runRegistryUrlIOC
+
+
+
+retryAction :: Monad m => Integer -> m (Either e a) -> m (Either e a)
+retryAction 1        action = action
+retryAction maxTries action = do
+    success <- action
+    case success of
+        Right a -> pure $ Right a
+        Left  _ -> retryAction (maxTries - 1) action
+
+replaceExecutableWithYoungAgent :: (MonadReader AppSettings m, MonadIO m) => m ()
+replaceExecutableWithYoungAgent = do
+    rt <- asks appFilesystemBase
+    let tmpAgent = (executablePath `relativeTo` rt) </> tmpAgentFileName
+    let agent    = (executablePath `relativeTo` rt) </> agentFileName
+
+    liftIO $ removeLink (toS agent)
+    liftIO $ rename (toS tmpAgent) (toS agent)
+
+
+-- We assume that all app versions must listen on the same port.
+youngAgentUrl :: Text
+youngAgentUrl = "http://localhost:" <> show youngAgentPort
+
+pingYoungAgent :: IO Version
+pingYoungAgent = do
+    (code, st_out, st_err) <- readProcessWithExitCode "curl" [toS $ toS youngAgentUrl </> "version"] ""
+    putStrLn st_out
+    putStrLn st_err
+    case code of
+        ExitSuccess -> case decodeStrict $ B8.pack st_out of
+            Nothing                 -> throwIO . InternalS9Error $ "unparseable version: " <> toS st_out
+            Just (AppVersionRes av) -> pure av
+        ExitFailure e -> throwIO . InternalS9Error $ "curl failure with exit code: " <> show e
+
+startupYoungAgent :: (MonadReader AppSettings m, MonadIO m) => m ProcessHandle
+startupYoungAgent = do
+    rt <- asks appFilesystemBase
+    let cmd = (proc (toS $ (executablePath `relativeTo` rt) </> tmpAgentFileName) ["--port", show youngAgentPort])
+            { create_group = True
+            }
+    ph <- liftIO $ view _4 <$> createProcess cmd
+    liftIO $ threadDelay 1_000_000 -- 1 second
+    liftIO $ getProcessExitCode ph >>= \case
+        Nothing -> pure ph
+        Just e  -> throwIO . InternalS9Error $ "young agent exited prematurely with exit code: " <> show e
+
+killYoungAgent :: ProcessHandle -> IO ()
+killYoungAgent p = do
+    mEC <- getProcessExitCode p
+    case mEC of
+        Nothing -> interruptProcessGroupOf p
+        Just _  -> pure ()
+    threadDelay appEndEstimate
+    where appEndEstimate = 10 * 1000000 :: Int --10 seconds
+
+runSyncOps :: [SyncOp] -> ReaderT AgentCtx IO [(Bool, Bool)]
+runSyncOps syncOps = do
+    ctx <- ask
+    let setUpdate b = if b
+            then liftIO $ writeIORef (appIsUpdating ctx) (Just agentVersion)
+            else liftIO $ writeIORef (appIsUpdating ctx) Nothing
+    res <- for syncOps $ \syncOp -> do
+        shouldRun <- syncOpShouldRun syncOp
+        putStrLn @Text [i|Sync Op "#{syncOpName syncOp}" should run: #{shouldRun}|]
+        when shouldRun $ do
+            putStrLn @Text [i|Running Sync Op: #{syncOpName syncOp}|]
+            setUpdate True
+            syncOpRun syncOp
+        pure $ (syncOpRequiresReboot syncOp, shouldRun)
+    setUpdate False
+    pure res
+
+synchronizeSystemState :: AgentCtx -> Version -> IO ()
+synchronizeSystemState ctx _version = handle @SomeException cleanup $ flip runReaderT ctx $ do
+    (restartsAndRuns, mTid) <- case synchronizer of
+        Synchronizer { synchronizerOperations } -> flip runStateT Nothing $ for synchronizerOperations $ \syncOp -> do
+            shouldRun <- lift $ syncOpShouldRun syncOp
+            putStrLn @Text [i|Sync Op "#{syncOpName syncOp}" should run: #{shouldRun}|]
+            when shouldRun $ do
+                whenM (isNothing <$> get) $ do
+                    tid <- liftIO . forkIO . forever $ playSong 300 updateInProgress *> threadDelay 20_000_000
+                    put (Just tid)
+                putStrLn @Text [i|Running Sync Op: #{syncOpName syncOp}|]
+                setUpdate True
+                lift $ syncOpRun syncOp
+            pure $ (syncOpRequiresReboot syncOp, shouldRun)
+    case mTid of
+        Nothing  -> pure ()
+        Just tid -> liftIO $ killThread tid
+    setUpdate False
+    when (any snd restartsAndRuns) $ liftIO $ playSong 400 marioPowerUp
+    when (any (uncurry (&&)) restartsAndRuns) $ liftIO do
+        callCommand "/bin/sync"
+        callCommand "/sbin/reboot"
+    where
+        setUpdate :: MonadIO m => Bool -> m ()
+        setUpdate b = if b
+            then liftIO $ writeIORef (appIsUpdating ctx) (Just agentVersion)
+            else liftIO $ writeIORef (appIsUpdating ctx) Nothing
+        cleanup :: SomeException -> IO ()
+        cleanup e = do
+            void $ try @SomeException Sound.stop
+            void $ try @SomeException Sound.unexport
+            let e' = InternalE $ show e
+            flip runReaderT ctx $ cantFail $ failUpdate e'
+

agent/src/Lib/Sound.hs

@@ -0,0 +1,248 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections       #-}
+module Lib.Sound where
+
+import           Startlude               hiding ( rotate )
+
+import           Control.Monad.Trans.Cont
+import           Control.Carrier.Writer.Strict
+import           System.FileLock
+
+import           Util.Function
+
+-- General
+
+rotate :: forall a . (Enum a, Bounded a) => a -> Int -> a
+rotate base step = toEnum $ (fromEnum base + step) `mod` size + (fromEnum $ minBound @a)
+    where size = fromEnum (maxBound @a) - fromEnum (minBound @a) + 1
+{-# INLINE rotate #-}
+
+
+-- Interface
+
+export :: IO ()
+export = writeFile "/sys/class/pwm/pwmchip0/export" "0"
+
+unexport :: IO ()
+unexport = writeFile "/sys/class/pwm/pwmchip0/unexport" "0"
+
+
+-- Constants
+
+semitoneK :: Double
+semitoneK = 2 ** (1 / 12)
+{-# INLINE semitoneK #-}
+
+
+-- Data Types
+
+data Note = Note Semitone Word8
+    deriving (Eq, Show)
+
+data Semitone =
+      C
+    | Db
+    | D
+    | Eb
+    | E
+    | F
+    | Gb
+    | G
+    | Ab
+    | A
+    | Bb
+    | B
+    deriving (Eq, Ord, Show, Enum, Bounded)
+
+newtype Interval = Interval Int deriving newtype (Num)
+
+data TimeSlice =
+      Sixteenth
+    | Eighth
+    | Quarter
+    | Half
+    | Whole
+    | Triplet TimeSlice
+    | Dot TimeSlice
+    | Tie TimeSlice TimeSlice
+    deriving (Eq, Show)
+
+
+-- Theory Manipulation
+
+interval :: Interval -> Note -> Note
+interval (Interval n) (Note step octave) =
+    let (o', s') = n `quotRem` 12
+        newStep  = step `rotate` s'
+        offset   = if
+            | newStep > step && s' < 0 -> subtract 1
+            | newStep < step && s' > 0 -> (+ 1)
+            | otherwise                -> id
+    in  Note newStep (offset $ octave + fromIntegral o')
+{-# INLINE interval #-}
+
+minorThird :: Interval
+minorThird = Interval 3
+
+majorThird :: Interval
+majorThird = Interval 3
+
+fourth :: Interval
+fourth = Interval 5
+
+fifth :: Interval
+fifth = Interval 7
+
+circleOfFourths :: Note -> [Note]
+circleOfFourths = iterate (interval fourth)
+
+circleOfFifths :: Note -> [Note]
+circleOfFifths = iterate (interval fifth)
+
+-- Theory To Interface Target
+
+noteFreq :: Note -> Double
+noteFreq (Note semi oct) = semitoneK ** (fromIntegral $ fromEnum semi) * c0 * (2 ** fromIntegral oct)
+    where
+        a4 = 440
+        c0 = a4 / (semitoneK ** 9) / (2 ** 4)
+
+-- tempo is in quarters per minute
+timeSliceToMicro :: Word16 -> TimeSlice -> Int
+timeSliceToMicro tempo timeSlice = case timeSlice of
+    Sixteenth          -> uspq `div` 4
+    Eighth             -> uspq `div` 2
+    Quarter            -> uspq
+    Half               -> uspq * 2
+    Whole              -> uspq * 4
+    Triplet timeSlice' -> timeSliceToMicro tempo timeSlice' * 2 `div` 3
+    Dot     timeSlice' -> timeSliceToMicro tempo timeSlice' * 3 `div` 2
+    Tie ts1 ts2        -> timeSliceToMicro tempo ts1 + timeSliceToMicro tempo ts2
+    where uspq = floor @Double $ 60 / fromIntegral tempo * 1_000_000
+
+
+-- Player
+
+periodFile :: FilePath
+periodFile = "/sys/class/pwm/pwmchip0/pwm0/period"
+
+dutyFile :: FilePath
+dutyFile = "/sys/class/pwm/pwmchip0/pwm0/duty_cycle"
+
+switchFile :: FilePath
+switchFile = "/sys/class/pwm/pwmchip0/pwm0/enable"
+
+play :: Note -> IO ()
+play note' = do
+    prd' <- readFile periodFile
+    case prd' of
+        "0\n" -> writeFile periodFile "1000"
+        _     -> pure ()
+    let prd = round @_ @Int $ 1 / noteFreq note' * 1_000_000_000 -- pwm needs it in nanos
+    writeFile dutyFile   "0"
+    writeFile periodFile (show prd)
+    writeFile dutyFile   (show $ prd `div` 2)
+    writeFile switchFile "1"
+
+stop :: IO ()
+stop = writeFile switchFile "0"
+
+playForDuration :: Note -> Int -> IO ()
+playForDuration note' duration = handle @SomeException (\e -> stop *> throwIO e) $ do
+    play note'
+    threadDelay (floor @Double $ fromIntegral duration * 0.95)
+    stop
+    threadDelay (ceiling @Double $ fromIntegral duration * 0.05)
+
+time :: IO () -> IO (UTCTime, UTCTime)
+time action = do
+    t0 <- getCurrentTime
+    action
+    t1 <- getCurrentTime
+    pure (t0, t1)
+
+playSong :: Word16 -> Song -> IO ()
+playSong = flip runCont id .* playSong'
+{-# INLINE playSong #-}
+
+playSongTimed :: Word16 -> Song -> IO (UTCTime, UTCTime)
+playSongTimed tempo song = runCont (playSong' tempo song) time
+{-# INLINE playSongTimed #-}
+
+playSong' :: Word16 -> Song -> Cont (IO b) (IO ())
+playSong' tempo song = cont $ \f -> bracket acquire release $ \_ -> f $ do
+    for_ song $ \(n, ts) -> do
+        let duration = timeSliceToMicro tempo ts
+        case n of
+            Nothing -> threadDelay duration
+            Just x  -> playForDuration x duration
+    where
+        soundLock = "/root/agent/sound.lock"
+        acquire   = do
+            l <- lockFile soundLock Exclusive
+            export
+            pure l
+        release l = do
+            void $ try @SomeException stop
+            void $ try @SomeException unexport
+            unlockFile l
+
+
+-- Songs
+
+type Song = [(Maybe Note, TimeSlice)]
+
+marioDeath :: Song
+marioDeath =
+    [ (Just $ Note B 4, Quarter)
+    , (Just $ Note F 5, Quarter)
+    , (Nothing        , Quarter)
+    , (Just $ Note F 5, Quarter)
+    , (Just $ Note F 5, Triplet Half)
+    , (Just $ Note E 5, Triplet Half)
+    , (Just $ Note D 5, Triplet Half)
+    , (Just $ Note C 5, Quarter)
+    , (Just $ Note E 4, Quarter)
+    , (Nothing        , Quarter)
+    , (Just $ Note E 4, Quarter)
+    , (Just $ Note C 4, Half)
+    ]
+
+marioPowerUp :: Song
+marioPowerUp =
+    [ (Just $ Note G 4 , Triplet Eighth)
+    , (Just $ Note B 4 , Triplet Eighth)
+    , (Just $ Note D 5 , Triplet Eighth)
+    , (Just $ Note G 5 , Triplet Eighth)
+    , (Just $ Note B 5 , Triplet Eighth)
+    , (Just $ Note Ab 4, Triplet Eighth)
+    , (Just $ Note C 5 , Triplet Eighth)
+    , (Just $ Note Eb 5, Triplet Eighth)
+    , (Just $ Note Ab 5, Triplet Eighth)
+    , (Just $ Note C 5 , Triplet Eighth)
+    , (Just $ Note Bb 4, Triplet Eighth)
+    , (Just $ Note D 5 , Triplet Eighth)
+    , (Just $ Note F 5 , Triplet Eighth)
+    , (Just $ Note Bb 5, Triplet Eighth)
+    , (Just $ Note D 6 , Triplet Eighth)
+    ]
+
+marioCoin :: Song
+marioCoin = [(Just $ Note B 5, Eighth), (Just $ Note E 6, Tie (Dot Quarter) Half)]
+
+updateInProgress :: Song
+updateInProgress = take 6 $ (, Triplet Eighth) . Just <$> circleOfFifths (Note A 3)
+
+beethoven :: Song
+beethoven = run . execWriter $ do
+    tell $ replicate 3 (Just $ Note E 5, Eighth)
+    tell $ [(Just $ Note C 5, Half)]
+    tell $ [(Nothing @Note, Eighth)]
+    tell $ replicate 3 (Just $ Note D 5, Eighth)
+    tell $ [(Just $ Note B 5, Half)]
+
+restoreActionInProgress :: Song
+restoreActionInProgress = take 5 $ (, Triplet Eighth) . Just <$> circleOfFourths (Note C 4)
+
+backupActionInProgress :: [(Maybe Note, TimeSlice)]
+backupActionInProgress = reverse restoreActionInProgress