Start9/start-os
2
0
Fork 0
mirror of https://github.com/Start9Labs/start-os.git synced 2026-03-26 02:11:53 +00:00
Code Issues Packages Projects Releases Wiki Activity

0.2.5 initial commit

Browse Source 
Makefile incomplete
This commit is contained in:
Aiden McClelland
2020-11-23 13:44:28 -07:00
commit 95d3845906
503 changed files with 53448 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

42
agent/.gitignore vendored Normal file
View File

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

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

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

12
agent/Changelog.md Normal file
View File

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

7
agent/README.md Normal file
View File

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

3
agent/TODO.md Normal file
View File

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

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

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

60
agent/brittany.yaml Normal file
View File

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

7
agent/build.sh Executable file
View File

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

14
agent/config/agent.service Normal file
View File

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

6
agent/config/journald.conf Normal file
View File

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

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

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

54
agent/config/routes Normal file
View File

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

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

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

5
agent/config/torrc Normal file
View File

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

13
agent/hie.yaml Normal file
View File

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

1
agent/migrations/0.1.0::0.1.0 Normal file
View File

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

1
agent/migrations/0.1.0::0.1.1 Normal file
View File

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

1
agent/migrations/0.1.1::0.1.2 Normal file
View File

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

1
agent/migrations/0.1.2::0.1.3 Normal file
View File

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

1
agent/migrations/0.1.3::0.1.4 Normal file
View File

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

1
agent/migrations/0.1.4::0.1.5 Normal file
View File

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

2
agent/migrations/0.1.5::0.2.0 Normal file
View File

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

1
agent/migrations/0.2.0::0.2.1 Normal file
View File

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

1
agent/migrations/0.2.1::0.2.2 Normal file
View File

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

1
agent/migrations/0.2.2::0.2.3 Normal file
View File

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

1
agent/migrations/0.2.3::0.2.4 Normal file
View File

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

1
agent/migrations/0.2.4::0.2.5 Normal file
View File

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

181
agent/package.yaml Normal file
View File

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

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

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

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

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

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

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

48
agent/src/Daemon/AppNotifications.hs Normal file
View File

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

20
agent/src/Daemon/RefreshProcDev.hs Normal file
View File

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

56
agent/src/Daemon/ZeroConf.hs Normal file
View File

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

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

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

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

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

9
agent/src/Handler/Authenticate.hs Normal file
View File

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

218
agent/src/Handler/Backups.hs Normal file
View File

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

85
agent/src/Handler/Hosts.hs Normal file
View File

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

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

@@ -0,0 +1,106 @@
{-# LANGUAGE PartialTypeSignatures #-}
module Handler.Icons where
import Startlude hiding ( Reader
, runReader
)
import Control.Carrier.Error.Either
import Control.Carrier.Lift
import Data.Conduit
import Data.Conduit.Binary as CB
import qualified Data.Text as T
import Network.HTTP.Simple
import System.FilePath.Posix
import Yesod.Core
import 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

75
agent/src/Handler/Login.hs Normal file
View File

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

32
agent/src/Handler/Notifications.hs Normal file
View File

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

36
agent/src/Handler/PasswordUpdate.hs Normal file
View File

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

28
agent/src/Handler/PowerOff.hs Normal file
View File

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

140
agent/src/Handler/Register.hs Normal file
View File

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

158
agent/src/Handler/Register/Nginx.hs Normal file
View File

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

44
agent/src/Handler/Register/Tor.hs Normal file
View File

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

51
agent/src/Handler/SelfUpdate.hs Normal file
View File

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

39
agent/src/Handler/SshKeys.hs Normal file
View File

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

71
agent/src/Handler/Status.hs Normal file
View File

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

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

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

178
agent/src/Handler/Types/Apps.hs Normal file
View File

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

28
agent/src/Handler/Types/HmacSig.hs Normal file
View File

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

44
agent/src/Handler/Types/Hosts.hs Normal file
View File

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

26
agent/src/Handler/Types/Metrics.hs Normal file
View File

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

32
agent/src/Handler/Types/Parse.hs Normal file
View File

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

65
agent/src/Handler/Types/Register.hs Normal file
View File

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

77
agent/src/Handler/Types/V0/Base.hs Normal file
View File

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

45
agent/src/Handler/Types/V0/Specs.hs Normal file
View File

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

25
agent/src/Handler/Types/V0/Ssh.hs Normal file
View File

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

32
agent/src/Handler/Types/V0/Wifi.hs Normal file
View File

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

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

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

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

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

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

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

469
agent/src/Lib/Algebra/Domain/AppMgr.hs Normal file
View File

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

43
agent/src/Lib/Algebra/Domain/AppMgr/TH.hs Normal file
View File

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

29
agent/src/Lib/Algebra/Domain/AppMgr/Types.hs Normal file
View File

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

84
agent/src/Lib/Algebra/State/RegistryUrl.hs Normal file
View File

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

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

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

46
agent/src/Lib/Background.hs Normal file
View File

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

297
agent/src/Lib/ClientManifest.hs Normal file
View File

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

53
agent/src/Lib/Crypto.hs Normal file
View File

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

53
agent/src/Lib/Database.hs Normal file
View File

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

283
agent/src/Lib/Error.hs Normal file
View File

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

100
agent/src/Lib/External/AppManifest.hs vendored Normal file
View File

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

291
agent/src/Lib/External/AppMgr.hs vendored Normal file
View File

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

40
agent/src/Lib/External/Metrics/Df.hs vendored Normal file
View File

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

58
agent/src/Lib/External/Metrics/Iotop.hs vendored Normal file
View File

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

118
agent/src/Lib/External/Metrics/ProcDev.hs vendored Normal file
View File

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

22
agent/src/Lib/External/Metrics/Temperature.hs vendored Normal file
View File

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

114
agent/src/Lib/External/Metrics/Top.hs vendored Normal file
View File

@@ -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][^(,|.)]+)"

