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

kill the agent

Browse Source
This commit is contained in:
Keagan McClelland
2021-12-30 11:32:26 -07:00
committed by Aiden McClelland
parent b3fe55a895
commit 834eb4b84b
160 changed files with 0 additions and 14527 deletions
Download Patch File Download Diff File Expand all files Collapse all files

40
agent/.gitignore vendored
View File

@@ -1,40 +0,0 @@
dist*
static/tmp/
static/combined/
config/client_session_key.aes
*.hi
*.o
*.sqlite3
*.sqlite3-shm
*.sqlite3-wal
.hsenv*
cabal-dev/
.stack-work/
.stack-work-devel/
yesod-devel/
.cabal-sandbox
cabal.sandbox.config
.DS_Store
*.swp
*.keter
*~
.vscode
\#*
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
View File

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

12
agent/Changelog.md
View File

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

7
agent/README.md
View File

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

3
agent/TODO.md
View File

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

522
agent/ambassador-agent.cabal
View File

@@ -1,522 +0,0 @@
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.34.4.
--
-- see: https://github.com/sol/hpack
name: ambassador-agent
version: 0.2.17
build-type: Simple
extra-source-files:
./migrations/0.1.0::0.1.0
./migrations/0.1.0::0.1.1
./migrations/0.1.1::0.1.2
./migrations/0.1.2::0.1.3
./migrations/0.1.3::0.1.4
./migrations/0.1.4::0.1.5
./migrations/0.1.5::0.2.0
./migrations/0.2.0::0.2.1
./migrations/0.2.10::0.2.11
./migrations/0.2.11::0.2.12
./migrations/0.2.12::0.2.13
./migrations/0.2.13::0.2.14
./migrations/0.2.14::0.2.15
./migrations/0.2.15::0.2.16
./migrations/0.2.16::0.2.17
./migrations/0.2.1::0.2.2
./migrations/0.2.2::0.2.3
./migrations/0.2.3::0.2.4
./migrations/0.2.4::0.2.5
./migrations/0.2.5::0.2.6
./migrations/0.2.6::0.2.7
./migrations/0.2.7::0.2.8
./migrations/0.2.8::0.2.9
./migrations/0.2.9::0.2.10
flag dev
description: Turn on development settings, like auto-reload templates.
manual: False
default: False
flag disable-auth
description: disable authorization checks
manual: False
default: False
flag library-only
description: Build for use with "yesod devel"
manual: False
default: False
library
exposed-modules:
Application
Auth
Constants
Daemon.AppNotifications
Daemon.RefreshProcDev
Daemon.SslRenew
Daemon.TorHealth
Daemon.ZeroConf
Foundation
Handler.Apps
Handler.Authenticate
Handler.Backups
Handler.Hosts
Handler.Icons
Handler.Login
Handler.Network
Handler.Notifications
Handler.PasswordUpdate
Handler.PowerOff
Handler.Register
Handler.Register.Nginx
Handler.Register.Tor
Handler.SelfUpdate
Handler.SshKeys
Handler.Status
Handler.Tor
Handler.Types.Apps
Handler.Types.HmacSig
Handler.Types.Hosts
Handler.Types.Metrics
Handler.Types.Parse
Handler.Types.Register
Handler.Types.V0.Base
Handler.Types.V0.Specs
Handler.Types.V0.Ssh
Handler.Types.V0.Wifi
Handler.Util
Handler.V0
Handler.Wifi
Lib.Algebra.Domain.AppMgr
Lib.Algebra.Domain.AppMgr.TH
Lib.Algebra.Domain.AppMgr.Types
Lib.Algebra.State.RegistryUrl
Lib.Avahi
Lib.Background
Lib.ClientManifest
Lib.Crypto
Lib.Database
Lib.Error
Lib.External.AppManifest
Lib.External.AppMgr
Lib.External.Metrics.Df
Lib.External.Metrics.Iotop
Lib.External.Metrics.ProcDev
Lib.External.Metrics.Temperature
Lib.External.Metrics.Top
Lib.External.Metrics.Types
Lib.External.Registry
Lib.External.Specs.Common
Lib.External.Specs.CPU
Lib.External.Specs.Memory
Lib.External.Util
Lib.External.WpaSupplicant
Lib.IconCache
Lib.Metrics
Lib.Migration
Lib.Notifications
Lib.Password
Lib.ProductKey
Lib.SelfUpdate
Lib.Sound
Lib.Ssh
Lib.Ssl
Lib.Synchronizers
Lib.SystemCtl
Lib.SystemPaths
Lib.Tor
Lib.TyFam.ConditionalData
Lib.Types.Core
Lib.Types.Emver
Lib.Types.Emver.Orphans
Lib.Types.NetAddress
Lib.Types.ServerApp
Lib.Types.Url
Lib.WebServer
Model
Orphans.Digest
Orphans.UUID
Settings
Startlude
Startlude.ByteStream
Startlude.ByteStream.Char8
Util.Conduit
Util.File
Util.Function
Util.Text
other-modules:
Paths_ambassador_agent
hs-source-dirs:
src
default-extensions:
NoImplicitPrelude
BlockArguments
ConstraintKinds
DataKinds
DeriveAnyClass
DeriveFunctor
DeriveGeneric
DerivingStrategies
EmptyCase
FlexibleContexts
FlexibleInstances
GADTs
GeneralizedNewtypeDeriving
InstanceSigs
KindSignatures
LambdaCase
MultiParamTypeClasses
MultiWayIf
NamedFieldPuns
NumericUnderscores
OverloadedStrings
PolyKinds
RankNTypes
StandaloneDeriving
StandaloneKindSignatures
TupleSections
TypeApplications
TypeFamilies
TypeOperators
build-depends:
aeson
, aeson-flatten
, attoparsec
, base >=4.9.1.0 && <5
, bytestring
, casing
, comonad
, conduit
, conduit-extra
, connection
, containers
, cryptonite
, cryptonite-conduit
, data-default
, directory
, errors
, exceptions
, exinst
, fast-logger
, file-embed
, filelock
, filepath
, fused-effects
, fused-effects-th
, git-embed
, http-api-data
, http-client
, http-client-tls
, http-conduit
, http-types
, interpolate
, iso8601-time
, json-rpc
, lens
, lens-aeson
, lifted-async
, lifted-base
, memory
, mime-types
, monad-control
, monad-logger
, network
, persistent
, persistent-sqlite
, persistent-template
, process
, process-extras
, protolude
, regex-compat
, resourcet
, shell-conduit
, singletons
, stm
, streaming
, streaming-bytestring
, streaming-conduit
, streaming-utils
, tar-conduit
, template-haskell
, text >=0.11 && <2.0
, time
, transformers
, transformers-base
, typed-process
, unix
, unliftio
, unliftio-core
, unordered-containers
, uuid
, wai
, wai-cors
, wai-extra
, warp
, yaml
, yesod
, yesod-auth
, yesod-core
, yesod-form
, yesod-persistent
if (flag(dev)) || (flag(library-only))
ghc-options: -Wall -Wunused-packages -fwarn-tabs -O0 -fdefer-typed-holes
cpp-options: -DDEVELOPMENT
else
ghc-options: -Wall -Wunused-packages -fwarn-tabs -O2 -fdefer-typed-holes
if (flag(disable-auth))
cpp-options: -DDISABLE_AUTH
default-language: Haskell2010
executable agent
main-is: main.hs
hs-source-dirs:
app
default-extensions:
NoImplicitPrelude
BlockArguments
ConstraintKinds
DataKinds
DeriveAnyClass
DeriveFunctor
DeriveGeneric
DerivingStrategies
EmptyCase
FlexibleContexts
FlexibleInstances
GADTs
GeneralizedNewtypeDeriving
InstanceSigs
KindSignatures
LambdaCase
MultiParamTypeClasses
MultiWayIf
NamedFieldPuns
NumericUnderscores
OverloadedStrings
PolyKinds
RankNTypes
StandaloneDeriving
StandaloneKindSignatures
TupleSections
TypeApplications
TypeFamilies
TypeOperators
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fdefer-typed-holes
build-depends:
aeson
, aeson-flatten
, ambassador-agent
, attoparsec
, base >=4.9.1.0 && <5
, bytestring
, casing
, comonad
, conduit
, conduit-extra
, connection
, containers
, cryptonite
, cryptonite-conduit
, data-default
, directory
, errors
, exceptions
, exinst
, fast-logger
, file-embed
, filelock
, filepath
, fused-effects
, fused-effects-th
, git-embed
, http-api-data
, http-client
, http-client-tls
, http-conduit
, http-types
, interpolate
, iso8601-time
, json-rpc
, lens
, lens-aeson
, lifted-async
, lifted-base
, memory
, mime-types
, monad-control
, monad-logger
, network
, persistent
, persistent-sqlite
, persistent-template
, process
, process-extras
, protolude
, regex-compat
, resourcet
, shell-conduit
, singletons
, stm
, streaming
, streaming-bytestring
, streaming-conduit
, streaming-utils
, tar-conduit
, template-haskell
, text >=0.11 && <2.0
, time
, transformers
, transformers-base
, typed-process
, unix
, unliftio
, unliftio-core
, unordered-containers
, uuid
, wai
, wai-cors
, wai-extra
, warp
, yaml
, yesod
, yesod-auth
, yesod-core
, yesod-form
, yesod-persistent
if flag(library-only)
buildable: False
default-language: Haskell2010
test-suite agent-test
type: exitcode-stdio-1.0
main-is: Main.hs
other-modules:
ChecklistSpec
Lib.External.AppManifestSpec
Lib.SoundSpec
Lib.Types.EmverProp
Live.Metrics
Live.Serialize
Spec
hs-source-dirs:
test
default-extensions:
NoImplicitPrelude
BlockArguments
ConstraintKinds
DataKinds
DeriveAnyClass
DeriveFunctor
DeriveGeneric
DerivingStrategies
EmptyCase
FlexibleContexts
FlexibleInstances
GADTs
GeneralizedNewtypeDeriving
InstanceSigs
KindSignatures
LambdaCase
MultiParamTypeClasses
MultiWayIf
NamedFieldPuns
NumericUnderscores
OverloadedStrings
PolyKinds
RankNTypes
StandaloneDeriving
StandaloneKindSignatures
TupleSections
TypeApplications
TypeFamilies
TypeOperators
ghc-options: -Wall -fdefer-typed-holes
build-depends:
aeson
, aeson-flatten
, ambassador-agent
, attoparsec
, base >=4.9.1.0 && <5
, bytestring
, casing
, comonad
, conduit
, conduit-extra
, connection
, containers
, cryptonite
, cryptonite-conduit
, data-default
, directory
, errors
, exceptions
, exinst
, fast-logger
, file-embed
, filelock
, filepath
, fused-effects
, fused-effects-th
, git-embed
, hedgehog
, hspec >=2.0.0
, hspec-expectations
, http-api-data
, http-client
, http-client-tls
, http-conduit
, http-types
, interpolate
, iso8601-time
, json-rpc
, lens
, lens-aeson
, lifted-async
, lifted-base
, memory
, mime-types
, monad-control
, monad-logger
, network
, persistent
, persistent-sqlite
, persistent-template
, process
, process-extras
, protolude
, random
, regex-compat
, resourcet
, shell-conduit
, singletons
, stm
, streaming
, streaming-bytestring
, streaming-conduit
, streaming-utils
, tar-conduit
, template-haskell
, text >=0.11 && <2.0
, time
, transformers
, transformers-base
, typed-process
, unix
, unliftio
, unliftio-core
, unordered-containers
, uuid
, wai
, wai-cors
, wai-extra
, warp
, yaml
, yesod
, yesod-auth
, yesod-core
, yesod-form
, yesod-persistent
, yesod-test
default-language: Haskell2010