89
agent/src/Lib/External/Metrics/Types.hs vendored Normal file
View File

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

196
agent/src/Lib/External/Registry.hs vendored Normal file
View File

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

32
agent/src/Lib/External/Specs/CPU.hs vendored Normal file
View File

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

13
agent/src/Lib/External/Specs/Common.hs vendored Normal file
View File

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

12
agent/src/Lib/External/Specs/Memory.hs vendored Normal file
View File

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

17
agent/src/Lib/External/Util.hs vendored Normal file
View File

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

102
agent/src/Lib/External/WpaSupplicant.hs vendored Normal file
View File

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

94
agent/src/Lib/IconCache.hs Normal file
View File

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

158
agent/src/Lib/Metrics.hs Normal file
View File

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

96
agent/src/Lib/Migration.hs Normal file
View File

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

109
agent/src/Lib/Notifications.hs Normal file
View File

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

77
agent/src/Lib/Password.hs Normal file
View File

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

12
agent/src/Lib/ProductKey.hs Normal file
View File

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

226
agent/src/Lib/SelfUpdate.hs Normal file
View File

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

248
agent/src/Lib/Sound.hs Normal file
View File

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

81
agent/src/Lib/Ssh.hs Normal file
View File

@@ -0,0 +1,81 @@
{-# LANGUAGE TupleSections #-}
module Lib.Ssh where
import Startlude
import Control.Lens
import Crypto.Hash
import Data.Aeson
import Data.ByteArray hiding ( null
, view
)
import Data.ByteArray.Encoding
import Data.ByteString.Builder
import Data.ByteString.Lazy ( toStrict )
import Data.List ( partition )
import qualified Data.Text as T
import System.Directory
import Lib.SystemPaths
import Settings
data SshAlg = RSA | ECDSA | Ed25519 | DSA deriving (Eq, Show)
instance ToJSON SshAlg where
toJSON = String . \case
RSA -> "ssh-rsa"
ECDSA -> "ecdsa-sha2-nistp256"
Ed25519 -> "ssh-ed25519"
DSA -> "ssh-dss"
getSshKeys :: (MonadReader AppSettings m, MonadIO m) => m [Text]
getSshKeys = do
base <- asks appFilesystemBase
liftIO $ doesFileExist (toS $ sshKeysFilePath `relativeTo` base) >>= \case
False -> pure []
True -> lines . T.strip <$> readFile (toS $ sshKeysFilePath `relativeTo` base)
fingerprint :: Text -> Either String (SshAlg, Text, Text)
fingerprint sshKey = do
(alg, b64, host) <- case T.split isSpace sshKey of
[alg, bin, host] -> (, encodeUtf8 bin, host) <$> parseAlg alg
[alg, bin] -> (, encodeUtf8 bin, "") <$> parseAlg alg
_ -> Left $ "Invalid SSH Key: " <> toS sshKey
bin <- convertFromBase @_ @ByteString Base64 b64
let dig = unpack . convert @_ @ByteString $ hashWith MD5 bin
let hex = fmap (byteString . convertToBase @ByteString Base16 . singleton) dig
let colons = intersperse (charUtf8 ':') hex
pure . (alg, , host) . decodeUtf8 . toStrict . toLazyByteString $ fold colons
where
parseAlg :: Text -> Either String SshAlg
parseAlg alg = case alg of
"ssh-rsa" -> Right RSA
"ecdsa-sha2-nistp256" -> Right ECDSA
"ssh-ed25519" -> Right Ed25519
"ssh-dss" -> Right DSA
_ -> Left $ "Invalid SSH Alg: " <> toS alg
createSshKey :: (MonadReader AppSettings m, MonadIO m) => Text -> m ()
createSshKey key = do
base <- asks appFilesystemBase
let writeFirstKeyToFile k = writeFile (toS $ sshKeysFilePath `relativeTo` base) (k <> "\n")
liftIO $ doesFileExist (toS $ sshKeysFilePath `relativeTo` base) >>= \case
False -> writeFirstKeyToFile sanitizedKey
True -> addKeyToFile (toS $ sshKeysFilePath `relativeTo` base) sanitizedKey
where sanitizedKey = T.strip key
addKeyToFile :: FilePath -> Text -> IO ()
addKeyToFile path k = do
oldKeys <- filter (not . T.null) . lines <$> readFile path
writeFile path $ unlines (k : oldKeys)
-- true if key deleted, false if key did not exist
deleteSshKey :: (MonadReader AppSettings m, MonadIO m) => Text -> m Bool
deleteSshKey fp = do
base <- asks appFilesystemBase
let rewriteFile others = liftIO $ writeFile (toS $ sshKeysFilePath `relativeTo` base) $ unlines others
getSshKeys >>= \case
[] -> pure False
keys -> do
let (existed, others) = partition ((Right fp ==) . fmap (view _2) . fingerprint) keys
if null existed then pure False else rewriteFile others >> pure True

355
agent/src/Lib/Ssl.hs Normal file
View File

@@ -0,0 +1,355 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE QuasiQuotes #-}
module Lib.Ssl where
import Startlude
import Control.Lens
import Data.String.Interpolate.IsString
import System.Process
root_CA_CERT_NAME :: Text
root_CA_CERT_NAME = "Embassy Local Root CA"
root_CA_OPENSSL_CONF :: FilePath -> ByteString
root_CA_OPENSSL_CONF path = [i|
# OpenSSL root CA configuration file.
# Copy to `/root/ca/openssl.cnf`.
[ ca ]
# `man ca`
default_ca = CA_default
[ CA_default ]
# Directory and file locations.
dir = #{path}
certs = $dir/certs
crl_dir = $dir/crl
new_certs_dir = $dir/newcerts
database = $dir/index.txt
serial = $dir/serial
RANDFILE = $dir/private/.rand
# The root key and root certificate.
private_key = $dir/private/ca.key.pem
certificate = $dir/certs/ca.cert.pem
# For certificate revocation lists.
crlnumber = $dir/crlnumber
crl = $dir/crl/ca.crl.pem
crl_extensions = crl_ext
default_crl_days = 30
# SHA-1 is deprecated, so use SHA-2 instead.
default_md = sha256
name_opt = ca_default
cert_opt = ca_default
default_days = 375
preserve = no
policy = policy_loose
[ policy_loose ]
# Allow the intermediate CA to sign a more diverse range of certificates.
# See the POLICY FORMAT section of the `ca` man page.
countryName = optional
stateOrProvinceName = optional
localityName = optional
organizationName = optional
organizationalUnitName = optional
commonName = supplied
emailAddress = optional
[ req ]
# Options for the `req` tool (`man req`).
default_bits = 4096
distinguished_name = req_distinguished_name
string_mask = utf8only
prompt = no
# SHA-1 is deprecated, so use SHA-2 instead.
default_md = sha256
# Extension to add when the -x509 option is used.
x509_extensions = v3_ca
[ req_distinguished_name ]
# See <https://en.wikipedia.org/wiki/Certificate_signing_request>.
CN = #{root_CA_CERT_NAME}
O = Start9 Labs
OU = Embassy
[ v3_ca ]
# Extensions for a typical CA (`man x509v3_config`).
subjectKeyIdentifier = hash
authorityKeyIdentifier = keyid:always,issuer
basicConstraints = critical, CA:true
keyUsage = critical, digitalSignature, cRLSign, keyCertSign
[ v3_intermediate_ca ]
# Extensions for a typical intermediate CA (`man x509v3_config`).
subjectKeyIdentifier = hash
authorityKeyIdentifier = keyid:always,issuer
basicConstraints = critical, CA:true, pathlen:0
keyUsage = critical, digitalSignature, cRLSign, keyCertSign
[ usr_cert ]
# Extensions for client certificates (`man x509v3_config`).
basicConstraints = CA:FALSE
nsCertType = client, email
nsComment = "OpenSSL Generated Client Certificate"
subjectKeyIdentifier = hash
authorityKeyIdentifier = keyid,issuer
keyUsage = critical, nonRepudiation, digitalSignature, keyEncipherment
extendedKeyUsage = clientAuth, emailProtection
[ server_cert ]
# Extensions for server certificates (`man x509v3_config`).
basicConstraints = CA:FALSE
nsCertType = server
nsComment = "OpenSSL Generated Server Certificate"
subjectKeyIdentifier = hash
authorityKeyIdentifier = keyid,issuer:always
keyUsage = critical, digitalSignature, keyEncipherment
extendedKeyUsage = serverAuth
[ crl_ext ]
# Extension for CRLs (`man x509v3_config`).
authorityKeyIdentifier=keyid:always
[ ocsp ]
# Extension for OCSP signing certificates (`man ocsp`).
basicConstraints = CA:FALSE
subjectKeyIdentifier = hash
authorityKeyIdentifier = keyid,issuer
keyUsage = critical, digitalSignature
extendedKeyUsage = critical, OCSPSigning
|]
intermediate_CA_OPENSSL_CONF :: Text -> ByteString
intermediate_CA_OPENSSL_CONF path = [i|
# OpenSSL intermediate CA configuration file.
# Copy to `/root/ca/intermediate/openssl.cnf`.
[ ca ]
# `man ca`
default_ca = CA_default
[ CA_default ]
# Directory and file locations.
dir = #{path}
certs = $dir/certs
crl_dir = $dir/crl
new_certs_dir = $dir/newcerts
database = $dir/index.txt
serial = $dir/serial
RANDFILE = $dir/private/.rand
# The root key and root certificate.
private_key = $dir/private/intermediate.key.pem
certificate = $dir/certs/intermediate.cert.pem
# For certificate revocation lists.
crlnumber = $dir/crlnumber
crl = $dir/crl/intermediate.crl.pem
crl_extensions = crl_ext
default_crl_days = 30
# SHA-1 is deprecated, so use SHA-2 instead.
default_md = sha256
name_opt = ca_default
cert_opt = ca_default
default_days = 375
preserve = no
copy_extensions = copy
policy = policy_loose
[ policy_loose ]
# Allow the intermediate CA to sign a more diverse range of certificates.
# See the POLICY FORMAT section of the `ca` man page.
countryName = optional
stateOrProvinceName = optional
localityName = optional
organizationName = optional
organizationalUnitName = optional
commonName = supplied
emailAddress = optional
[ req ]
# Options for the `req` tool (`man req`).
default_bits = 4096
distinguished_name = req_distinguished_name
string_mask = utf8only
prompt = no
# SHA-1 is deprecated, so use SHA-2 instead.
default_md = sha256
# Extension to add when the -x509 option is used.
x509_extensions = v3_ca
[ req_distinguished_name ]
CN = Embassy Local Intermediate CA
O = Start9 Labs
OU = Embassy
[ v3_ca ]
# Extensions for a typical CA (`man x509v3_config`).
subjectKeyIdentifier = hash
authorityKeyIdentifier = keyid:always,issuer
basicConstraints = critical, CA:true
keyUsage = critical, digitalSignature, cRLSign, keyCertSign
[ v3_intermediate_ca ]
# Extensions for a typical intermediate CA (`man x509v3_config`).
subjectKeyIdentifier = hash
authorityKeyIdentifier = keyid:always,issuer
basicConstraints = critical, CA:true, pathlen:0
keyUsage = critical, digitalSignature, cRLSign, keyCertSign
[ usr_cert ]
# Extensions for client certificates (`man x509v3_config`).
basicConstraints = CA:FALSE
nsCertType = client, email
nsComment = "OpenSSL Generated Client Certificate"
subjectKeyIdentifier = hash
authorityKeyIdentifier = keyid,issuer
keyUsage = critical, nonRepudiation, digitalSignature, keyEncipherment
extendedKeyUsage = clientAuth, emailProtection
[ server_cert ]
# Extensions for server certificates (`man x509v3_config`).
basicConstraints = CA:FALSE
nsCertType = server
nsComment = "OpenSSL Generated Server Certificate"
subjectKeyIdentifier = hash
authorityKeyIdentifier = keyid,issuer:always
keyUsage = critical, digitalSignature, keyEncipherment
extendedKeyUsage = serverAuth
[ crl_ext ]
# Extension for CRLs (`man x509v3_config`).
authorityKeyIdentifier=keyid:always
[ ocsp ]
# Extension for OCSP signing certificates (`man ocsp`).
basicConstraints = CA:FALSE
subjectKeyIdentifier = hash
authorityKeyIdentifier = keyid,issuer
keyUsage = critical, digitalSignature
extendedKeyUsage = critical, OCSPSigning
|]
domain_CSR_CONF :: Text -> ByteString
domain_CSR_CONF name = [i|
[req]
default_bits = 4096
default_md = sha256
distinguished_name = req_distinguished_name
prompt = no
[req_distinguished_name]
CN = #{name}
O = Start9 Labs
OU = Embassy
|]
writeRootCaCert :: MonadIO m => FilePath -> FilePath -> FilePath -> m (ExitCode, String, String)
writeRootCaCert confPath keyFilePath certFileDestinationPath = liftIO $ readProcessWithExitCode
"openssl"
[ "req"
, -- use x509
"-new"
, -- new request
"-x509"
, -- self signed x509
"-nodes"
, -- no passphrase
"-days"
, -- expires in...
"3650"
, -- valid for 10 years. Max is 20 years
"-key"
, -- source private key
toS keyFilePath
, "-out"
-- target cert path
, toS certFileDestinationPath
, "-config"
-- configured by...
, toS confPath
]
""
data DeriveCertificate = DeriveCertificate
{ applicantConfPath :: FilePath
, applicantKeyPath :: FilePath
, applicantCertPath :: FilePath
, signingConfPath :: FilePath
, signingKeyPath :: FilePath
, signingCertPath :: FilePath
, duration :: Integer
}
writeIntermediateCert :: MonadIO m => DeriveCertificate -> m (ExitCode, String, String)
writeIntermediateCert DeriveCertificate {..} = liftIO $ interpret $ do
-- openssl genrsa -out dump/int.key 4096
segment $ openssl [i|genrsa -out #{applicantKeyPath} 4096|]
-- openssl req -new -config dump/int-csr.conf -key dump/int.key -nodes -out dump/int.csr
segment $ openssl [i|req -new
-config #{applicantConfPath}
-key #{applicantKeyPath}
-nodes
-out #{applicantCertPath <> ".csr"}|]
-- openssl x509 -CA dump/ca.crt -CAkey dump/ca.key -CAcreateserial -days 3650 -req -in dump/int.csr -out dump/int.crt
segment $ openssl [i|ca -batch
-config #{signingConfPath}
-rand_serial
-keyfile #{signingKeyPath}
-cert #{signingCertPath}
-extensions v3_intermediate_ca
-days #{duration}
-notext
-in #{applicantCertPath <> ".csr"}
-out #{applicantCertPath}|]
liftIO $ readFile signingCertPath >>= appendFile applicantCertPath
writeLeafCert :: MonadIO m => DeriveCertificate -> Text -> Text -> m (ExitCode, String, String)
writeLeafCert DeriveCertificate {..} hostname torAddress = liftIO $ interpret $ do
segment $ openssl [i|genrsa -out #{applicantKeyPath} 4096|]
segment $ openssl [i|req -config #{applicantConfPath}
-key #{applicantKeyPath}
-new
-addext subjectAltName=DNS:#{hostname},DNS:*.#{hostname},DNS:#{torAddress},DNS:*.#{torAddress}
-out #{applicantCertPath <> ".csr"}|]
segment $ openssl [i|ca -batch
-config #{signingConfPath}
-rand_serial
-keyfile #{signingKeyPath}
-cert #{signingCertPath}
-extensions server_cert
-days #{duration}
-notext
-in #{applicantCertPath <> ".csr"}
-out #{applicantCertPath}
|]
liftIO $ readFile signingCertPath >>= appendFile applicantCertPath
openssl :: Text -> IO (ExitCode, String, String)
openssl = ($ "") . readProcessWithExitCode "openssl" . fmap toS . words
{-# INLINE openssl #-}
interpret :: ExceptT ExitCode (StateT (String, String) IO) () -> IO (ExitCode, String, String)
interpret = fmap (over _1 (either id (const ExitSuccess)) . regroup) . flip runStateT ("", "") . runExceptT
{-# INLINE interpret #-}
regroup :: (a, (b, c)) -> (a, b, c)
regroup (a, (b, c)) = (a, b, c)
{-# INLINE regroup #-}
segment :: IO (ExitCode, String, String) -> ExceptT ExitCode (StateT (String, String) IO) ()
segment action = liftIO action >>= \case
(ExitSuccess, o, e) -> modify (bimap (<> o) (<> e))
(ec , o, e) -> modify (bimap (<> o) (<> e)) *> throwE ec
{-# INLINE segment #-}

437
agent/src/Lib/Synchronizers.hs Normal file
View File

@@ -0,0 +1,437 @@
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Lib.Synchronizers where
import Startlude hiding ( check )
import qualified Startlude.ByteStream as ByteStream
import qualified Startlude.ByteStream.Char8 as ByteStream
import qualified Control.Effect.Reader.Labelled
as Fused
import Control.Carrier.Lift ( runM )
import Control.Monad.Trans.Reader ( mapReaderT )
import Control.Monad.Trans.Resource
import Data.Attoparsec.Text
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as B8
import qualified Data.Conduit as Conduit
import qualified Data.Conduit.Combinators as Conduit
import qualified Data.Conduit.Tar as Conduit
import Data.Conduit.Shell hiding ( arch
, patch
, stream
, hostname
)
import Data.FileEmbed
import qualified Data.HashMap.Strict as HM
import Data.IORef
import Data.String.Interpolate.IsString
import qualified Data.Yaml as Yaml
import Exinst
import System.FilePath ( splitPath
, joinPath
, (</>)
)
import System.FilePath.Posix ( takeDirectory )
import System.Directory
import System.IO.Error
import System.Posix.Files
import qualified Streaming.Prelude as Stream
import qualified Streaming.Conduit as Conduit
import qualified Streaming.Zip as Stream
import Constants
import Foundation
import Lib.ClientManifest
import Lib.Error
import qualified Lib.External.AppMgr as AppMgr
import Lib.External.Registry
import Lib.Sound
import Lib.Ssl
import Lib.Tor
import Lib.Types.Core
import Lib.Types.NetAddress
import Lib.Types.Emver
import Lib.SystemCtl
import Lib.SystemPaths hiding ( (</>) )
import Settings
import Util.File
import qualified Lib.Algebra.Domain.AppMgr as AppMgr2
import Daemon.ZeroConf ( getStart9AgentHostname )
data Synchronizer = Synchronizer
{ synchronizerVersion :: Version
, synchronizerOperations :: [SyncOp]
}
data SyncOp = SyncOp
{ syncOpName :: Text
, syncOpShouldRun :: ReaderT AgentCtx IO Bool -- emit true if op is to be run
, syncOpRun :: ReaderT AgentCtx IO ()
, syncOpRequiresReboot :: Bool
}
data Arch = ArmV7 | ArmV8 deriving (Show)
data KernelVersion = KernelVersion
{ kernelVersionNumber :: Version
, kernelVersionArch :: Arch
}
deriving Show
parseKernelVersion :: Parser KernelVersion
parseKernelVersion = do
major' <- decimal
minor' <- char '.' *> decimal
patch' <- char '.' *> decimal
arch <- string "-v7l+" *> pure ArmV7 <|> string "-v8+" *> pure ArmV8
pure $ KernelVersion (Version (major', minor', patch', 0)) arch
synchronizer :: Synchronizer
synchronizer = sync_0_2_5
{-# INLINE synchronizer #-}
sync_0_2_5 :: Synchronizer
sync_0_2_5 = Synchronizer
"0.2.5"
[ syncCreateAgentTmp
, syncCreateSshDir
, syncRemoveAvahiSystemdDependency
, syncInstallAppMgr
, syncFullUpgrade
, sync32BitKernel
, syncInstallNginx
, syncWriteNginxConf
, syncInstallDuplicity
, syncInstallExfatFuse
, syncInstallExfatUtils
, syncInstallAmbassadorUI
, syncOpenHttpPorts
, syncUpgradeLifeline
, syncPrepSslRootCaDir
, syncPrepSslIntermediateCaDir
, syncPersistLogs
]
syncCreateAgentTmp :: SyncOp
syncCreateAgentTmp = SyncOp "Create Agent Tmp Dir" check migrate False
where
check = do
s <- asks appSettings
tmp <- injectFilesystemBaseFromContext s $ getAbsoluteLocationFor agentTmpDirectory
liftIO $ not <$> doesPathExist (toS tmp)
migrate = do
s <- asks appSettings
tmp <- injectFilesystemBaseFromContext s $ getAbsoluteLocationFor agentTmpDirectory
liftIO $ createDirectoryIfMissing True (toS tmp)
syncCreateSshDir :: SyncOp
syncCreateSshDir = SyncOp "Create SSH directory" check migrate False
where
check = do
base <- asks $ appFilesystemBase . appSettings
liftIO $ not <$> doesPathExist (toS $ sshKeysDirectory `relativeTo` base)
migrate = do
base <- asks $ appFilesystemBase . appSettings
liftIO $ createDirectoryIfMissing False (toS $ sshKeysDirectory `relativeTo` base)
syncRemoveAvahiSystemdDependency :: SyncOp
syncRemoveAvahiSystemdDependency = SyncOp "Remove Avahi Systemd Dependency" check migrate False
where
wanted = decodeUtf8 $ $(embedFile "config/agent.service")
check = do
base <- asks $ appFilesystemBase . appSettings
content <- liftIO $ readFile (toS $ agentServicePath `relativeTo` base)
pure (content /= wanted)
migrate = do
base <- asks $ appFilesystemBase . appSettings
liftIO $ writeFile (toS $ agentServicePath `relativeTo` base) wanted
void $ liftIO systemCtlDaemonReload
-- the main purpose of this is the kernel upgrade but it does upgrade all packages on the system, maybe we should
-- reconsider the heavy handed approach here
syncFullUpgrade :: SyncOp
syncFullUpgrade = SyncOp "Full Upgrade" check migrate True
where
check = liftIO . run $ do
v <- decodeUtf8 <<$>> (uname ("-r" :: Text) $| conduit await)
case parse parseKernelVersion <$> v of
Just (Done _ (KernelVersion (Version av) _)) -> if av < (4, 19, 118, 0) then pure True else pure False
_ -> pure False
migrate = liftIO . run $ do
shell "apt update"
shell "apt full-upgrade -y"
sync32BitKernel :: SyncOp
sync32BitKernel = SyncOp "32 Bit Kernel Switch" check migrate True
where
getBootCfgPath = getAbsoluteLocationFor bootConfigPath
check = do
settings <- asks appSettings
cfg <- injectFilesystemBaseFromContext settings getBootCfgPath
liftIO . run $ fmap isNothing $ (shell [i|grep "arm_64bit=0" #{cfg} || true|] $| conduit await)
migrate = do
base <- asks $ appFilesystemBase . appSettings
let tmpFile = bootConfigTempPath `relativeTo` base
let bootCfg = bootConfigPath `relativeTo` base
contents <- liftIO $ readFile (toS bootCfg)
let contents' = unlines . (<> ["arm_64bit=0"]) . filter (/= "arm_64bit=1") . lines $ contents
liftIO $ writeFile (toS tmpFile) contents'
liftIO $ renameFile (toS tmpFile) (toS bootCfg)
syncInstallNginx :: SyncOp
syncInstallNginx = SyncOp "Install Nginx" check migrate False
where
check = liftIO . run $ fmap isNothing (shell [i|which nginx || true|] $| conduit await)
migrate = liftIO . run $ do
apt "update"
apt "install" "nginx" "-y"
syncInstallDuplicity :: SyncOp
syncInstallDuplicity = SyncOp "Install duplicity" check migrate False
where
check = liftIO . run $ fmap isNothing (shell [i|which duplicity || true|] $| conduit await)
migrate = liftIO . run $ do
apt "update"
apt "install" "-y" "duplicity"
syncInstallExfatFuse :: SyncOp
syncInstallExfatFuse = SyncOp "Install exfat-fuse" check migrate False
where
check =
liftIO
$ (run (shell [i|dpkg -l|] $| shell [i|grep exfat-fuse|] $| conduit await) $> False)
`catch` \(e :: ProcessException) -> case e of
ProcessException _ (ExitFailure 1) -> pure True
_ -> throwIO e
migrate = liftIO . run $ do
apt "update"
apt "install" "-y" "exfat-fuse"
syncInstallExfatUtils :: SyncOp
syncInstallExfatUtils = SyncOp "Install exfat-utils" check migrate False
where
check =
liftIO
$ (run (shell [i|dpkg -l|] $| shell [i|grep exfat-utils|] $| conduit await) $> False)
`catch` \(e :: ProcessException) -> case e of
ProcessException _ (ExitFailure 1) -> pure True
_ -> throwIO e
migrate = liftIO . run $ do
apt "update"
apt "install" "-y" "exfat-utils"
syncWriteConf :: Text -> ByteString -> SystemPath -> SyncOp
syncWriteConf name contents' confLocation = SyncOp [i|Write #{name} Conf|] check migrate False
where
contents = decodeUtf8 contents'
check = do
base <- asks $ appFilesystemBase . appSettings
conf <-
liftIO
$ (Just <$> readFile (toS $ confLocation `relativeTo` base))
`catch` (\(e :: IOException) -> if isDoesNotExistError e then pure Nothing else throwIO e)
case conf of
Nothing -> pure True
Just co -> pure $ if co == contents then False else True
migrate = do
base <- asks $ appFilesystemBase . appSettings
void . liftIO $ createDirectoryIfMissing True (takeDirectory (toS $ confLocation `relativeTo` base))
liftIO $ writeFile (toS $ confLocation `relativeTo` base) contents
syncPrepSslRootCaDir :: SyncOp
syncPrepSslRootCaDir = SyncOp "Create Embassy Root CA Environment" check migrate False
where
check = do
base <- asks $ appFilesystemBase . appSettings
liftIO . fmap not . doesPathExist . toS $ rootCaDirectory `relativeTo` base
migrate = do
base <- asks $ appFilesystemBase . appSettings
liftIO $ do
createDirectoryIfMissing True . toS $ rootCaDirectory `relativeTo` base
for_ ["/certs", "/crl", "/newcerts", "/private"] $ \p -> do
createDirectoryIfMissing True . toS $ p `relativeTo` (rootCaDirectory `relativeTo` base)
setFileMode (toS $ (rootCaDirectory <> "/private") `relativeTo` base) (7 `shiftL` 6)
writeFile (toS $ (rootCaDirectory <> "/index.txt") `relativeTo` base) ""
writeFile (toS $ (rootCaDirectory <> "/serial") `relativeTo` base) "1000"
BS.writeFile (toS $ rootCaOpenSslConfPath `relativeTo` base)
(root_CA_OPENSSL_CONF . toS $ rootCaDirectory `relativeTo` base)
syncPrepSslIntermediateCaDir :: SyncOp
syncPrepSslIntermediateCaDir = SyncOp "Create Embassy Intermediate CA Environment" check migrate False
where
check = do
base <- asks $ appFilesystemBase . appSettings
liftIO . fmap not . doesPathExist . toS $ intermediateCaDirectory `relativeTo` base
migrate = do
base <- asks $ appFilesystemBase . appSettings
liftIO $ do
createDirectoryIfMissing True . toS $ intermediateCaDirectory `relativeTo` base
for_ ["/certs", "/crl", "/newcerts", "/private"] $ \p -> do
createDirectoryIfMissing True . toS $ (intermediateCaDirectory <> p) `relativeTo` base
setFileMode (toS $ (intermediateCaDirectory <> "/private") `relativeTo` base) (7 `shiftL` 6)
writeFile (toS $ (intermediateCaDirectory <> "/index.txt") `relativeTo` base) ""
writeFile (toS $ (intermediateCaDirectory <> "/serial") `relativeTo` base) "1000"
BS.writeFile (toS $ intermediateCaOpenSslConfPath `relativeTo` base)
(intermediate_CA_OPENSSL_CONF . toS $ intermediateCaDirectory `relativeTo` base)
syncWriteNginxConf :: SyncOp
syncWriteNginxConf = syncWriteConf "Nginx" $(embedFile "config/nginx.conf") nginxConfig
syncInstallAmbassadorUI :: SyncOp
syncInstallAmbassadorUI = SyncOp "Install Ambassador UI" check migrate False
where
check = do
base <- asks (appFilesystemBase . appSettings)
liftIO (doesPathExist (toS $ ambassadorUiPath `relativeTo` base)) >>= \case
True -> do
manifest <- liftIO $ readFile (toS $ ambassadorUiManifestPath `relativeTo` base)
case Yaml.decodeEither' (encodeUtf8 manifest) of
Left _ -> pure False
Right (Some1 _ cm) -> case cm of
(V0 cmv0) -> pure $ clientManifestV0AppVersion cmv0 /= agentVersion
False -> pure True
migrate = mapReaderT runResourceT $ do
base <- asks (appFilesystemBase . appSettings)
liftIO $ removePathForcibly (toS $ ambassadorUiPath `relativeTo` base)
void
. runInContext
-- untar and save to path
$ streamUntar (ambassadorUiPath `relativeTo` base)
-- unzip
. Stream.gunzip
-- download
$ getAmbassadorUiForSpec (exactly agentVersion)
runM $ injectFilesystemBase base $ do
-- if the ssl config has already been setup, we want to override the config with new UI details
-- otherwise we leave it alone
whenM (liftIO $ doesFileExist (toS $ nginxSitesAvailable nginxSslConf `relativeTo` base)) $ do
sid <- getStart9AgentHostname
let hostname = sid <> ".local"
installAmbassadorUiNginxHTTPS
(NginxSiteConfOverride
hostname
443
(Just $ NginxSsl { nginxSslKeyPath = entityKeyPath sid
, nginxSslCertPath = entityCertPath sid
, nginxSslOnlyServerNames = [hostname]
}
)
)
nginxSslConf
installAmbassadorUiNginxHTTP nginxTorConf
streamUntar :: (MonadResource m, MonadThrow m) => Text -> ByteStream.ByteStream m () -> m ()
streamUntar root stream = Conduit.runConduit $ Conduit.fromBStream stream .| Conduit.untar \f -> do
let path = toS . (toS root </>) . joinPath . drop 1 . splitPath . B8.unpack . Conduit.filePath $ f
print path
if (Conduit.fileType f == Conduit.FTDirectory)
then liftIO $ createDirectoryIfMissing True path
else Conduit.sinkFile path
installAmbassadorUiNginxHTTP :: (MonadIO m, HasFilesystemBase sig m) => SystemPath -> m ()
installAmbassadorUiNginxHTTP = installAmbassadorUiNginx Nothing
installAmbassadorUiNginxHTTPS :: (MonadIO m, HasFilesystemBase sig m) => NginxSiteConfOverride -> SystemPath -> m ()
installAmbassadorUiNginxHTTPS o = installAmbassadorUiNginx $ Just o
-- Private. Installs an nginx conf from client-manifest to 'fileName' and restarts nginx.
installAmbassadorUiNginx :: (MonadIO m, HasFilesystemBase sig m)
=> Maybe NginxSiteConfOverride
-> SystemPath -- nginx conf file name
-> m ()
installAmbassadorUiNginx mSslOverrides fileName = do
base <- Fused.ask @"filesystemBase"
-- parse app manifest
-- generate nginx conf from app manifest
-- write conf to ambassador target location
appEnv <- flip runReaderT base . handleS9ErrNuclear $ liftA2
(HM.intersectionWith (,))
(AppMgr2.runAppMgrCliC $ HM.mapMaybe AppMgr2.infoResTorAddress <$> AppMgr2.list [AppMgr2.flags| |])
AppMgr.readLanIps -- TODO: get appmgr to expose this or guarantee its structure
agentTor <- getAgentHiddenServiceUrl
let fullEnv = HM.insert (AppId "start9-ambassador") (TorAddress agentTor, LanIp "127.0.0.1") appEnv
removeFileIfExists $ nginxAvailableConf base
removeFileIfExists $ nginxEnabledConf base
flip runReaderT fullEnv
$ transpile mSslOverrides (ambassadorUiClientManifiest base) (nginxAvailableConf base)
>>= \case
True -> pure ()
False -> throwIO . InternalS9Error $ "Failed to write ambassador ui nginx config " <> show fileName
liftIO $ createSymbolicLink (nginxAvailableConf base) (nginxEnabledConf base)
-- restart nginx
void . liftIO $ systemCtl RestartService "nginx"
where
ambassadorUiClientManifiest b = toS $ (ambassadorUiPath <> "/client-manifest.yaml") `relativeTo` b
nginxAvailableConf b = toS $ (nginxSitesAvailable fileName) `relativeTo` b
nginxEnabledConf b = toS $ (nginxSitesEnabled fileName) `relativeTo` b
syncOpenHttpPorts :: SyncOp
syncOpenHttpPorts = SyncOp "Open Hidden Service Port 80" check migrate False
where
check = runResourceT $ do
base <- asks $ appFilesystemBase . appSettings
res <-
ByteStream.readFile (toS $ AppMgr.torrcBase `relativeTo` base)
& ByteStream.lines
& Stream.mapped ByteStream.toStrict
& Stream.map decodeUtf8
& Stream.filter
( ( (== ["HiddenServicePort", "443", "127.0.0.1:443"])
<||> (== ["HiddenServicePort", "80", "127.0.0.1:80"])
)
. words
)
& Stream.toList_
if length res < 2 then pure True else pure False
migrate = cantFail . flip catchE failUpdate $ do
lift $ syncOpRun $ syncWriteConf "Torrc" $(embedFile "config/torrc") AppMgr.torrcBase
AppMgr.torReload
syncInstallAppMgr :: SyncOp
syncInstallAppMgr = SyncOp "Install AppMgr" check migrate False
where
check = runExceptT AppMgr.getAppMgrVersion >>= \case
Left _ -> pure True
Right v -> not . (v <||) <$> asks (appMgrVersionSpec . appSettings)
migrate = fmap (either absurd id) . runExceptT . flip catchE failUpdate $ do
avs <- asks $ appMgrVersionSpec . appSettings
av <- AppMgr.installNewAppMgr avs
unless (av <|| avs) $ throwE $ AppMgrVersionE av avs
syncUpgradeLifeline :: SyncOp
syncUpgradeLifeline = SyncOp "Upgrade Lifeline" check migrate False
where
clearResets :: SystemPath
clearResets = "/usr/local/bin/clear-resets.sh"
check = do
base <- asks $ appFilesystemBase . appSettings
liftIO $ doesFileExist . toS $ clearResets `relativeTo` base
migrate = do
base <- asks $ appFilesystemBase . appSettings
removeFileIfExists . toS $ lifelineBinaryPath `relativeTo` base
mapReaderT runResourceT $ runInContext $ getLifelineBinary (exactly "0.2.0")
removeFileIfExists . toS $ clearResets `relativeTo` base
syncPersistLogs :: SyncOp
syncPersistLogs =
(syncWriteConf "Journald" $(embedFile "config/journald.conf") journaldConfig) { syncOpRequiresReboot = True }
failUpdate :: S9Error -> ExceptT Void (ReaderT AgentCtx IO) ()
failUpdate e = do
ref <- asks appIsUpdateFailed
putStrLn $ "UPDATE FAILED: " <> errorMessage (toError e)
liftIO $ playSong 216 beethoven
liftIO $ writeIORef ref (Just e)
cantFail :: Monad m => ExceptT Void m a -> m a
cantFail = fmap (either absurd id) . runExceptT

23
agent/src/Lib/SystemCtl.hs Normal file
View File

@@ -0,0 +1,23 @@
module Lib.SystemCtl where
import Startlude hiding ( words )
import Protolude.Unsafe ( unsafeHead )
import Data.String
import System.Process
import Text.Casing
data ServiceAction =
StartService
| StopService
| RestartService
deriving (Eq, Show)
toAction :: ServiceAction -> String
toAction = fmap toLower . unsafeHead . words . wordify . show
systemCtl :: ServiceAction -> Text -> IO ExitCode
systemCtl action service = rawSystem "systemctl" [toAction action, toS service]
systemCtlDaemonReload :: IO ExitCode
systemCtlDaemonReload = rawSystem "systemctl" ["daemon-reload"]

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