5
agent/app/main.hs
View File

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

60
agent/brittany.yaml
View File

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

6
agent/build.sh
View File

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

23
agent/cabal.project
View File

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

2513
agent/cabal.project.freeze
View File

File diff suppressed because it is too large Load Diff

14
agent/config/agent.service
View File

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

6
agent/config/journald.conf
View File

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

29
agent/config/nginx.conf
View File

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

7
agent/config/restarter.service
View File

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

9
agent/config/restarter.timer
View File

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

61
agent/config/routes
View File

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

37
agent/config/settings.yml
View File

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

5
agent/config/torrc
View File

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

13
agent/hie.yaml
View File

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

1
agent/migrations/0.1.0::0.1.0
View File

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

1
agent/migrations/0.1.0::0.1.1
View File

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

1
agent/migrations/0.1.1::0.1.2
View File

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

1
agent/migrations/0.1.2::0.1.3
View File

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

1
agent/migrations/0.1.3::0.1.4
View File

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

1
agent/migrations/0.1.4::0.1.5
View File

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

2
agent/migrations/0.1.5::0.2.0
View File

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

1
agent/migrations/0.2.0::0.2.1
View File

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

1
agent/migrations/0.2.10::0.2.11
View File

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

1
agent/migrations/0.2.11::0.2.12
View File

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

1
agent/migrations/0.2.12::0.2.13
View File

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

1
agent/migrations/0.2.13::0.2.14
View File

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

1
agent/migrations/0.2.14::0.2.15
View File

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

1
agent/migrations/0.2.15::0.2.16
View File

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

1
agent/migrations/0.2.16::0.2.17
View File

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

1
agent/migrations/0.2.1::0.2.2
View File

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

1
agent/migrations/0.2.2::0.2.3
View File

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

1
agent/migrations/0.2.3::0.2.4
View File

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

1
agent/migrations/0.2.4::0.2.5
View File

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

1
agent/migrations/0.2.5::0.2.6
View File

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

1
agent/migrations/0.2.6::0.2.7
View File

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

1
agent/migrations/0.2.7::0.2.8
View File

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

1
agent/migrations/0.2.8::0.2.9
View File

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

1
agent/migrations/0.2.9::0.2.10
View File

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

185
agent/package.yaml
View File

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

247
agent/src/Application.hs
View File

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

19
agent/src/Auth.hs
View File

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

16
agent/src/Constants.hs
View File

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

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

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

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

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

98
agent/src/Daemon/SslRenew.hs
View File

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

50
agent/src/Daemon/TorHealth.hs
View File

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

65
agent/src/Daemon/ZeroConf.hs
View File

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

226
agent/src/Foundation.hs
View File

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

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

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

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

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

244
agent/src/Handler/Backups.hs
View File

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

56
agent/src/Handler/Hosts.hs
View File

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

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

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

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

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

36
agent/src/Handler/Network.hs
View File

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

36
agent/src/Handler/Notifications.hs
View File

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

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

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

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

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

166
agent/src/Handler/Register.hs
View File

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

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

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

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

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

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

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

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

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

81
agent/src/Handler/Status.hs
View File

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

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

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

213
agent/src/Handler/Types/Apps.hs
View File

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

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

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

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

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

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

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

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

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

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

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

82
agent/src/Handler/Types/V0/Base.hs
View File

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

48
agent/src/Handler/Types/V0/Specs.hs
View File

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

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

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

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

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

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

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

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

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

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

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

483
agent/src/Lib/Algebra/Domain/AppMgr.hs
View File

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

289
agent/src/Lib/Error.hs
View File

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

157
agent/src/Lib/External/AppManifest.hs vendored
View File

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

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

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

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

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

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

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

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

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

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

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

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