diff --git a/agent/.gitignore b/agent/.gitignore deleted file mode 100644 index e68da4df1..000000000 --- a/agent/.gitignore +++ /dev/null @@ -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 diff --git a/agent/.stylish-haskell.yaml b/agent/.stylish-haskell.yaml deleted file mode 100644 index 77f782fc0..000000000 --- a/agent/.stylish-haskell.yaml +++ /dev/null @@ -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'. - # - # - : 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 diff --git a/agent/Changelog.md b/agent/Changelog.md deleted file mode 100644 index c5162c552..000000000 --- a/agent/Changelog.md +++ /dev/null @@ -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 \ No newline at end of file diff --git a/agent/README.md b/agent/README.md deleted file mode 100644 index 4b31a7dc7..000000000 --- a/agent/README.md +++ /dev/null @@ -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 \ No newline at end of file diff --git a/agent/TODO.md b/agent/TODO.md deleted file mode 100644 index 79d19f3dd..000000000 --- a/agent/TODO.md +++ /dev/null @@ -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 ` throws no error, but completes without the app being stopped, we need to restart dockerd. diff --git a/agent/ambassador-agent.cabal b/agent/ambassador-agent.cabal deleted file mode 100644 index 14a7f96c6..000000000 --- a/agent/ambassador-agent.cabal +++ /dev/null @@ -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 diff --git a/agent/app/main.hs b/agent/app/main.hs deleted file mode 100644 index 035cf5583..000000000 --- a/agent/app/main.hs +++ /dev/null @@ -1,5 +0,0 @@ -import Application ( appMain ) -import Startlude - -main :: IO () -main = appMain diff --git a/agent/brittany.yaml b/agent/brittany.yaml deleted file mode 100644 index e07b9b930..000000000 --- a/agent/brittany.yaml +++ /dev/null @@ -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 diff --git a/agent/build.sh b/agent/build.sh deleted file mode 100755 index 14e27c205..000000000 --- a/agent/build.sh +++ /dev/null @@ -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 diff --git a/agent/cabal.project b/agent/cabal.project deleted file mode 100644 index b7509239a..000000000 --- a/agent/cabal.project +++ /dev/null @@ -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 diff --git a/agent/cabal.project.freeze b/agent/cabal.project.freeze deleted file mode 100644 index 6178d5a21..000000000 --- a/agent/cabal.project.freeze +++ /dev/null @@ -1,2513 +0,0 @@ -constraints: any.AC-Angle ==1.0, - any.ALUT ==2.4.0.3, - any.ANum ==0.2.0.2, - any.Allure ==0.9.5.0, - any.Boolean ==0.2.4, - any.BoundedChan ==1.0.3.0, - any.ChannelT ==0.0.0.7, - any.Chart ==1.9.3, - any.ChasingBottoms ==1.3.1.9, - any.Clipboard ==2.3.2.0, - any.ClustalParser ==1.3.0, - any.Color ==0.2.0, - any.ConfigFile ==1.1.4, - any.DAV ==1.3.4, - any.DBFunctor ==0.1.1.1, - any.Decimal ==0.5.1, - any.Diff ==0.4.0, - any.ENIG ==0.0.1.0, - any.Earley ==0.13.0.1, - any.Ebnf2ps ==1.0.15, - any.FenwickTree ==0.1.2.1, - any.FindBin ==0.0.5, - any.FloatingHex ==0.5, - any.FontyFruity ==0.5.3.5, - any.ForestStructures ==0.0.1.0, - any.GLFW-b ==3.3.0.0, - any.GLURaw ==2.0.0.4, - any.GLUT ==2.7.0.15, - any.GenericPretty ==1.2.2, - any.Glob ==0.10.1, - any.HCodecs ==0.5.2, - any.HDBC ==2.4.0.3, - any.HDBC-session ==0.1.2.0, - any.HSlippyMap ==3.0.1, - any.HStringTemplate ==0.8.7, - any.HSvm ==0.1.1.3.22, - any.HTTP ==4000.3.15, - any.HUnit ==1.6.0.0, - any.HUnit-approx ==1.1.1.1, - any.HaTeX ==3.22.2.0, - any.HaXml ==1.25.5, - any.HandsomeSoup ==0.4.2, - any.HasBigDecimal ==0.1.1, - HsOpenSSL -fast-bignum, - any.HsOpenSSL ==0.11.4.19, - any.HsYAML ==0.2.1.0, - any.HsYAML-aeson ==0.2.0.0, - any.IPv6Addr ==1.1.5, - any.Imlib ==0.1.2, - any.IntervalMap ==0.6.1.2, - any.JuicyPixels ==3.3.5, - any.JuicyPixels-blurhash ==0.1.0.3, - any.JuicyPixels-extra ==0.4.1, - any.JuicyPixels-scale-dct ==0.1.2, - any.LambdaHack ==0.9.5.0, - any.LibZip ==1.0.1, - any.List ==0.6.2, - any.ListLike ==4.7.2, - any.ListTree ==0.2.3, - any.MapWith ==0.2.0.0, - any.MemoTrie ==0.6.10, - any.MissingH ==1.4.3.0, - any.MonadPrompt ==1.0.0.5, - any.MonadRandom ==0.5.2, - any.MusicBrainz ==0.4.1, - NineP -bytestring-in-base, - any.NineP ==0.0.2.1, - any.NumInstances ==1.4, - any.ObjectName ==1.1.0.1, - any.OneTuple ==0.2.2.1, - any.Only ==0.1, - any.OpenAL ==1.7.0.5, - any.OpenGL ==3.0.3.0, - any.OpenGLRaw ==3.3.4.0, - any.ParsecTools ==0.0.2.0, - any.PyF ==0.9.0.2, - any.QuasiText ==0.1.2.6, - any.QuickCheck ==2.13.2, - any.RSA ==2.4.1, - any.Ranged-sets ==0.4.0, - any.Rasterific ==0.7.5.3, - any.RefSerialize ==0.4.0, - any.SHA ==1.6.4.4, - any.SafeSemaphore ==0.10.1, - any.ShellCheck ==0.7.1, - any.Spintax ==0.3.5, - any.StateVar ==1.2, - any.TCache ==0.12.1, - any.Taxonomy ==2.1.0, - any.TypeCompose ==0.9.14, - any.ViennaRNAParser ==1.3.3, - any.Win32 ==2.6.1.0, - any.Win32-notify ==0.3.0.3, - any.X11 ==1.9.2, - any.X11-xft ==0.3.1, - any.Xauth ==0.1, - any.abstract-deque ==0.3, - any.abstract-par ==0.3.3, - any.accuerr ==0.2.0.2, - any.ace ==0.6, - any.action-permutations ==0.0.0.1, - any.ad ==4.4, - any.adjunctions ==4.4, - any.adler32 ==0.1.2.0, - any.aeson ==1.4.7.1, - any.aeson-attoparsec ==0.0.0, - any.aeson-better-errors ==0.9.1.0, - any.aeson-casing ==0.2.0.0, - any.aeson-combinators ==0.0.2.1, - any.aeson-compat ==0.3.9, - any.aeson-default ==0.9.1.0, - any.aeson-diff ==1.1.0.9, - any.aeson-flatten ==0.1.0.2, - any.aeson-generic-compat ==0.0.1.3, - any.aeson-lens ==0.5.0.0, - any.aeson-optics ==1.1.0.1, - any.aeson-picker ==0.1.0.5, - any.aeson-pretty ==0.8.8, - any.aeson-qq ==0.8.3, - any.aeson-schemas ==1.3.1, - any.aeson-with ==0.1.2.0, - any.aeson-yak ==0.1.1.3, - any.aeson-yaml ==1.1.0.0, - any.al ==0.1.4.2, - any.alarmclock ==0.7.0.5, - any.alerts ==0.1.2.0, - any.alex ==3.2.5, - any.alg ==0.2.13.1, - any.algebraic-graphs ==0.5, - any.almost-fix ==0.0.2, - any.alsa-core ==0.5.0.1, - any.alsa-mixer ==0.3.0, - any.alsa-pcm ==0.6.1.1, - any.alsa-seq ==0.6.0.7, - any.alternative-vector ==0.0.0, - any.amazonka-apigateway ==1.6.1, - any.amazonka-application-autoscaling ==1.6.1, - any.amazonka-appstream ==1.6.1, - any.amazonka-athena ==1.6.1, - any.amazonka-autoscaling ==1.6.1, - any.amazonka-budgets ==1.6.1, - any.amazonka-certificatemanager ==1.6.1, - any.amazonka-cloudformation ==1.6.1, - any.amazonka-cloudfront ==1.6.1, - any.amazonka-cloudhsm ==1.6.1, - any.amazonka-cloudsearch ==1.6.1, - any.amazonka-cloudsearch-domains ==1.6.1, - any.amazonka-cloudtrail ==1.6.1, - any.amazonka-cloudwatch ==1.6.1, - any.amazonka-cloudwatch-events ==1.6.1, - any.amazonka-cloudwatch-logs ==1.6.1, - any.amazonka-codebuild ==1.6.1, - any.amazonka-codecommit ==1.6.1, - any.amazonka-codedeploy ==1.6.1, - any.amazonka-codepipeline ==1.6.1, - any.amazonka-cognito-identity ==1.6.1, - any.amazonka-cognito-idp ==1.6.1, - any.amazonka-cognito-sync ==1.6.1, - any.amazonka-config ==1.6.1, - any.amazonka-core ==1.6.1, - any.amazonka-datapipeline ==1.6.1, - any.amazonka-devicefarm ==1.6.1, - any.amazonka-directconnect ==1.6.1, - any.amazonka-discovery ==1.6.1, - any.amazonka-dms ==1.6.1, - any.amazonka-ds ==1.6.1, - any.amazonka-dynamodb ==1.6.1, - any.amazonka-dynamodb-streams ==1.6.1, - any.amazonka-ecr ==1.6.1, - any.amazonka-ecs ==1.6.1, - any.amazonka-efs ==1.6.1, - any.amazonka-elasticache ==1.6.1, - any.amazonka-elasticbeanstalk ==1.6.1, - any.amazonka-elasticsearch ==1.6.1, - any.amazonka-elastictranscoder ==1.6.1, - any.amazonka-elb ==1.6.1, - any.amazonka-elbv2 ==1.6.1, - any.amazonka-emr ==1.6.1, - any.amazonka-gamelift ==1.6.1, - any.amazonka-glacier ==1.6.1, - any.amazonka-glue ==1.6.1, - any.amazonka-health ==1.6.1, - any.amazonka-iam ==1.6.1, - any.amazonka-importexport ==1.6.1, - any.amazonka-inspector ==1.6.1, - any.amazonka-iot ==1.6.1, - any.amazonka-iot-dataplane ==1.6.1, - any.amazonka-kinesis ==1.6.1, - any.amazonka-kinesis-analytics ==1.6.1, - any.amazonka-kinesis-firehose ==1.6.1, - any.amazonka-kms ==1.6.1, - any.amazonka-lambda ==1.6.1, - any.amazonka-lightsail ==1.6.1, - any.amazonka-marketplace-analytics ==1.6.1, - any.amazonka-marketplace-metering ==1.6.1, - any.amazonka-ml ==1.6.1, - any.amazonka-opsworks ==1.6.1, - any.amazonka-opsworks-cm ==1.6.1, - any.amazonka-pinpoint ==1.6.1, - any.amazonka-polly ==1.6.1, - any.amazonka-rds ==1.6.1, - any.amazonka-redshift ==1.6.1, - any.amazonka-rekognition ==1.6.1, - any.amazonka-route53 ==1.6.1, - any.amazonka-route53-domains ==1.6.1, - any.amazonka-s3 ==1.6.1, - any.amazonka-sdb ==1.6.1, - any.amazonka-servicecatalog ==1.6.1, - any.amazonka-ses ==1.6.1, - any.amazonka-shield ==1.6.1, - any.amazonka-sms ==1.6.1, - any.amazonka-snowball ==1.6.1, - any.amazonka-sns ==1.6.1, - any.amazonka-sqs ==1.6.1, - any.amazonka-ssm ==1.6.1, - any.amazonka-stepfunctions ==1.6.1, - any.amazonka-storagegateway ==1.6.1, - any.amazonka-sts ==1.6.1, - any.amazonka-support ==1.6.1, - any.amazonka-swf ==1.6.1, - any.amazonka-test ==1.6.1, - any.amazonka-waf ==1.6.1, - any.amazonka-workspaces ==1.6.1, - any.amazonka-xray ==1.6.1, - any.amqp ==0.20.0, - any.amqp-utils ==0.4.4.1, - any.annotated-wl-pprint ==0.7.0, - any.ansi-terminal ==0.10.3, - any.ansi-wl-pprint ==0.6.9, - any.ap-normalize ==0.1.0.0, - any.apecs ==0.9.2, - any.apecs-gloss ==0.2.4, - any.apecs-physics ==0.4.4, - any.api-field-json-th ==0.1.0.2, - any.app-settings ==0.2.0.12, - any.appar ==0.1.8, - any.appendmap ==0.1.5, - any.apply-refact ==0.8.2.1, - any.apportionment ==0.0.0.3, - any.approximate ==0.3.2, - any.approximate-equality ==1.1.0.2, - any.arbor-lru-cache ==0.1.1.1, - any.arithmoi ==0.11.0.1, - any.array-memoize ==0.6.0, - any.arrow-extras ==0.1.0.1, - any.ascii ==1.0.0.2, - any.ascii-case ==1.0.0.2, - any.ascii-char ==1.0.0.2, - any.ascii-group ==1.0.0.2, - any.ascii-predicates ==1.0.0.2, - any.ascii-progress ==0.3.3.0, - any.ascii-superset ==1.0.0.2, - any.ascii-th ==1.0.0.2, - any.asciidiagram ==1.3.3.3, - any.asif ==6.0.4, - any.asn1-encoding ==0.9.6, - any.asn1-parse ==0.9.5, - any.asn1-types ==0.3.4, - any.assert-failure ==0.1.2.5, - any.assoc ==1.0.2, - any.astro ==0.4.2.1, - any.async ==2.2.2, - any.async-extra ==0.2.0.0, - any.async-pool ==0.9.1, - any.async-refresh ==0.3.0.0, - any.async-refresh-tokens ==0.4.0.0, - any.atom-basic ==0.2.5, - any.atomic-primops ==0.8.3, - any.atomic-write ==0.2.0.7, - any.attoparsec ==0.13.2.4, - any.attoparsec-base64 ==0.0.0, - any.attoparsec-binary ==0.2, - any.attoparsec-expr ==0.1.1.2, - any.attoparsec-iso8601 ==1.0.1.0, - any.attoparsec-path ==0.0.0.1, - any.audacity ==0.0.2, - any.aur ==7.0.4, - any.aura ==3.1.9, - any.authenticate ==1.3.5, - any.authenticate-oauth ==1.6.0.1, - any.auto ==0.4.3.1, - any.auto-update ==0.1.6, - any.autoexporter ==1.1.19, - any.avers ==0.0.17.1, - any.avro ==0.5.2.0, - any.aws-cloudfront-signed-cookies ==0.2.0.6, - any.bank-holidays-england ==0.2.0.5, - any.base-compat ==0.11.1, - any.base-compat-batteries ==0.11.1, - any.base-orphans ==0.8.2, - any.base-prelude ==1.4, - any.base-unicode-symbols ==0.2.4.2, - any.base16 ==0.3.0.1, - any.base16-bytestring ==0.1.1.7, - any.base16-lens ==0.1.3.0, - any.base32 ==0.2.0.0, - any.base32-lens ==0.1.0.0, - any.base32string ==0.9.1, - any.base58-bytestring ==0.1.0, - any.base58string ==0.10.0, - any.base64 ==0.4.2.2, - any.base64-bytestring ==1.1.0.0, - any.base64-bytestring-type ==1.0.1, - any.base64-lens ==0.3.0, - any.base64-string ==0.2, - any.basement ==0.0.11, - any.basic-prelude ==0.7.0, - any.bazel-runfiles ==0.12, - any.bbdb ==0.8, - any.bcrypt ==0.0.11, - any.bech32 ==1.1.0, - any.bech32-th ==1.0.2, - any.bench ==1.0.12, - any.benchpress ==0.2.2.14, - any.between ==0.11.0.0, - any.bibtex ==0.1.0.6, - any.bifunctors ==5.5.7, - any.bimap ==0.4.0, - any.bimap-server ==0.1.0.1, - any.bimaps ==0.1.0.2, - any.bin ==0.1, - any.binary-conduit ==1.3.1, - any.binary-ext ==2.0.4, - any.binary-ieee754 ==0.1.0.0, - any.binary-instances ==1.0.0.1, - any.binary-list ==1.1.1.2, - any.binary-orphans ==1.0.1, - any.binary-parser ==0.5.6, - any.binary-parsers ==0.2.4.0, - any.binary-search ==1.0.0.3, - any.binary-shared ==0.8.3, - any.binary-tagged ==0.3, - any.binaryen ==0.0.4.0, - any.bindings-DSL ==1.0.25, - any.bindings-GLFW ==3.3.2.0, - any.bindings-libzip ==1.0.1, - any.bindings-uname ==0.1, - any.bins ==0.1.2.0, - any.bitarray ==0.0.1.1, - any.bits ==0.5.2, - any.bits-extra ==0.0.2.0, - any.bitset-word8 ==0.1.1.2, - any.bitvec ==1.0.3.0, - any.blake2 ==0.3.0, - any.blanks ==0.4.1, - any.blas-carray ==0.1.0.1, - any.blas-comfort-array ==0.0.0.2, - any.blas-ffi ==0.1, - any.blaze-bootstrap ==0.1.0.1, - any.blaze-builder ==0.4.1.0, - any.blaze-html ==0.9.1.2, - any.blaze-markup ==0.8.2.7, - any.blaze-svg ==0.3.6.1, - any.blaze-textual ==0.2.1.0, - any.bmp ==1.2.6.3, - any.board-games ==0.3, - any.boltzmann-samplers ==0.1.1.0, - any.boolean-like ==0.1.1.0, - any.boolsimplifier ==0.1.8, - any.boots ==0.2.0.1, - any.bordacount ==0.1.0.0, - any.boring ==0.1.3, - any.both ==0.1.1.1, - any.bound ==2.0.1, - any.bounded-queue ==1.0.0, - any.boundingboxes ==0.2.3, - any.bower-json ==1.0.0.1, - any.boxes ==0.1.5, - brick +demos, - any.brick ==0.56, - any.broadcast-chan ==0.2.1.1, - any.bsb-http-chunked ==0.0.0.4, - bson -_old-network, - any.bson ==0.4.0.1, - any.btrfs ==0.2.0.0, - any.buffer-builder ==0.2.4.7, - any.buffer-pipe ==0.0, - any.bugsnag-hs ==0.2.0.1, - any.bugzilla-redhat ==0.3.0, - any.burrito ==1.1.0.2, - any.butcher ==1.3.3.2, - any.bv ==0.5, - any.bv-little ==1.1.1, - any.byte-order ==0.1.2.0, - any.byteable ==0.1.1, - any.bytedump ==1.0, - any.byteorder ==1.0.4, - any.bytes ==0.17, - any.byteset ==0.1.1.0, - any.bytestring-builder ==0.10.8.2.0, - any.bytestring-conversion ==0.3.1, - any.bytestring-lexing ==0.5.0.2, - any.bytestring-mmap ==0.2.2, - any.bytestring-strict-builder ==0.4.5.3, - any.bytestring-to-vector ==0.3.0.1, - any.bytestring-tree-builder ==0.2.7.4, - bz2 -with-bzlib, - any.bz2 ==1.0.1.0, - any.bzlib ==0.5.1.0, - any.bzlib-conduit ==0.3.0.2, - any.c14n ==0.1.0.1, - any.c2hs ==0.28.6, - any.ca-province-codes ==1.0.0.0, - any.cabal-debian ==5.1, - any.cabal-doctest ==1.0.8, - any.cabal-file ==0.1.0, - any.cabal-flatpak ==0.1.0.2, - any.cabal-plan ==0.7.1.0, - cabal-rpm -old-locale, - any.cabal-rpm ==2.0.6, - any.cabal2nix ==2.15.5, - any.cabal2spec ==2.6.2, - any.cache ==0.1.3.0, - any.cacophony ==0.10.1, - any.calendar-recycling ==0.0.0.1, - any.call-stack ==0.2.0, - any.can-i-haz ==0.3.1.0, - any.cardano-coin-selection ==1.0.1, - any.carray ==0.1.6.8, - any.casa-client ==0.0.1, - any.casa-types ==0.0.1, - any.case-insensitive ==1.2.1.0, - any.cased ==0.1.0.0, - any.cases ==0.1.4, - any.casing ==0.1.4.1, - cassava -bytestring--lt-0_10_4, - any.cassava ==0.5.2.0, - any.cassava-conduit ==0.6.0, - any.cassava-megaparsec ==2.0.2, - any.cast ==0.1.0.2, - any.category ==0.2.5.0, - any.cayley-client ==0.4.13, - any.cborg ==0.2.4.0, - any.cborg-json ==0.2.2.0, - any.cereal ==0.5.8.1, - any.cereal-conduit ==0.8.0, - any.cereal-text ==0.1.0.2, - any.cereal-vector ==0.2.0.1, - any.cfenv ==0.1.0.0, - any.cgi ==3001.5.0.0, - any.chan ==0.0.4.1, - any.character-cases ==0.1.0.6, - any.charset ==0.3.7.1, - any.charsetdetect-ae ==1.1.0.4, - any.chaselev-deque ==0.5.0.5, - any.cheapskate ==0.1.1.2, - any.cheapskate-highlight ==0.1.0.0, - any.cheapskate-lucid ==0.1.0.0, - any.checkers ==0.5.6, - any.checksum ==0.0, - any.chimera ==0.3.1.0, - any.chiphunk ==0.1.2.1, - any.choice ==0.2.2, - any.chronologique ==0.3.1.3, - any.chronos ==1.1.1, - any.chronos-bench ==0.2.0.2, - any.chunked-data ==0.3.1, - any.cipher-aes ==0.2.11, - any.cipher-camellia ==0.0.2, - any.cipher-des ==0.0.6, - any.cipher-rc4 ==0.1.4, - any.circle-packing ==0.1.0.6, - any.clash-ghc ==1.2.4, - any.clash-lib ==1.2.4, - any.clash-prelude ==1.2.4, - any.classy-prelude ==1.5.0, - any.classy-prelude-conduit ==1.5.0, - any.clay ==0.13.3, - any.clientsession ==0.9.1.2, - any.climb ==0.3.3, - any.clock ==0.8, - any.clock-extras ==0.1.0.2, - any.clumpiness ==0.17.0.2, - any.cmark ==0.6, - any.cmark-gfm ==0.2.2, - any.cmark-lucid ==0.1.0.0, - any.cmdargs ==0.10.20, - any.co-log ==0.4.0.1, - any.co-log-concurrent ==0.5.0.0, - any.co-log-core ==0.2.1.1, - any.co-log-polysemy ==0.0.1.2, - any.code-page ==0.2, - any.codec-beam ==0.2.0, - any.codec-rpm ==0.2.2, - any.colorful-monoids ==0.2.1.3, - any.colorize-haskell ==1.0.1, - any.colour ==2.3.5, - any.colourista ==0.1.0.0, - any.combinatorial ==0.1.0.1, - any.comfort-array ==0.4, - any.comfort-graph ==0.0.3.1, - any.commutative ==0.0.2, - any.comonad ==5.0.6, - any.comonad-extras ==4.0.1, - any.compactmap ==0.1.4.2.1, - any.compensated ==0.8.1, - any.compiler-warnings ==0.1.0, - any.composable-associations ==0.1.0.0, - any.composable-associations-aeson ==0.1.0.0, - any.composite-aeson ==0.7.4.0, - any.composite-aeson-path ==0.7.4.0, - any.composite-aeson-refined ==0.7.4.0, - any.composite-base ==0.7.4.0, - any.composite-binary ==0.7.4.0, - any.composite-ekg ==0.7.4.0, - any.composite-hashable ==0.7.4.0, - any.composite-tuple ==0.1.2.0, - any.composite-xstep ==0.1.0.0, - any.composition ==1.0.2.1, - any.composition-extra ==2.0.0, - any.concise ==0.1.0.1, - any.concurrency ==1.11.0.0, - any.concurrent-extra ==0.7.0.12, - any.concurrent-output ==1.10.12, - any.concurrent-split ==0.0.1.1, - any.concurrent-supply ==0.1.8, - any.cond ==0.4.1.1, - any.conduit ==1.3.2.1, - any.conduit-algorithms ==0.0.11.0, - any.conduit-combinators ==1.3.0, - any.conduit-concurrent-map ==0.1.1, - any.conduit-extra ==1.3.5, - any.conduit-parse ==0.2.1.0, - any.conduit-zstd ==0.0.2.0, - any.conferer ==0.4.1.1, - any.conferer-hspec ==0.4.0.1, - any.conferer-source-json ==0.4.0.1, - any.conferer-warp ==0.4.0.1, - any.config-ini ==0.2.4.0, - any.configurator ==0.3.0.0, - any.configurator-export ==0.1.0.1, - any.configurator-pg ==0.2.4, - any.connection ==0.3.1, - any.connection-pool ==0.2.2, - any.console-style ==0.0.2.1, - any.constraint ==0.1.4.0, - any.constraint-tuples ==0.1.2, - any.constraints ==0.12, - any.construct ==0.3, - any.contravariant ==1.5.2, - any.contravariant-extras ==0.3.5.2, - any.control-bool ==0.2.1, - any.control-monad-free ==0.6.2, - any.control-monad-omega ==0.3.2, - any.convertible ==1.1.1.0, - any.cookie ==0.4.5, - any.core-data ==0.2.1.8, - any.core-program ==0.2.4.5, - any.core-text ==0.2.3.6, - any.countable ==1.0, - any.country ==0.2.1, - any.cpio-conduit ==0.7.0, - any.cpphs ==1.20.9.1, - any.cprng-aes ==0.6.1, - any.cpu ==0.1.2, - any.cpuinfo ==0.1.0.1, - any.crackNum ==2.4, - any.crc32c ==0.0.0, - any.credential-store ==0.1.2, - any.criterion ==1.5.6.2, - any.criterion-measurement ==0.1.2.0, - any.cron ==0.7.0, - any.crypto-api ==0.13.3, - any.crypto-cipher-types ==0.0.9, - any.crypto-enigma ==0.1.1.6, - any.crypto-numbers ==0.2.7, - any.crypto-pubkey ==0.2.8, - any.crypto-pubkey-types ==0.4.3, - any.crypto-random ==0.0.9, - any.crypto-random-api ==0.2.0, - any.cryptocompare ==0.1.2, - any.cryptohash ==0.11.9, - any.cryptohash-cryptoapi ==0.1.4, - any.cryptohash-md5 ==0.11.100.1, - any.cryptohash-sha1 ==0.11.100.1, - any.cryptohash-sha256 ==0.11.101.0, - any.cryptonite ==0.27, - any.cryptonite-conduit ==0.2.2, - any.cryptonite-openssl ==0.7, - any.csp ==1.4.0, - any.css-syntax ==0.1.0.0, - any.css-text ==0.1.3.0, - any.csv ==0.1.2, - any.ctrie ==0.2, - any.cubicbezier ==0.6.0.6, - any.cubicspline ==0.1.2, - any.cuckoo-filter ==0.2.0.2, - any.cue-sheet ==2.0.1, - curl +new-base, - any.curl ==1.3.8, - any.currencies ==0.2.0.0, - any.currency ==0.2.0.0, - any.cursor ==0.3.0.0, - any.cursor-brick ==0.1.0.0, - any.cursor-fuzzy-time ==0.0.0.0, - any.cursor-gen ==0.3.0.0, - any.cutter ==0.0, - any.cyclotomic ==1.1.1, - any.czipwith ==1.0.1.3, - any.d10 ==0.2.1.6, - any.data-accessor ==0.2.3, - any.data-accessor-mtl ==0.2.0.4, - any.data-accessor-template ==0.2.1.16, - any.data-accessor-transformers ==0.2.1.7, - any.data-ascii ==1.0.0.2, - any.data-binary-ieee754 ==0.4.4, - any.data-bword ==0.1.0.1, - any.data-checked ==0.3, - any.data-clist ==0.1.2.3, - any.data-compat ==0.1.0.2, - any.data-default ==0.7.1.1, - any.data-default-class ==0.1.2.0, - any.data-default-instances-containers ==0.0.1, - any.data-default-instances-dlist ==0.0.1, - any.data-default-instances-old-locale ==0.0.1, - any.data-diverse ==4.7.0.0, - any.data-dword ==0.3.2, - any.data-endian ==0.1.1, - any.data-fix ==0.3.0, - any.data-forest ==0.1.0.8, - any.data-has ==0.3.0.0, - any.data-interval ==2.0.1, - any.data-inttrie ==0.1.4, - any.data-lens-light ==0.1.2.2, - any.data-memocombinators ==0.5.1, - any.data-msgpack ==0.0.13, - any.data-msgpack-types ==0.0.3, - any.data-or ==1.0.0.5, - any.data-ordlist ==0.4.7.0, - any.data-ref ==0.0.2, - any.data-reify ==0.6.1, - any.data-serializer ==0.3.4.1, - any.data-textual ==0.3.0.3, - any.datadog ==0.2.5.0, - any.dataurl ==0.1.0.0, - any.dbus ==1.2.16, - any.dbus-hslogger ==0.1.0.1, - any.debian ==4.0.2, - any.debian-build ==0.10.2.0, - any.debug-trace-var ==0.2.0, - any.dec ==0.0.3, - any.declarative ==0.5.3, - any.deepseq-generics ==0.2.0.0, - any.deepseq-instances ==0.1.0.1, - any.deferred-folds ==0.9.10.1, - any.dejafu ==2.4.0.0, - any.dense-linear-algebra ==0.1.0.0, - any.depq ==0.4.1.0, - any.deque ==0.4.3, - any.deriveJsonNoPrefix ==0.1.0.1, - any.deriving-aeson ==0.2.6, - any.deriving-compat ==0.5.9, - any.derulo ==1.0.9, - any.dhall ==1.33.1, - any.dhall-bash ==1.0.31, - any.dhall-json ==1.7.0, - any.dhall-lsp-server ==1.0.8, - any.dhall-yaml ==1.2.2, - any.di-core ==1.0.4, - any.di-monad ==1.3.1, - any.diagrams-solve ==0.1.2, - any.dialogflow-fulfillment ==0.1.1.3, - any.dictionary-sharing ==0.1.0.0, - any.digest ==0.0.1.2, - any.digits ==0.3.1, - any.dimensional ==1.3, - any.direct-sqlite ==2.3.26, - any.directory-tree ==0.12.1, - any.discount ==0.1.1, - any.disk-free-space ==0.1.0.1, - any.distributed-closure ==0.4.2.0, - any.distribution-nixpkgs ==1.3.1, - any.distribution-opensuse ==1.1.1, - any.distributive ==0.6.2, - any.dl-fedora ==0.7.5, - any.dlist ==0.8.0.8, - any.dlist-instances ==0.1.1.1, - any.dlist-nonempty ==0.1.1, - any.dns ==4.0.1, - any.do-list ==1.0.1, - any.do-notation ==0.1.0.2, - any.dockerfile ==0.2.0, - any.doclayout ==0.3, - any.doctemplates ==0.8.2, - any.doctest ==0.16.3, - any.doctest-discover ==0.2.0.0, - any.doctest-exitcode-stdio ==0.0, - any.doctest-lib ==0.1, - any.doldol ==0.4.1.2, - any.dotenv ==0.8.0.7, - any.dotgen ==0.4.3, - any.dotnet-timespan ==0.0.1.0, - any.double-conversion ==2.0.2.0, - any.download ==0.3.2.7, - any.drinkery ==0.4, - any.dsp ==0.2.5.1, - any.dual ==0.1.1.1, - any.dublincore-xml-conduit ==0.1.0.2, - any.dunai ==0.7.0, - any.duration ==0.1.0.0, - any.dvorak ==0.1.0.0, - any.dynamic-state ==0.3.1, - any.dyre ==0.8.12, - any.eap ==0.9.0.2, - any.earcut ==0.1.0.4, - any.easy-file ==0.2.2, - any.echo ==0.1.3, - any.ecstasy ==0.2.1.0, - any.ed25519 ==0.0.5.0, - any.edit-distance ==0.2.2.1, - any.edit-distance-vector ==1.0.0.4, - any.editor-open ==0.6.0.0, - any.egison ==4.0.3, - any.egison-pattern-src ==0.2.1.0, - any.egison-pattern-src-th-mode ==0.2.1.1, - any.either ==5.0.1.1, - any.either-both ==0.1.1.1, - any.either-unwrap ==1.1, - any.ekg ==0.4.0.15, - any.ekg-core ==0.1.1.7, - any.ekg-json ==0.1.0.6, - any.ekg-statsd ==0.2.5.0, - any.elerea ==2.9.0, - any.elf ==0.30, - any.eliminators ==0.7, - any.elm-bridge ==0.6.1, - any.elm-core-sources ==1.0.0, - any.elm-export ==0.6.0.1, - any.elm2nix ==0.2, - any.elynx ==0.4.0, - any.elynx-markov ==0.4.0, - any.elynx-nexus ==0.4.0, - any.elynx-seq ==0.4.0, - any.elynx-tools ==0.4.0, - any.elynx-tree ==0.4.0, - any.email-validate ==2.3.2.13, - any.emojis ==0.1, - any.enclosed-exceptions ==1.0.3, - any.entropy ==0.4.1.6, - any.enum-subset-generate ==0.1.0.0, - any.enummapset ==0.6.0.3, - any.enumset ==0.0.5, - any.envelope ==0.2.2.0, - any.envy ==2.1.0.0, - any.epub-metadata ==4.5, - any.eq ==4.2, - any.equal-files ==0.0.5.3, - any.equational-reasoning ==0.6.0.3, - any.erf ==2.0.0.0, - any.errors ==2.3.0, - any.errors-ext ==0.4.2, - any.ersatz ==0.4.8, - any.essence-of-live-coding ==0.2.4, - any.essence-of-live-coding-gloss ==0.2.4, - any.essence-of-live-coding-pulse ==0.2.4, - any.essence-of-live-coding-quickcheck ==0.2.4, - any.etc ==0.4.1.0, - any.event-list ==0.1.2, - any.eventful-core ==0.2.0, - any.eventful-test-helpers ==0.2.0, - any.eventstore ==1.4.1, - any.every ==0.0.1, - any.exact-combinatorics ==0.2.0.9, - any.exact-pi ==0.5.0.1, - any.exception-mtl ==0.4.0.1, - any.exception-transformers ==0.4.0.9, - any.exceptions ==0.10.4, - any.executable-path ==0.0.3.1, - any.exinst ==0.8, - any.exit-codes ==1.0.0, - any.exomizer ==1.0.0, - any.exp-pairs ==0.2.0.0, - any.expiring-cache-map ==0.0.6.1, - any.explicit-exception ==0.1.10, - any.express ==0.1.3, - any.extended-reals ==0.2.4.0, - any.extensible-effects ==5.0.0.1, - any.extensible-exceptions ==0.1.1.4, - any.extra ==1.7.8, - any.extractable-singleton ==0.0.1, - any.extrapolate ==0.4.2, - any.fail ==4.9.0.0, - any.failable ==1.2.4.0, - any.fakedata ==0.7.1, - any.fakedata-parser ==0.1.0.0, - any.fast-digits ==0.3.0.0, - any.fast-logger ==3.0.2, - any.fast-math ==1.0.2, - any.fb ==2.1.1, - any.feature-flags ==0.1.0.1, - any.fedora-dists ==1.1.2, - any.fedora-haskell-tools ==0.9, - any.feed ==1.3.0.1, - any.fft ==0.1.8.6, - any.fgl ==5.7.0.3, - any.file-embed ==0.0.13.0, - any.file-embed-lzma ==0, - any.file-modules ==0.1.2.4, - any.file-path-th ==0.1.0.0, - any.filelock ==0.1.1.5, - any.filemanip ==0.3.6.3, - any.filepattern ==0.1.2, - any.fileplow ==0.1.0.0, - any.filtrable ==0.1.4.0, - any.fin ==0.1.1, - any.fingertree ==0.1.4.2, - any.finite-typelits ==0.1.4.2, - any.first-class-families ==0.8.0.0, - any.first-class-patterns ==0.3.2.5, - any.fitspec ==0.4.8, - any.fixed ==0.3, - any.fixed-length ==0.2.2, - any.fixed-vector ==1.2.0.0, - any.fixed-vector-hetero ==0.6.0.0, - any.flac ==0.2.0, - any.flac-picture ==0.1.2, - any.flags-applicative ==0.1.0.2, - any.flat ==0.4.4, - any.flat-mcmc ==1.5.1, - any.flexible-defaults ==0.0.3, - any.floatshow ==0.2.4, - any.flow ==1.0.21, - any.flush-queue ==1.0.0, - any.fmlist ==0.9.4, - any.fmt ==0.6.1.2, - any.fn ==0.3.0.2, - any.focus ==1.0.1.3, - any.focuslist ==0.1.0.2, - any.fold-debounce ==0.2.0.9, - any.foldable1 ==0.1.0.0, - any.foldl ==1.4.9, - any.folds ==0.7.5, - any.follow-file ==0.0.3, - any.foreign-store ==0.2, - any.forkable-monad ==0.2.0.3, - any.forma ==1.1.3, - any.format-numbers ==0.1.0.1, - any.formatting ==6.3.7, - any.foundation ==0.0.25, - any.free ==5.1.3, - any.free-categories ==0.2.0.0, - any.free-vl ==0.1.4, - any.freenect ==1.2.1, - any.freer-simple ==1.2.1.1, - any.freetype2 ==0.2.0, - any.friendly-time ==0.4.1, - any.from-sum ==0.2.3.0, - any.frontmatter ==0.1.0.2, - any.fsnotify ==0.3.0.1, - any.fsnotify-conduit ==0.1.1.1, - any.ftp-client ==0.5.1.4, - any.ftp-client-conduit ==0.5.0.5, - any.funcmp ==1.9, - any.function-builder ==0.3.0.1, - functor-classes-compat +containers, - any.functor-classes-compat ==1, - any.fused-effects ==1.1.0.0, - any.fused-effects-th ==0.1.0.2, - any.fusion-plugin ==0.2.1, - any.fusion-plugin-types ==0.1.0, - any.fuzzcheck ==0.1.1, - any.fuzzy ==0.1.0.0, - any.fuzzy-dates ==0.1.1.2, - any.fuzzy-time ==0.1.0.0, - any.fuzzyset ==0.2.0, - any.gauge ==0.2.5, - any.gd ==3000.7.3, - any.gdp ==0.0.3.0, - any.general-games ==1.1.1, - any.generic-arbitrary ==0.1.0, - any.generic-constraints ==1.1.1.1, - any.generic-data ==0.9.1.0, - any.generic-deriving ==1.13.1, - any.generic-lens ==2.0.0.0, - any.generic-lens-core ==2.0.0.0, - any.generic-monoid ==0.1.0.1, - any.generic-optics ==2.0.0.0, - any.generic-random ==1.3.0.1, - any.generics-sop ==0.5.1.0, - any.generics-sop-lens ==0.2.0.1, - any.genvalidity ==0.11.0.0, - any.genvalidity-aeson ==0.3.0.0, - any.genvalidity-bytestring ==0.6.0.0, - any.genvalidity-containers ==0.9.0.0, - any.genvalidity-criterion ==0.2.0.0, - any.genvalidity-hspec ==0.7.0.4, - any.genvalidity-hspec-aeson ==0.3.1.1, - any.genvalidity-hspec-binary ==0.2.0.4, - any.genvalidity-hspec-cereal ==0.2.0.4, - any.genvalidity-hspec-hashable ==0.2.0.5, - any.genvalidity-hspec-optics ==0.1.1.2, - any.genvalidity-hspec-persistent ==0.0.0.1, - any.genvalidity-mergeful ==0.2.0.0, - any.genvalidity-mergeless ==0.2.0.0, - any.genvalidity-path ==0.3.0.4, - any.genvalidity-property ==0.5.0.1, - any.genvalidity-scientific ==0.2.1.1, - any.genvalidity-text ==0.7.0.2, - any.genvalidity-time ==0.3.0.0, - any.genvalidity-typed-uuid ==0.0.0.2, - any.genvalidity-unordered-containers ==0.3.0.1, - any.genvalidity-uuid ==0.1.0.4, - any.genvalidity-vector ==0.3.0.1, - any.geojson ==4.0.2, - any.getopt-generics ==0.13.0.4, - any.ghc-byteorder ==4.11.0.0.10, - any.ghc-check ==0.5.0.1, - any.ghc-clippy-plugin ==0.0.0.1, - any.ghc-core ==0.5.6, - any.ghc-events ==0.13.0, - any.ghc-exactprint ==0.6.3.2, - any.ghc-lib ==8.10.2.20200916, - any.ghc-lib-parser ==8.10.2.20200916, - any.ghc-lib-parser-ex ==8.10.0.16, - any.ghc-parser ==0.2.2.0, - any.ghc-paths ==0.1.0.12, - any.ghc-prof ==1.4.1.7, - any.ghc-source-gen ==0.4.0.0, - any.ghc-syntax-highlighter ==0.0.6.0, - any.ghc-tcplugins-extra ==0.4, - any.ghc-trace-events ==0.1.2.1, - any.ghc-typelits-extra ==0.4, - any.ghc-typelits-knownnat ==0.7.3, - any.ghc-typelits-natnormalise ==0.7.2, - any.ghc-typelits-presburger ==0.3.0.1, - any.ghci-hexcalc ==0.1.1.0, - any.ghcid ==0.8.7, - any.ghcjs-codemirror ==0.0.0.2, - any.ghost-buster ==0.1.1.0, - any.gi-atk ==2.0.22, - any.gi-cairo ==1.0.24, - any.gi-cairo-connector ==0.1.0, - any.gi-cairo-render ==0.1.0, - any.gi-dbusmenu ==0.4.8, - any.gi-dbusmenugtk3 ==0.4.9, - any.gi-gdk ==3.0.23, - any.gi-gdkpixbuf ==2.0.24, - any.gi-gdkx11 ==3.0.10, - any.gi-gio ==2.0.27, - any.gi-glib ==2.0.24, - any.gi-gobject ==2.0.24, - any.gi-graphene ==1.0.2, - any.gi-gtk ==3.0.36, - any.gi-gtk-hs ==0.3.9, - any.gi-harfbuzz ==0.0.3, - any.gi-pango ==1.0.23, - any.gi-xlib ==2.0.9, - any.ginger ==0.10.1.0, - any.gingersnap ==0.3.1.0, - any.git-embed ==0.1.0, - any.githash ==0.1.4.0, - any.github-release ==1.3.3, - any.github-rest ==1.0.3, - any.github-types ==0.2.1, - any.github-webhooks ==0.15.0, - any.gitlab-haskell ==0.2.3, - any.gitrev ==1.3.1, - any.gl ==0.9, - any.glabrous ==2.0.2, - any.gloss ==1.13.1.2, - any.gloss-rendering ==1.13.1.1, - any.gluturtle ==0.0.58.1, - any.gnuplot ==0.5.6.1, - any.google-isbn ==1.0.3, - any.gothic ==0.1.5, - any.gpolyline ==0.1.0.1, - any.graph-core ==0.3.0.0, - any.graph-wrapper ==0.2.6.0, - any.graphite ==0.10.0.1, - any.graphql-client ==1.1.0, - any.graphs ==0.7.1, - any.graphviz ==2999.20.1.0, - any.gravatar ==0.8.0, - any.groom ==0.1.2.1, - any.group-by-date ==0.1.0.3, - any.groups ==0.5, - any.gtk-sni-tray ==0.1.6.0, - any.gtk-strut ==0.1.3.0, - any.guarded-allocation ==0.0.1, - any.hOpenPGP ==2.9.4, - any.hackage-db ==2.1.0, - any.hackage-security ==0.6.0.1, - any.haddock-library ==1.9.0, - any.hadolint ==1.18.0, - any.hadoop-streaming ==0.2.0.3, - any.half ==0.3, - any.hall-symbols ==0.1.0.6, - any.hamtsolo ==1.0.3, - any.hapistrano ==0.4.1.2, - any.happstack-server ==7.6.1, - any.happy ==1.20.0, - any.hashable ==1.3.0.0, - any.hashable-time ==0.2.0.2, - any.hashids ==1.0.2.4, - any.hashing ==0.1.0.1, - any.hashmap ==1.3.3, - any.hashtables ==1.2.4.1, - any.haskeline ==0.8.1.0, - any.haskell-gi ==0.24.5, - any.haskell-gi-base ==0.24.3, - any.haskell-gi-overloading ==1.0, - any.haskell-import-graph ==1.0.4, - any.haskell-lexer ==1.1, - any.haskell-lsp ==0.22.0.0, - any.haskell-lsp-types ==0.22.0.0, - any.haskell-names ==0.9.9, - any.haskell-src-exts ==1.23.1, - any.haskell-src-exts-util ==0.2.5, - any.haskell-src-meta ==0.8.5, - any.haskey-btree ==0.3.0.1, - any.hasql ==1.4.4.2, - any.hasql-notifications ==0.1.0.0, - any.hasql-optparse-applicative ==0.3.0.6, - any.hasql-pool ==0.5.2, - any.hasql-queue ==1.2.0.2, - any.hasql-transaction ==1.0.0.1, - any.hasty-hamiltonian ==1.3.3, - any.haxr ==3000.11.4.1, - any.hdaemonize ==0.5.6, - any.headroom ==0.3.1.0, - any.heap ==1.0.4, - any.heaps ==0.3.6.1, - any.hebrew-time ==0.1.2, - any.hedgehog ==1.0.3, - any.hedgehog-classes ==0.2.5.1, - any.hedgehog-corpus ==0.2.0, - any.hedgehog-fakedata ==0.0.1.3, - any.hedgehog-fn ==1.0, - any.hedgehog-quickcheck ==0.1.1, - any.hedis ==0.12.14, - any.here ==1.2.13, - any.heredoc ==0.2.0.0, - any.hexml ==0.3.4, - any.hexml-lens ==0.2.1, - any.hexpat ==0.20.13, - any.hexstring ==0.11.1, - any.hformat ==0.3.3.1, - any.hfsevents ==0.1.6, - any.hgeometry ==0.11.0.0, - any.hgeometry-combinatorial ==0.11.0.0, - any.hgrev ==0.2.6, - any.hi-file-parser ==0.1.0.0, - any.hidapi ==0.1.5, - any.hie-bios ==0.7.1, - any.higher-leveldb ==0.6.0.0, - any.highlighting-kate ==0.6.4, - any.hinfo ==0.0.3.0, - any.hinotify ==0.4, - any.hint ==0.9.0.3, - any.hjsmin ==0.2.0.4, - any.hkd-default ==1.1.0.0, - any.hkgr ==0.2.6.1, - any.hledger ==1.19.1, - any.hledger-iadd ==1.3.12, - any.hledger-interest ==1.6.0, - any.hledger-lib ==1.19.1, - any.hledger-stockquotes ==0.1.0.0, - any.hledger-ui ==1.19.1, - any.hledger-web ==1.19.1, - any.hlibcpuid ==0.2.0, - any.hlibgit2 ==0.18.0.16, - any.hlibsass ==0.1.10.1, - any.hlint ==3.2, - any.hmatrix ==0.20.0.0, - any.hmatrix-gsl ==0.19.0.1, - any.hmatrix-gsl-stats ==0.4.1.8, - any.hmatrix-morpheus ==0.1.1.2, - any.hmatrix-vector-sized ==0.1.3.0, - any.hmm-lapack ==0.4, - any.hmpfr ==0.4.4, - any.hnix-store-core ==0.2.0.0, - any.hnock ==0.4.0, - any.hoauth2 ==1.15.0, - any.hoogle ==5.0.18, - any.hopenpgp-tools ==0.23.1, - any.hopenssl ==2.2.4, - any.hopfli ==0.2.2.1, - any.hosc ==0.18.1, - any.hostname ==1.0, - any.hostname-validate ==1.0.0, - any.hourglass ==0.2.12, - any.hourglass-orphans ==0.1.0.0, - any.hp2pretty ==0.9, - any.hpack ==0.34.2, - any.hpack-dhall ==0.5.2, - any.hpc-codecov ==0.2.0.0, - any.hpc-lcov ==1.0.1, - any.hruby ==0.3.8, - any.hs-GeoIP ==0.3, - any.hs-bibutils ==6.10.0.0, - any.hs-functors ==0.1.7.1, - any.hs-php-session ==0.0.9.3, - any.hsass ==0.8.0, - any.hsc2hs ==0.68.7, - any.hscolour ==1.24.4, - any.hsdns ==1.8, - any.hsebaysdk ==0.4.1.0, - any.hsemail ==2.2.0, - any.hsini ==0.5.1.2, - any.hsinstall ==2.6, - any.hslogger ==1.3.1.0, - any.hslua ==1.2.0, - any.hslua-aeson ==1.0.3, - any.hslua-module-doclayout ==0.2.0, - any.hslua-module-system ==0.2.2, - any.hslua-module-text ==0.3.0, - any.hsp ==0.10.0, - any.hspec ==2.7.4, - any.hspec-attoparsec ==0.1.0.2, - any.hspec-checkers ==0.1.0.2, - any.hspec-contrib ==0.5.1, - any.hspec-core ==2.7.4, - any.hspec-discover ==2.7.4, - any.hspec-expectations ==0.8.2, - any.hspec-expectations-lifted ==0.10.0, - any.hspec-expectations-pretty-diff ==0.7.2.5, - any.hspec-golden ==0.1.0.3, - any.hspec-golden-aeson ==0.7.0.0, - any.hspec-hedgehog ==0.0.1.2, - any.hspec-leancheck ==0.0.4, - any.hspec-megaparsec ==2.1.0, - any.hspec-meta ==2.6.0, - any.hspec-parsec ==0, - any.hspec-smallcheck ==0.5.2, - any.hspec-tables ==0.0.1, - any.hspec-wai ==0.10.1, - any.hspec-wai-json ==0.10.1, - any.hsshellscript ==3.4.5, - any.hsyslog ==5.0.2, - any.htaglib ==1.2.0, - any.html ==1.0.1.2, - any.html-conduit ==1.3.2.1, - any.html-entities ==1.1.4.3, - any.html-entity-map ==0.1.0.0, - any.htoml ==1.0.0.3, - any.http-api-data ==0.4.1.1, - any.http-client ==0.6.4.1, - any.http-client-openssl ==0.3.1.0, - any.http-client-overrides ==0.1.1.0, - any.http-client-tls ==0.3.5.3, - any.http-common ==0.8.2.1, - any.http-conduit ==2.3.7.3, - any.http-date ==0.0.9, - any.http-directory ==0.1.8, - any.http-download ==0.2.0.0, - any.http-link-header ==1.0.3.1, - any.http-media ==0.8.0.0, - any.http-query ==0.1.0, - any.http-reverse-proxy ==0.6.0, - any.http-streams ==0.8.7.2, - any.http-types ==0.12.3, - any.http2 ==2.0.5, - any.httpd-shed ==0.4.1.1, - any.human-readable-duration ==0.2.1.4, - any.hunit-dejafu ==2.0.0.4, - any.hvect ==0.4.0.0, - any.hvega ==0.10.0.0, - any.hw-balancedparens ==0.4.1.0, - any.hw-bits ==0.7.2.1, - any.hw-conduit ==0.2.1.0, - any.hw-conduit-merges ==0.2.1.0, - any.hw-diagnostics ==0.0.1.0, - any.hw-excess ==0.2.3.0, - any.hw-fingertree ==0.1.2.0, - any.hw-fingertree-strict ==0.1.2.0, - any.hw-hedgehog ==0.1.1.0, - any.hw-hspec-hedgehog ==0.1.1.0, - any.hw-int ==0.0.2.0, - any.hw-ip ==2.4.2.0, - any.hw-json-simd ==0.1.1.0, - any.hw-kafka-client ==3.1.2, - any.hw-mquery ==0.2.1.0, - any.hw-parser ==0.1.1.0, - any.hw-prim ==0.6.3.0, - any.hw-rankselect-base ==0.3.4.1, - any.hw-streams ==0.0.1.0, - any.hw-string-parse ==0.0.0.4, - any.hweblib ==0.6.3, - hxt +network-uri, - any.hxt ==9.3.1.18, - any.hxt-charproperties ==9.4.0.0, - any.hxt-css ==0.1.0.3, - any.hxt-curl ==9.1.1.1, - any.hxt-expat ==9.1.1, - hxt-http +network-uri, - any.hxt-http ==9.1.5.2, - any.hxt-regex-xmlschema ==9.2.0.3, - any.hxt-tagsoup ==9.1.4, - any.hxt-unicode ==9.0.2.4, - any.hybrid-vectors ==0.2.2, - any.hyper ==0.1.0.3, - any.hyperloglog ==0.4.3, - any.hyphenation ==0.8, - any.iconv ==0.4.1.3, - any.identicon ==0.2.2, - any.ieee754 ==0.8.0, - any.if ==0.1.0.0, - any.iff ==0.0.6, - any.ihaskell ==0.10.1.2, - any.ihs ==0.1.0.3, - any.ilist ==0.4.0.1, - any.imagesize-conduit ==1.1, - any.immortal ==0.3, - any.immortal-queue ==0.1.0.1, - any.include-file ==0.1.0.4, - any.incremental-parser ==0.5, - any.indents ==0.5.0.1, - any.indexed ==0.1.3, - any.indexed-containers ==0.1.0.2, - any.indexed-list-literals ==0.2.1.3, - any.indexed-profunctors ==0.1, - any.infer-license ==0.2.0, - any.inflections ==0.4.0.6, - any.influxdb ==1.9.0, - any.ini ==0.4.1, - any.inj ==1.0, - any.inline-c ==0.9.1.2, - any.inline-c-cpp ==0.4.0.2, - any.inliterate ==0.1.0, - any.input-parsers ==0.1.0.1, - any.insert-ordered-containers ==0.2.3.1, - any.inspection-testing ==0.4.2.4, - any.instance-control ==0.1.2.0, - any.integer-logarithms ==1.0.3, - any.integer-roots ==1.0, - any.integration ==0.2.1, - any.intern ==0.9.2, - any.interpolate ==0.2.1, - any.interpolatedstring-perl6 ==1.0.2, - any.interpolation ==0.1.1.1, - any.interpolator ==1.1.0.2, - any.intervals ==0.9.1, - any.intro ==0.9.0.0, - any.intset-imperative ==0.1.0.0, - any.invariant ==0.5.3, - any.invertible ==0.2.0.7, - any.invertible-grammar ==0.1.3, - any.io-machine ==0.2.0.0, - any.io-manager ==0.1.0.3, - any.io-memoize ==1.1.1.0, - any.io-region ==0.1.1, - any.io-storage ==0.3, - any.io-streams ==1.5.2.0, - any.io-streams-haproxy ==1.0.1.0, - any.ip6addr ==1.0.1, - any.iproute ==1.7.9, - any.ipynb ==0.1.0.1, - any.ipython-kernel ==0.10.2.1, - any.irc ==0.6.1.0, - any.irc-client ==1.1.1.1, - any.irc-conduit ==0.3.0.4, - any.irc-ctcp ==0.1.3.0, - any.isbn ==1.1.0.1, - any.islink ==0.1.0.0, - any.iso3166-country-codes ==0.20140203.8, - any.iso639 ==0.1.0.3, - any.iso8601-time ==0.1.5, - any.it-has ==0.2.0.0, - any.iterable ==3.0, - any.ix-shapable ==0.1.0, - any.ixset-typed ==0.5, - any.ixset-typed-binary-instance ==0.1.0.2, - any.ixset-typed-conversions ==0.1.2.0, - any.ixset-typed-hashable-instance ==0.1.0.2, - any.jack ==0.7.1.4, - any.jailbreak-cabal ==1.3.5, - any.jira-wiki-markup ==1.3.2, - any.jose ==0.8.3.1, - any.jose-jwt ==0.8.0, - any.js-dgtable ==0.5.2, - any.js-flot ==0.8.3, - any.js-jquery ==3.3.1, - any.json-feed ==1.0.11, - any.json-rpc ==1.0.3, - any.json-rpc-generic ==0.2.1.5, - any.json-stream ==0.4.2.4, - any.jsonpath ==0.2.0.0, - any.junit-xml ==0.1.0.1, - any.justified-containers ==0.3.0.0, - any.jwt ==0.10.0, - any.kan-extensions ==5.2, - any.kanji ==3.4.1, - any.katip ==0.8.5.0, - any.kawhi ==0.3.0, - any.kazura-queue ==0.1.0.4, - any.kdt ==0.2.4, - any.keycode ==0.2.2, - any.keys ==3.12.3, - any.kind-apply ==0.3.2.0, - any.kind-generics ==0.4.1.0, - any.kind-generics-th ==0.2.2.0, - any.kmeans ==0.1.3, - any.koofr-client ==1.0.0.3, - any.krank ==0.2.2, - any.kubernetes-webhook-haskell ==0.2.0.3, - any.l10n ==0.1.0.1, - any.labels ==0.3.3, - any.lame ==0.2.0, - any.language-avro ==0.1.3.1, - any.language-bash ==0.9.2, - any.language-c ==0.8.3, - any.language-c-quote ==0.12.2.1, - any.language-docker ==9.1.1, - any.language-java ==0.2.9, - any.language-javascript ==0.7.1.0, - any.language-nix ==2.2.0, - any.language-protobuf ==1.0.1, - any.language-python ==0.5.8, - any.lapack ==0.3.2, - any.lapack-carray ==0.0.3, - any.lapack-comfort-array ==0.0.0.1, - any.lapack-ffi ==0.0.2, - any.lapack-ffi-tools ==0.1.2.1, - any.largeword ==1.2.5, - any.latex ==0.1.0.4, - any.lattices ==2.0.2, - any.lawful ==0.1.0.0, - any.lazy-csv ==0.5.1, - any.lazyio ==0.1.0.4, - any.lca ==0.3.1, - any.leancheck ==0.9.3, - any.leancheck-instances ==0.0.4, - any.leapseconds-announced ==2017.1.0.1, - any.learn-physics ==0.6.5, - any.lens ==4.19.2, - any.lens-action ==0.2.4, - any.lens-aeson ==1.1, - any.lens-datetime ==0.3, - any.lens-family ==2.0.0, - any.lens-family-core ==2.0.0, - any.lens-family-th ==0.5.1.0, - any.lens-misc ==0.0.2.0, - any.lens-process ==0.3.0.2, - any.lens-properties ==4.11.1, - any.lens-regex ==0.1.1, - any.lenz ==0.4.2.0, - any.leveldb-haskell ==0.6.5, - any.libffi ==0.1, - any.libgit ==0.3.1, - any.libgraph ==1.14, - any.libmpd ==0.9.1.0, - any.libyaml ==0.1.2, - any.life-sync ==1.1.1.0, - any.lift-generics ==0.1.3, - any.lifted-async ==0.10.1.2, - any.lifted-base ==0.2.3.12, - any.line ==4.0.1, - any.linear ==1.21.1, - any.linear-circuit ==0.1.0.2, - any.linenoise ==0.3.2, - any.linux-file-extents ==0.2.0.0, - any.linux-namespaces ==0.1.3.0, - any.liquid-fixpoint ==0.8.10.2, - any.list-predicate ==0.1.0.1, - any.list-singleton ==1.0.0.4, - any.list-t ==1.0.4, - any.listsafe ==0.1.0.1, - any.little-logger ==0.1.0, - any.little-rio ==0.2.1, - any.llvm-hs ==9.0.1, - any.llvm-hs-pure ==9.0.0, - any.lmdb ==0.2.5, - any.load-env ==0.2.1.0, - any.loc ==0.1.3.8, - any.locators ==0.3.0.3, - any.loch-th ==0.2.2, - any.lockfree-queue ==0.2.3.1, - any.log-domain ==0.13, - any.logfloat ==0.13.3.3, - any.logging ==3.0.5, - any.logging-facade ==0.3.0, - any.logging-facade-syslog ==1, - any.logict ==0.7.0.3, - any.loop ==0.3.0, - any.lrucache ==1.2.0.1, - any.lrucaching ==0.3.3, - any.lsp-test ==0.11.0.6, - any.lucid ==2.9.12, - any.lucid-cdn ==0.2.0.1, - any.lucid-extras ==0.2.2, - any.lukko ==0.1.1.2, - any.lz4-frame-conduit ==0.1.0.1, - any.lzma ==0.0.0.3, - any.lzma-conduit ==1.2.1, - any.machines ==0.7, - any.magic ==1.1, - any.magico ==0.0.2.1, - any.main-tester ==0.2.0.1, - any.mainland-pretty ==0.7.0.1, - any.makefile ==1.1.0.0, - any.managed ==1.0.8, - any.markdown ==0.1.17.4, - any.markdown-unlit ==0.5.0, - any.markov-chain ==0.0.3.4, - any.massiv ==0.5.4.0, - any.massiv-io ==0.3.0.1, - any.massiv-test ==0.1.4, - any.math-extras ==0.1.1.0, - any.math-functions ==0.3.4.1, - any.mathexpr ==0.3.0.0, - any.matplotlib ==0.7.5, - any.matrices ==0.5.0, - any.matrix ==0.3.6.1, - any.matrix-as-xyz ==0.1.2.2, - any.matrix-market-attoparsec ==0.1.1.3, - any.matrix-static ==0.3, - any.maximal-cliques ==0.1.1, - any.mbox ==0.3.4, - any.mbox-utility ==0.0.3.1, - any.mcmc ==0.2.3, - any.mcmc-types ==1.0.3, - any.med-module ==0.1.2.1, - any.medea ==1.2.0, - any.median-stream ==0.7.0.0, - any.megaparsec ==8.0.0, - any.megaparsec-tests ==8.0.0, - any.membrain ==0.0.0.2, - any.memory ==0.15.0, - any.mercury-api ==0.1.0.2, - any.mergeful ==0.2.0.0, - any.mergeless ==0.3.0.0, - mersenne-random-pure64 -small_base, - any.mersenne-random-pure64 ==0.2.2.0, - any.messagepack ==0.5.4, - any.metrics ==0.4.1.1, - any.mfsolve ==0.3.2.0, - any.microlens ==0.4.11.2, - any.microlens-aeson ==2.3.1, - any.microlens-contra ==0.1.0.2, - any.microlens-ghc ==0.4.12, - any.microlens-mtl ==0.2.0.1, - any.microlens-platform ==0.4.1, - any.microlens-process ==0.2.0.2, - any.microlens-th ==0.4.3.5, - any.microspec ==0.2.1.3, - any.microstache ==1.0.1.1, - any.midair ==0.2.0.1, - any.midi ==0.2.2.2, - any.mighty-metropolis ==2.0.0, - any.mime-mail ==0.5.0, - any.mime-mail-ses ==0.4.3, - any.mime-types ==0.1.0.9, - any.min-max-pqueue ==0.1.0.2, - any.mini-egison ==1.0.0, - any.minimal-configuration ==0.1.4, - any.minimorph ==0.3.0.0, - any.miniutter ==0.5.1.1, - mintty +win32-2-5-3, - any.mintty ==0.1.2, - any.missing-foreign ==0.1.1, - any.mixed-types-num ==0.4.0.2, - any.mltool ==0.2.0.1, - any.mmap ==0.5.9, - any.mmark ==0.0.7.2, - any.mmark-cli ==0.0.5.0, - any.mmark-ext ==0.2.1.2, - any.mmorph ==1.1.3, - any.mnist-idx ==0.1.2.8, - any.mockery ==0.3.5, - any.mod ==0.1.2.0, - any.model ==0.5, - any.modern-uri ==0.3.2.0, - any.modular ==0.1.0.8, - any.monad-control ==1.0.2.3, - any.monad-control-aligned ==0.0.1.1, - any.monad-coroutine ==0.9.0.4, - any.monad-extras ==0.6.0, - any.monad-journal ==0.8.1, - any.monad-logger ==0.3.35, - any.monad-logger-json ==0.1.0.0, - any.monad-logger-prefix ==0.1.11, - any.monad-loops ==0.4.3, - any.monad-memo ==0.5.3, - any.monad-metrics ==0.2.1.4, - any.monad-par ==0.3.5, - any.monad-par-extras ==0.3.3, - any.monad-parallel ==0.7.2.3, - any.monad-peel ==0.2.1.2, - any.monad-products ==4.0.1, - any.monad-resumption ==0.1.4.0, - any.monad-skeleton ==0.1.5, - any.monad-st ==0.2.4.1, - any.monad-time ==0.3.1.0, - any.monad-unlift ==0.2.0, - any.monad-unlift-ref ==0.2.1, - any.monadic-arrays ==0.2.2, - any.monadlist ==0.0.2, - any.monads-tf ==0.1.0.3, - mongoDB -_old-network, - any.mongoDB ==2.7.0.0, - any.mono-traversable ==1.0.15.1, - any.mono-traversable-instances ==0.1.1.0, - any.mono-traversable-keys ==0.1.0, - any.monoid-subclasses ==1.0.1, - any.monoid-transformer ==0.0.4, - any.more-containers ==0.2.2.0, - any.morpheus-graphql ==0.15.1, - any.morpheus-graphql-client ==0.15.1, - any.morpheus-graphql-core ==0.15.1, - any.mountpoints ==1.0.2, - any.mpi-hs ==0.7.2.0, - any.mpi-hs-binary ==0.1.1.0, - any.mpi-hs-cereal ==0.1.0.0, - any.mtl-compat ==0.2.2, - any.mtl-prelude ==2.0.3.1, - any.multi-containers ==0.1.1, - any.multiarg ==0.30.0.10, - any.multimap ==1.2.1, - any.multipart ==0.2.0, - any.multiset ==0.3.4.3, - any.multistate ==0.8.0.3, - any.murmur-hash ==0.1.0.9, - any.murmur3 ==1.0.4, - any.mustache ==2.3.1, - any.mutable-containers ==0.3.4, - any.mwc-probability ==2.3.1, - any.mwc-random ==0.14.0.0, - any.mx-state-codes ==1.0.0.0, - any.mysql ==0.1.7, - any.mysql-simple ==0.4.5, - any.n2o ==0.11.1, - any.nagios-check ==0.3.2, - any.names-th ==0.3.0.1, - any.nano-erl ==0.1.0.1, - any.nanospec ==0.2.2, - any.nats ==1.1.2, - any.natural-induction ==0.2.0.0, - any.natural-sort ==0.1.2, - any.natural-transformation ==0.4, - any.ndjson-conduit ==0.1.0.5, - any.neat-interpolation ==0.5.1.2, - any.netcode-io ==0.0.2, - any.netlib-carray ==0.1, - any.netlib-comfort-array ==0.0.0.1, - any.netlib-ffi ==0.1.1, - any.netpbm ==1.0.3, - any.nettle ==0.3.0, - any.netwire ==5.0.3, - any.netwire-input ==0.0.7, - any.netwire-input-glfw ==0.0.11, - any.network ==3.1.1.1, - any.network-bsd ==2.8.1.0, - any.network-byte-order ==0.1.6, - any.network-conduit-tls ==1.3.2, - any.network-info ==0.2.0.10, - any.network-ip ==0.3.0.3, - any.network-messagepack-rpc ==0.1.2.0, - any.network-messagepack-rpc-websocket ==0.1.1.1, - any.network-simple ==0.4.5, - any.network-simple-tls ==0.4, - any.network-transport ==0.5.4, - any.network-transport-composed ==0.2.1, - any.network-uri ==2.6.3.0, - any.newtype ==0.2.2.0, - any.newtype-generics ==0.5.4, - any.nicify-lib ==1.0.1, - nix-paths +allow-relative-paths, - any.nix-paths ==1.0.1, - any.no-value ==1.0.0.0, - any.non-empty ==0.3.2, - any.non-empty-sequence ==0.2.0.4, - any.non-negative ==0.1.2, - any.nonce ==1.0.7, - any.nondeterminism ==1.4, - any.nonempty-containers ==0.3.4.1, - any.nonempty-vector ==0.2.0.2, - any.nonemptymap ==0.0.6.0, - any.not-gloss ==0.7.7.0, - any.nowdoc ==0.1.1.0, - any.nqe ==0.6.3, - any.nsis ==0.3.3, - any.numbers ==3000.2.0.2, - any.numeric-extras ==0.1, - any.numeric-prelude ==0.4.3.2, - any.numhask ==0.6.0.2, - any.numtype-dk ==0.5.0.2, - any.nuxeo ==0.3.2, - any.nvim-hs ==2.1.0.4, - any.nvim-hs-contrib ==2.0.0.0, - any.nvim-hs-ghcid ==2.0.0.0, - any.o-clock ==1.2.0, - any.oauthenticated ==0.2.1.0, - any.odbc ==0.2.2, - any.oeis2 ==1.0.4, - any.ofx ==0.4.4.0, - any.old-locale ==1.0.0.7, - any.old-time ==1.1.0.3, - any.once ==0.4, - any.one-liner ==1.0, - any.one-liner-instances ==0.1.2.1, - any.oo-prototypes ==0.1.0.0, - any.opaleye ==0.7.1.0, - any.open-browser ==0.2.1.0, - any.openexr-write ==0.1.0.2, - any.openpgp-asciiarmor ==0.1.2, - any.opensource ==0.1.1.0, - any.openssl-streams ==1.2.3.0, - any.opentelemetry ==0.6.1, - any.opentelemetry-extra ==0.6.1, - any.opentelemetry-lightstep ==0.6.1, - any.opentelemetry-wai ==0.6.1, - any.operational ==0.2.3.5, - any.operational-class ==0.3.0.0, - any.optics ==0.3, - any.optics-core ==0.3.0.1, - any.optics-extra ==0.3, - any.optics-th ==0.3.0.2, - any.optics-vl ==0.2.1, - any.optional-args ==1.0.2, - any.options ==1.2.1.1, - any.optparse-applicative ==0.15.1.0, - any.optparse-generic ==1.3.1, - any.optparse-simple ==0.1.1.3, - any.optparse-text ==0.1.1.0, - any.ordered-containers ==0.2.2, - any.ormolu ==0.1.3.0, - any.overhang ==1.0.0, - any.packcheck ==0.5.1, - any.packdeps ==0.6.0.0, - any.pager ==0.1.1.0, - any.pagination ==0.2.1, - any.pagure-cli ==0.2, - any.pandoc-types ==1.22, - any.parallel ==3.2.2.0, - any.parallel-io ==0.3.3, - any.paripari ==0.7.0.0, - any.parseargs ==0.2.0.9, - any.parsec-class ==1.0.0.0, - any.parsec-numbers ==0.1.0, - any.parsec-numeric ==0.1.0.0, - any.parser-combinators ==1.2.1, - any.parser-combinators-tests ==1.2.1, - any.parsers ==0.12.10, - any.partial-handler ==1.0.3, - any.partial-isomorphisms ==0.2.2.1, - any.partial-semigroup ==0.5.1.8, - any.password ==2.0.1.1, - any.password-instances ==2.0.0.1, - any.path ==0.7.0, - any.path-binary-instance ==0.1.0.1, - any.path-extensions ==0.1.1.0, - any.path-extra ==0.2.0, - any.path-io ==1.6.0, - any.path-like ==0.2.0.2, - any.path-pieces ==0.2.1, - any.path-text-utf8 ==0.0.1.6, - pathtype -old-time, - any.pathtype ==0.8.1.1, - any.pathwalk ==0.3.1.2, - any.pattern-arrows ==0.0.2, - any.pava ==0.1.0.0, - any.pcg-random ==0.1.3.6, - any.pcre-heavy ==1.0.0.2, - any.pcre-light ==0.4.1.0, - any.pcre-utils ==0.1.8.1.1, - any.pdfinfo ==1.5.4, - any.peano ==0.1.0.1, - any.pem ==0.2.4, - any.percent-format ==0.0.1, - any.perfect-hash-generator ==0.2.0.6, - any.perfect-vector-shuffle ==0.1.1.1, - any.persist ==0.1.1.5, - any.persistable-record ==0.6.0.5, - any.persistable-types-HDBC-pg ==0.0.3.5, - any.persistent ==2.10.5.2, - any.persistent-mysql ==2.10.2.3, - any.persistent-postgresql ==2.10.1.2, - any.persistent-qq ==2.9.2, - any.persistent-template ==2.8.2.3, - any.pg-harness-client ==0.6.0, - any.pg-transact ==0.3.1.1, - any.pgp-wordlist ==0.1.0.3, - any.phantom-state ==0.2.1.2, - any.pid1 ==0.1.2.0, - any.pipes ==4.3.14, - any.pipes-aeson ==0.4.1.8, - any.pipes-attoparsec ==0.5.1.5, - any.pipes-binary ==0.4.2, - any.pipes-bytestring ==2.1.6, - any.pipes-concurrency ==2.0.12, - any.pipes-csv ==1.4.3, - any.pipes-extras ==1.0.15, - any.pipes-fastx ==0.3.0.0, - any.pipes-group ==1.0.12, - any.pipes-http ==1.0.6, - any.pipes-network ==0.6.5, - any.pipes-network-tls ==0.4, - any.pipes-ordered-zip ==1.1.0, - any.pipes-parse ==3.0.8, - any.pipes-random ==1.0.0.5, - any.pipes-safe ==2.3.2, - any.pipes-wai ==3.2.0, - any.pkcs10 ==0.2.0.0, - any.pkgtreediff ==0.4, - any.placeholders ==0.1, - any.plaid ==0.1.0.4, - any.plotlyhs ==0.2.1, - any.pointed ==5.0.1, - any.pointedlist ==0.6.1, - any.pointless-fun ==1.1.0.6, - any.poll ==0.0.0.1, - any.poly ==0.4.0.0, - any.poly-arity ==0.1.0, - any.polynomials-bernstein ==1.1.2, - any.polyparse ==1.13, - any.polysemy ==1.3.0.0, - any.pooled-io ==0.0.2.2, - any.port-utils ==0.2.1.0, - any.posix-paths ==0.2.1.6, - any.possibly ==1.0.0.0, - any.post-mess-age ==0.2.1.0, - any.postgres-options ==0.2.0.0, - any.postgresql-binary ==0.12.3.1, - any.postgresql-libpq ==0.9.4.2, - any.postgresql-libpq-notify ==0.2.0.0, - any.postgresql-orm ==0.5.1, - any.postgresql-simple ==0.6.2, - any.postgresql-typed ==0.6.1.2, - any.postgrest ==7.0.1, - any.pptable ==0.3.0.0, - any.pqueue ==1.4.1.3, - any.prefix-units ==0.2.0, - any.prelude-compat ==0.0.0.2, - any.prelude-safeenum ==0.1.1.2, - any.pretty-class ==1.0.1.1, - any.pretty-hex ==1.1, - any.pretty-relative-time ==0.2.0.0, - any.pretty-show ==1.10, - any.pretty-simple ==3.3.0.0, - any.pretty-sop ==0.2.0.3, - any.pretty-terminal ==0.1.0.0, - any.prettyclass ==1.0.0.0, - any.prettyprinter ==1.6.2, - any.prettyprinter-ansi-terminal ==1.1.2, - any.prettyprinter-compat-annotated-wl-pprint ==1, - any.prettyprinter-compat-ansi-wl-pprint ==1.0.1, - any.prettyprinter-compat-wl-pprint ==1.0.0.1, - any.prettyprinter-convert-ansi-wl-pprint ==1.1.1, - any.primes ==0.2.1.0, - any.primitive ==0.7.1.0, - any.primitive-addr ==0.1.0.2, - any.primitive-unaligned ==0.1.1.1, - any.print-console-colors ==0.1.0.0, - any.probability ==0.2.7, - any.process-extras ==0.7.4, - any.product-isomorphic ==0.0.3.3, - any.product-profunctors ==0.11.0.1, - any.profiterole ==0.1, - any.profunctors ==5.5.2, - any.project-template ==0.2.1.0, - any.projectroot ==0.2.0.1, - any.prometheus ==2.2.2, - any.prometheus-client ==1.0.1, - any.prometheus-wai-middleware ==1.0.1.0, - any.promises ==0.3, - any.prompt ==0.1.1.2, - any.prospect ==0.1.0.0, - any.proto-lens ==0.7.0.0, - any.proto-lens-arbitrary ==0.1.2.9, - any.proto-lens-optparse ==0.1.1.7, - any.proto-lens-protobuf-types ==0.7.0.0, - any.proto-lens-protoc ==0.7.0.0, - any.proto-lens-runtime ==0.7.0.0, - any.proto-lens-setup ==0.4.0.4, - any.proto3-wire ==1.1.0, - any.protobuf ==0.2.1.3, - any.protobuf-simple ==0.1.1.0, - any.protocol-radius ==0.0.1.1, - any.protocol-radius-test ==0.1.0.1, - any.protolude ==0.3.0, - any.proxied ==0.3.1, - any.psqueues ==0.2.7.2, - any.publicsuffix ==0.20200526, - any.pulse-simple ==0.1.14, - any.pureMD5 ==2.1.3, - any.purescript-bridge ==0.14.0.0, - any.pushbullet-types ==0.4.1.0, - any.pusher-http-haskell ==2.0.0.1, - any.pvar ==0.2.0.0, - any.qchas ==1.1.0.1, - any.qm-interpolated-string ==0.3.0.0, - any.qrcode-core ==0.9.4, - any.qrcode-juicypixels ==0.8.2, - any.quadratic-irrational ==0.1.1, - any.quickcheck-arbitrary-adt ==0.3.1.0, - any.quickcheck-assertions ==0.3.0, - any.quickcheck-classes ==0.6.4.0, - any.quickcheck-classes-base ==0.6.1.0, - any.quickcheck-higherorder ==0.1.0.0, - any.quickcheck-instances ==0.3.23, - any.quickcheck-io ==0.2.0, - any.quickcheck-simple ==0.1.1.1, - any.quickcheck-special ==0.1.0.6, - any.quickcheck-text ==0.1.2.1, - any.quickcheck-transformer ==0.3.1.1, - any.quickcheck-unicode ==1.0.1.0, - any.quiet ==0.2, - any.radius ==0.6.1.0, - any.rainbow ==0.34.2.2, - any.rainbox ==0.26.0.0, - any.ral ==0.1, - any.rampart ==1.1.0.1, - any.ramus ==0.1.2, - any.rando ==0.0.0.4, - any.random ==1.1, - any.random-bytestring ==0.1.3.2, - any.random-fu ==0.2.7.4, - any.random-shuffle ==0.0.4, - any.random-source ==0.3.0.8, - any.random-tree ==0.6.0.5, - any.range ==0.3.0.2, - any.range-set-list ==0.1.3.1, - any.rank1dynamic ==0.4.0, - any.rank2classes ==1.4.0.1, - any.rasterific-svg ==0.3.3.2, - any.rate-limit ==1.4.2, - any.ratel ==1.0.12, - any.ratel-wai ==1.1.3, - any.rattle ==0.2, - any.raw-strings-qq ==1.1, - any.rawfilepath ==0.2.4, - any.rawstring-qm ==0.2.3.0, - any.rcu ==0.2.4, - any.rdf ==0.1.0.4, - any.rdtsc ==1.3.0.1, - any.re2 ==0.3, - any.read-editor ==0.1.0.2, - any.read-env-var ==1.0.0.0, - any.readable ==0.3.1, - any.reanimate ==1.0.0.0, - any.reanimate-svg ==0.11.0.0, - any.rebase ==1.6.1, - any.record-dot-preprocessor ==0.2.6, - any.record-hasfield ==1.0, - any.records-sop ==0.1.0.3, - any.recursion-schemes ==5.1.3, - any.reducers ==3.12.3, - any.ref-fd ==0.4.0.2, - any.ref-tf ==0.4.0.2, - any.refact ==0.3.0.2, - any.refined ==0.6.1, - any.reflection ==2.1.6, - any.reform ==0.2.7.4, - any.reform-blaze ==0.2.4.3, - any.reform-hamlet ==0.0.5.3, - any.reform-happstack ==0.2.5.3, - any.regex ==1.1.0.0, - any.regex-applicative ==0.3.4, - any.regex-applicative-text ==0.1.0.1, - any.regex-base ==0.94.0.0, - any.regex-compat ==0.95.2.0, - any.regex-compat-tdfa ==0.95.1.4, - any.regex-pcre ==0.95.0.0, - any.regex-pcre-builtin ==0.95.1.2.8.43, - any.regex-posix ==0.96.0.0, - any.regex-tdfa ==1.3.1.0, - any.regex-with-pcre ==1.1.0.0, - any.registry ==0.1.9.3, - any.reinterpret-cast ==0.1.0, - any.relapse ==1.0.0.0, - any.relational-query ==0.12.2.3, - any.relational-query-HDBC ==0.7.2.0, - any.relational-record ==0.2.2.0, - any.relational-schemas ==0.1.8.0, - any.reliable-io ==0.0.1, - any.relude ==0.7.0.0, - any.renderable ==0.2.0.1, - any.replace-attoparsec ==1.4.2.0, - any.replace-megaparsec ==1.4.3.0, - any.repline ==0.4.0.0, - any.req ==3.6.0, - any.req-conduit ==1.0.0, - any.rerebase ==1.6.1, - any.resistor-cube ==0.0.1.2, - any.resolv ==0.1.2.0, - any.resource-pool ==0.2.3.2, - any.resourcet ==1.2.4.2, - any.result ==0.2.6.0, - any.rethinkdb-client-driver ==0.0.25, - any.retry ==0.8.1.2, - any.rev-state ==0.1.2, - any.rfc1751 ==0.1.3, - any.rfc5051 ==0.2, - any.rhine ==0.7.0, - any.rhine-gloss ==0.7.0, - any.rigel-viz ==0.2.0.0, - any.rio ==0.1.19.0, - any.rio-orphans ==0.1.1.0, - any.rio-prettyprint ==0.1.1.0, - any.roc-id ==0.1.0.0, - any.rocksdb-haskell ==1.0.1, - any.rocksdb-haskell-jprupp ==2.1.3, - any.rocksdb-query ==0.4.2, - any.roles ==0.2.0.0, - any.rope-utf16-splay ==0.3.1.0, - any.rosezipper ==0.2, - any.rot13 ==0.2.0.1, - any.rpmbuild-order ==0.4.3.1, - any.runmemo ==1.0.0.1, - any.rvar ==0.2.0.6, - any.safe ==0.3.19, - any.safe-decimal ==0.2.0.0, - any.safe-exceptions ==0.1.7.1, - any.safe-foldable ==0.1.0.0, - any.safe-json ==1.1.1, - any.safe-money ==0.9, - any.safe-tensor ==0.2.1.0, - any.safecopy ==0.10.3, - any.safeio ==0.0.5.0, - any.salak ==0.3.6, - any.salak-yaml ==0.3.5.3, - any.saltine ==0.1.1.0, - any.salve ==1.0.10, - any.sample-frame ==0.0.3, - any.sample-frame-np ==0.0.4.1, - any.sampling ==0.3.5, - any.say ==0.1.0.1, - any.sbp ==2.6.3, - any.scalpel ==0.6.2, - any.scalpel-core ==0.6.2, - any.scanf ==0.1.0.0, - any.scanner ==0.3.1, - any.scheduler ==1.4.2.3, - any.scientific ==0.3.6.2, - any.scotty ==0.12, - any.scrypt ==0.5.0, - any.sdl2 ==2.5.2.0, - any.sdl2-gfx ==0.2, - any.sdl2-image ==2.0.0, - any.sdl2-mixer ==1.1.0, - any.sdl2-ttf ==2.1.1, - any.search-algorithms ==0.3.1, - any.secp256k1-haskell ==0.4.0, - any.securemem ==0.1.10, - any.selda ==0.5.1.0, - any.selda-json ==0.1.1.0, - any.selda-postgresql ==0.1.8.1, - any.selda-sqlite ==0.1.7.1, - any.selective ==0.4.1.1, - any.semialign ==1.1.0.1, - any.semialign-indexed ==1.1, - any.semialign-optics ==1.1, - any.semigroupoid-extras ==5, - any.semigroupoids ==5.3.4, - any.semigroups ==0.19.1, - any.semiring-simple ==1.0.0.1, - any.semirings ==0.5.4, - any.semver ==0.3.4, - any.sendfile ==0.7.11.1, - any.seqalign ==0.2.0.4, - any.seqid ==0.6.2, - any.seqid-streams ==0.7.2, - any.sequence-formats ==1.5.1.3, - any.sequenceTools ==1.4.0.5, - any.serf ==0.1.1.0, - any.serialise ==0.2.3.0, - any.servant ==0.18, - any.servant-rawm ==1.0.0.0, - any.serverless-haskell ==0.12.2, - any.serversession ==1.0.1, - any.serversession-frontend-wai ==1.0, - any.ses-html ==0.4.0.0, - any.set-cover ==0.1.1, - any.setenv ==0.1.1.3, - any.setlocale ==1.0.0.9, - any.sexp-grammar ==2.2.1, - any.shake ==0.19.1, - any.shake-plus ==0.3.3.0, - any.shake-plus-extended ==0.4.1.0, - any.shakespeare ==2.0.25, - any.shared-memory ==0.2.0.0, - any.shell-conduit ==5.0.0, - any.shell-escape ==0.2.0, - any.shell-utility ==0.1, - any.shellmet ==0.0.3.1, - any.shelltestrunner ==1.9, - any.shelly ==1.9.0, - any.shikensu ==0.3.11, - any.should-not-typecheck ==2.1.0, - any.show-combinators ==0.2.0.0, - any.siggy-chardust ==1.0.0, - any.signal ==0.1.0.4, - any.silently ==1.2.5.1, - any.simple-affine-space ==0.1.1, - any.simple-cabal ==0.1.2, - any.simple-cmd ==0.2.2, - any.simple-cmd-args ==0.1.6, - any.simple-log ==0.9.12, - any.simple-reflect ==0.3.3, - any.simple-sendfile ==0.2.30, - any.simple-templates ==1.0.0, - any.simple-vec3 ==0.6.0.1, - any.simplistic-generics ==2.0.0, - any.since ==0.0.0, - any.singleton-bool ==0.1.5, - any.singleton-nats ==0.4.5, - any.singletons ==2.7, - any.singletons-presburger ==0.3.0.1, - any.siphash ==1.0.3, - any.sitemap-gen ==0.1.0.0, - any.sized ==0.8.0.0, - any.skein ==1.0.9.4, - any.skews ==0.1.0.3, - any.skip-var ==0.1.1.0, - any.skylighting ==0.10.0.2, - any.skylighting-core ==0.10.0.2, - any.slack-api ==0.12, - any.slack-progressbar ==0.1.0.1, - any.slist ==0.1.1.0, - any.slynx ==0.4.0, - any.smallcheck ==1.2.0, - any.smash ==0.1.1.0, - any.smash-aeson ==0.1.0.0, - any.smash-lens ==0.1.0.1, - any.smash-microlens ==0.1.0.0, - any.smoothie ==0.4.2.11, - any.snap-blaze ==0.2.1.5, - any.snap-core ==1.0.4.2, - any.snap-server ==1.1.1.2, - any.snowflake ==0.1.1.1, - any.soap ==0.2.3.6, - any.soap-openssl ==0.1.0.2, - any.soap-tls ==0.1.1.4, - any.socks ==0.6.1, - any.some ==1.0.1, - any.sop-core ==0.5.0.1, - any.sort ==1.0.0.0, - any.sorted-list ==0.2.1.0, - any.sourcemap ==0.1.6, - any.sox ==0.2.3.1, - any.soxlib ==0.0.3.1, - any.sparse-linear-algebra ==0.3.1, - any.sparse-tensor ==0.2.1.4, - any.spatial-math ==0.5.0.1, - any.special-values ==0.1.0.0, - any.speculate ==0.4.2, - any.speedy-slice ==0.3.1, - any.splice ==0.6.1.1, - any.splint ==1.0.1.2, - any.split ==0.2.3.4, - any.splitmix ==0.0.5, - any.spoon ==0.3.1, - any.spreadsheet ==0.1.3.8, - any.sql-words ==0.1.6.4, - any.sqlcli ==0.2.2.0, - any.sqlcli-odbc ==0.2.0.1, - any.sqlite-simple ==0.4.18.0, - any.squeather ==0.4.0.0, - any.srcloc ==0.5.1.2, - any.stache ==2.2.0, - any.stack-templatizer ==0.1.0.2, - any.stackcollapse-ghc ==0.0.1.2, - any.stateref ==0.3, - any.static-text ==0.2.0.6, - any.statistics ==0.15.2.0, - any.status-notifier-item ==0.3.0.5, - any.stb-image-redux ==0.2.1.3, - any.step-function ==0.2, - any.stm-chans ==3.0.0.4, - any.stm-conduit ==4.0.1, - any.stm-delay ==0.1.1.1, - any.stm-extras ==0.1.0.3, - any.stm-split ==0.0.2.1, - any.stopwatch ==0.1.0.6, - any.storable-complex ==0.2.3.0, - any.storable-endian ==0.2.6, - any.storable-record ==0.0.5, - any.storable-tuple ==0.0.3.3, - any.storablevector ==0.2.13.1, - any.store ==0.7.7, - any.store-core ==0.4.4.3, - any.store-streaming ==0.2.0.3, - any.stratosphere ==0.59.1, - any.streaming ==0.2.3.0, - any.streaming-attoparsec ==1.0.0.1, - any.streaming-bytestring ==0.1.6, - any.streaming-commons ==0.2.2.1, - any.streaming-conduit ==0.1.2.2, - any.streaming-utils ==0.2.0.0, - any.streams ==3.3, - any.strict ==0.4, - any.strict-concurrency ==0.2.4.3, - any.strict-list ==0.1.5, - any.strict-tuple ==0.1.3, - any.strict-tuple-lens ==0.1.0.1, - any.string-class ==0.1.7.0, - any.string-combinators ==0.6.0.5, - any.string-conv ==0.1.2, - any.string-conversions ==0.4.0.1, - any.string-interpolate ==0.3.0.1, - any.string-qq ==0.0.4, - any.string-random ==0.1.3.0, - any.string-transform ==1.1.1, - any.stringbuilder ==0.5.1, - any.stringsearch ==0.3.6.6, - any.stripe-concepts ==1.0.2.4, - any.stripe-core ==2.6.2, - any.stripe-haskell ==2.6.2, - any.stripe-http-client ==2.6.2, - any.stripe-tests ==2.6.2, - any.strive ==5.0.12, - any.structs ==0.1.3, - any.structured ==0.1, - any.structured-cli ==2.6.0.0, - any.subcategories ==0.1.0.0, - any.sum-type-boilerplate ==0.1.1, - any.sundown ==0.6, - any.superbuffer ==0.3.1.1, - any.svg-tree ==0.6.2.4, - any.swagger ==0.3.0, - any.swagger2 ==2.6, - any.swish ==0.10.0.4, - any.syb ==0.7.1, - any.symbol ==0.2.4, - any.symengine ==0.1.2.0, - any.symmetry-operations-symbols ==0.0.2.1, - any.sysinfo ==0.1.1, - any.system-argv0 ==0.1.1, - any.system-fileio ==0.3.16.4, - any.system-filepath ==0.4.14, - any.system-info ==0.5.1, - any.systemd ==2.3.0, - any.tabular ==0.2.2.8, - any.tagchup ==0.4.1.1, - any.tagged ==0.8.6, - any.tagged-binary ==0.2.0.1, - any.tagged-identity ==0.1.3, - any.tagged-transformer ==0.8.1, - any.tagshare ==0.0, - any.tagsoup ==0.14.8, - any.tao ==1.0.0, - any.tao-example ==1.0.0, - tar -old-time, - any.tar ==0.5.1.1, - any.tar-conduit ==0.3.2, - any.tardis ==0.4.1.0, - any.tasty ==1.2.3, - any.tasty-ant-xml ==1.1.6, - any.tasty-dejafu ==2.0.0.6, - any.tasty-discover ==4.2.1, - any.tasty-expected-failure ==0.11.1.2, - any.tasty-golden ==2.3.3.2, - any.tasty-hedgehog ==1.0.0.2, - any.tasty-hspec ==1.1.5.1, - any.tasty-hunit ==0.10.0.2, - any.tasty-kat ==0.0.3, - any.tasty-leancheck ==0.0.1, - any.tasty-lua ==0.2.3, - any.tasty-program ==1.0.5, - any.tasty-quickcheck ==0.10.1.1, - any.tasty-rerun ==1.1.17, - any.tasty-silver ==3.1.15, - any.tasty-smallcheck ==0.8.1, - any.tasty-th ==0.1.7, - any.tasty-wai ==0.1.1.1, - any.tce-conf ==1.3, - any.tdigest ==0.2.1, - any.template-haskell-compat-v0208 ==0.1.5, - any.temporary ==1.3, - any.temporary-rc ==1.2.0.3, - any.temporary-resourcet ==0.1.0.1, - any.tensorflow-test ==0.1.0.0, - any.tensors ==0.1.4, - any.termbox ==0.3.0, - any.terminal-progress-bar ==0.4.1, - any.terminal-size ==0.3.2.1, - any.test-framework ==0.8.2.0, - any.test-framework-hunit ==0.3.0.2, - any.test-framework-leancheck ==0.0.1, - any.test-framework-quickcheck2 ==0.3.0.5, - any.test-framework-smallcheck ==0.2, - any.test-fun ==0.1.0.0, - any.testing-type-modifiers ==0.1.0.1, - any.texmath ==0.12.0.3, - any.text-ansi ==0.1.0.1, - any.text-binary ==0.2.1.1, - any.text-builder ==0.6.6.1, - any.text-conversions ==0.3.0, - any.text-format ==0.3.2, - any.text-icu ==0.7.0.1, - any.text-latin1 ==0.3.1, - any.text-ldap ==0.1.1.13, - any.text-manipulate ==0.2.0.1, - any.text-metrics ==0.3.0, - any.text-postgresql ==0.0.3.1, - any.text-printer ==0.5.0.1, - any.text-regex-replace ==0.1.1.3, - any.text-region ==0.3.1.0, - any.text-short ==0.1.3, - any.text-show ==3.8.5, - any.text-show-instances ==3.8.3, - any.text-zipper ==0.10.1, - any.textlocal ==0.1.0.5, - any.tf-random ==0.5, - any.tfp ==1.0.1.1, - any.th-abstraction ==0.3.2.0, - any.th-bang-compat ==0.0.1.0, - any.th-constraint-compat ==0.0.1.0, - any.th-data-compat ==0.1.0.0, - any.th-desugar ==1.11, - any.th-env ==0.1.0.2, - any.th-expand-syns ==0.4.6.0, - any.th-extras ==0.0.0.4, - any.th-lift ==0.8.1, - any.th-lift-instances ==0.1.17, - any.th-nowq ==0.1.0.5, - any.th-orphans ==0.13.10, - any.th-printf ==0.7, - any.th-reify-compat ==0.0.1.5, - any.th-reify-many ==0.1.9, - any.th-strict-compat ==0.1.0.1, - any.th-test-utils ==1.1.0, - any.th-utilities ==0.2.4.0, - any.these ==1.1.1.1, - any.these-lens ==1.0.0.1, - any.these-optics ==1, - any.these-skinny ==0.7.4, - any.thread-hierarchy ==0.3.0.2, - any.thread-local-storage ==0.2, - any.thread-supervisor ==0.2.0.0, - any.threads ==0.5.1.6, - any.threepenny-gui ==0.9.0.0, - any.throttle-io-stream ==0.2.0.1, - any.through-text ==0.1.0.0, - any.throwable-exceptions ==0.1.0.9, - any.thyme ==0.3.5.5, - any.tidal ==1.6.1, - any.tile ==0.3.0.0, - any.time-compat ==1.9.3, - any.time-lens ==0.4.0.2, - time-locale-compat -old-locale, - any.time-locale-compat ==0.1.1.5, - any.time-locale-vietnamese ==1.0.0.0, - any.time-manager ==0.0.0, - any.time-parsers ==0.1.2.1, - any.time-units ==1.0.0, - any.timeit ==2.0, - any.timelens ==0.2.0.2, - any.timer-wheel ==0.3.0, - any.timerep ==2.0.0.2, - any.timezone-olson ==0.2.0, - any.timezone-series ==0.1.9, - any.tinylog ==0.15.0, - any.titlecase ==1.0.1, - any.tldr ==0.8.0, - any.tls ==1.5.4, - any.tls-debug ==0.4.8, - any.tls-session-manager ==0.0.4, - any.tlynx ==0.4.0, - any.tmapchan ==0.0.3, - any.tmapmvar ==0.0.4, - any.tmp-postgres ==1.34.1.0, - any.tomland ==1.3.1.0, - any.tonalude ==0.1.1.0, - any.topograph ==1.0.0.1, - any.torsor ==0.1, - any.tostring ==0.2.1.1, - any.tracing ==0.0.5.1, - any.transaction ==0.1.1.3, - any.transformers-base ==0.4.5.2, - any.transformers-bifunctors ==0.1, - transformers-compat +five-three, - any.transformers-compat ==0.6.5, - any.transformers-fix ==1.0, - any.traverse-with-class ==1.0.1.0, - any.tree-diff ==0.1, - any.tree-fun ==0.8.1.0, - any.trifecta ==2.1, - any.triplesec ==0.2.2.1, - any.tsv2csv ==0.1.0.2, - any.ttc ==0.2.3.0, - any.ttl-hashtables ==1.4.1.0, - any.ttrie ==0.1.2.1, - any.tuple ==0.3.0.2, - any.tuple-sop ==0.3.1.0, - any.tuple-th ==0.2.5, - any.tuples-homogenous-h98 ==0.1.1.0, - any.turtle ==1.5.20, - any.type-equality ==1, - any.type-errors ==0.2.0.0, - any.type-errors-pretty ==0.0.1.1, - any.type-hint ==0.1, - any.type-level-integers ==0.0.1, - any.type-level-kv-list ==1.1.0, - any.type-level-natural-number ==2.0, - any.type-level-numbers ==0.1.1.1, - any.type-map ==0.1.6.0, - any.type-natural ==0.9.0.0, - any.type-of-html ==1.5.1.0, - any.type-of-html-static ==0.1.0.2, - any.type-operators ==0.2.0.0, - any.type-spec ==0.4.0.0, - any.typed-process ==0.2.6.0, - any.typed-uuid ==0.0.0.2, - any.typerep-map ==0.3.3.0, - any.tzdata ==0.1.20190911.0, - any.ua-parser ==0.7.5.1, - any.uglymemo ==0.1.0.1, - any.ulid ==0.3.0.0, - any.unagi-chan ==0.4.1.3, - any.unbounded-delays ==0.1.1.0, - any.unboxed-ref ==0.4.0.0, - any.unboxing-vector ==0.2.0.0, - any.uncertain ==0.3.1.0, - any.unconstrained ==0.1.0.2, - any.unexceptionalio ==0.5.1, - any.unexceptionalio-trans ==0.5.1, - any.unicode ==0.0.1.1, - any.unicode-show ==0.1.0.4, - any.unicode-transforms ==0.3.7, - any.unification-fd ==0.10.0.1, - any.union-find ==0.2, - any.uniplate ==1.6.12, - any.uniprot-kb ==0.1.2.0, - any.uniq-deep ==1.2.0, - any.unique ==0, - any.unique-logic ==0.4, - any.unique-logic-tf ==0.5.1, - any.unit-constraint ==0.0.0, - any.universe ==1.2, - any.universe-base ==1.1.1, - any.universe-instances-base ==1.1, - any.universe-instances-extended ==1.1.1, - any.universe-instances-trans ==1.1, - any.universe-reverse-instances ==1.1, - any.universe-some ==1.2, - any.universum ==1.7.1, - any.unix-bytestring ==0.3.7.3, - any.unix-compat ==0.5.2, - any.unix-time ==0.4.7, - any.unliftio ==0.2.13, - any.unliftio-core ==0.2.0.1, - any.unliftio-pool ==0.2.1.1, - any.unlit ==0.4.0.0, - any.unordered-containers ==0.2.12.0, - any.unsafe ==0.0, - any.urbit-hob ==0.3.3, - any.uri-bytestring ==0.3.2.2, - any.uri-bytestring-aeson ==0.1.0.8, - any.uri-encode ==1.5.0.6, - any.url ==2.1.3, - any.users ==0.5.0.0, - any.utf8-conversions ==0.1.0.4, - any.utf8-light ==0.4.2, - any.utf8-string ==1.0.1.1, - any.util ==0.1.17.1, - any.utility-ht ==0.0.15, - any.uuid ==1.3.13, - any.uuid-types ==1.0.3, - any.validation ==1.1, - any.validation-selective ==0.1.0.0, - any.validity ==0.11.0.0, - any.validity-aeson ==0.2.0.4, - any.validity-bytestring ==0.4.1.1, - any.validity-containers ==0.5.0.4, - any.validity-path ==0.4.0.1, - any.validity-primitive ==0.0.0.1, - any.validity-scientific ==0.2.0.3, - any.validity-text ==0.3.1.1, - any.validity-time ==0.4.0.0, - any.validity-unordered-containers ==0.2.0.3, - any.validity-uuid ==0.1.0.3, - any.validity-vector ==0.2.0.3, - any.valor ==0.1.0.0, - any.vault ==0.3.1.4, - any.vec ==0.3, - any.vector ==0.12.1.2, - any.vector-algorithms ==0.8.0.3, - any.vector-binary-instances ==0.2.5.1, - any.vector-buffer ==0.4.1, - any.vector-builder ==0.3.8, - any.vector-bytes-instances ==0.1.1, - any.vector-instances ==3.4, - any.vector-mmap ==0.0.3, - any.vector-rotcev ==0.1.0.0, - any.vector-sized ==1.4.2, - any.vector-space ==0.16, - any.vector-split ==1.0.0.2, - any.vector-th-unbox ==0.2.1.7, - any.verbosity ==0.4.0.0, - any.versions ==3.5.4, - any.vformat ==0.14.1.0, - any.vformat-aeson ==0.1.0.1, - any.vformat-time ==0.1.0.0, - any.vinyl ==0.13.0, - any.void ==0.7.3, - any.vty ==5.30, - any.wai ==3.2.2.1, - any.wai-app-static ==3.1.7.2, - any.wai-conduit ==3.0.0.4, - any.wai-cors ==0.2.7, - any.wai-enforce-https ==0.0.2.1, - any.wai-eventsource ==3.0.0, - any.wai-extra ==3.1.0, - any.wai-handler-launch ==3.0.3.1, - any.wai-logger ==2.3.6, - any.wai-middleware-auth ==0.2.3.1, - any.wai-middleware-caching ==0.1.0.2, - any.wai-middleware-clacks ==0.1.0.1, - any.wai-middleware-static ==0.8.3, - any.wai-saml2 ==0.2.1.0, - any.wai-session ==0.3.3, - any.wai-slack-middleware ==0.2.0, - any.wai-websockets ==3.0.1.2, - any.wakame ==0.1.0.0, - any.warp ==3.3.13, - any.warp-tls ==3.3.0, - any.warp-tls-uid ==0.2.0.6, - any.wave ==0.2.0, - any.wcwidth ==0.0.2, - any.webdriver ==0.9.0.1, - any.webex-teams-api ==0.2.0.1, - any.webex-teams-conduit ==0.2.0.1, - any.webex-teams-pipes ==0.2.0.1, - any.webgear-server ==0.2.0, - any.webrtc-vad ==0.1.0.3, - any.websockets ==0.12.7.1, - any.websockets-snap ==0.10.3.1, - any.weigh ==0.0.16, - any.wide-word ==0.1.1.1, - any.wikicfp-scraper ==0.1.0.11, - windns +allow-non-windows, - any.windns ==0.1.0.1, - any.with-location ==0.1.0, - any.with-utf8 ==1.0.2.1, - any.witherable-class ==0, - any.within ==0.2.0.1, - any.wizards ==1.0.3, - any.wl-pprint-annotated ==0.1.0.1, - any.wl-pprint-console ==0.1.0.2, - any.wl-pprint-text ==1.2.0.1, - any.word-trie ==0.3.0, - any.word-wrap ==0.4.1, - any.word24 ==2.0.1, - any.word8 ==0.1.3, - any.world-peace ==1.0.2.0, - any.wrap ==0.0.0, - any.wreq ==0.5.3.2, - any.writer-cps-exceptions ==0.1.0.1, - any.writer-cps-mtl ==0.1.1.6, - any.writer-cps-transformers ==0.5.6.1, - any.wss-client ==0.3.0.0, - any.wuss ==1.1.17, - any.x11-xim ==0.0.9.0, - any.x509 ==1.7.5, - any.x509-store ==1.6.7, - any.x509-system ==1.6.6, - any.x509-validation ==1.6.11, - any.xdg-basedir ==0.2.2, - any.xdg-desktop-entry ==0.1.1.1, - any.xdg-userdirs ==0.1.0.2, - any.xeno ==0.4.2, - any.xls ==0.1.3, - any.xlsx ==0.8.1, - any.xlsx-tabular ==0.2.2.1, - any.xml ==1.3.14, - any.xml-basic ==0.1.3.1, - any.xml-conduit ==1.9.0.0, - any.xml-conduit-writer ==0.1.1.2, - any.xml-hamlet ==0.5.0.1, - any.xml-helpers ==1.0.0, - any.xml-indexed-cursor ==0.1.1.0, - any.xml-lens ==0.2, - any.xml-picklers ==0.3.6, - any.xml-to-json ==2.0.1, - any.xml-to-json-fast ==2.0.0, - any.xml-types ==0.3.8, - any.xmlgen ==0.6.2.2, - any.xmonad ==0.15, - any.xmonad-contrib ==0.16, - any.xmonad-extras ==0.15.2, - any.xss-sanitize ==0.3.6, - any.xxhash-ffi ==0.2.0.0, - any.yaml ==0.11.5.0, - any.yamlparse-applicative ==0.1.0.1, - any.yes-precure5-command ==5.5.3, - any.yesod ==1.6.1.0, - any.yesod-auth ==1.6.10, - any.yesod-auth-hashdb ==1.7.1.2, - any.yesod-bin ==1.6.0.6, - any.yesod-core ==1.6.18.4, - any.yesod-fb ==0.6.1, - any.yesod-form ==1.6.7, - any.yesod-gitrev ==0.2.1, - any.yesod-newsfeed ==1.7.0.0, - any.yesod-persistent ==1.6.0.4, - any.yesod-sitemap ==1.6.0, - any.yesod-static ==1.6.1.0, - any.yesod-test ==1.6.10, - any.yesod-websockets ==0.3.0.2, - any.yi-rope ==0.11, - any.yjsvg ==0.2.0.1, - any.yjtools ==0.9.18, - any.yoga ==0.0.0.5, - any.youtube ==0.2.1.1, - any.zenacy-html ==2.0.2, - any.zenacy-unicode ==1.0.0, - any.zero ==0.1.5, - any.zeromq4-haskell ==0.8.0, - any.zeromq4-patterns ==0.3.1.0, - any.zim-parser ==0.2.1.0, - any.zio ==0.1.0.0, - any.zip ==1.6.0, - any.zip-archive ==0.4.1, - any.zip-stream ==0.2.0.1, - any.zipper-extra ==0.1.3.2, - any.zippers ==0.3, - any.zlib ==0.6.2.2, - any.zlib-bindings ==0.1.1.5, - any.zlib-lens ==0.1.2.1, - any.zot ==0.0.3, - any.zstd ==0.1.2.0, - any.ztail ==1.2.0.2 diff --git a/agent/config/agent.service b/agent/config/agent.service deleted file mode 100644 index 791d68d08..000000000 --- a/agent/config/agent.service +++ /dev/null @@ -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 \ No newline at end of file diff --git a/agent/config/journald.conf b/agent/config/journald.conf deleted file mode 100644 index 47951df4c..000000000 --- a/agent/config/journald.conf +++ /dev/null @@ -1,6 +0,0 @@ -[Journal] -Storage=persistent -SystemMaxUse=100M -SystemMaxFileSize=10M -MaxRetentionSec=1month -MaxFileSec=1week \ No newline at end of file diff --git a/agent/config/nginx.conf b/agent/config/nginx.conf deleted file mode 100644 index fa6f87b13..000000000 --- a/agent/config/nginx.conf +++ /dev/null @@ -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/*; -} \ No newline at end of file diff --git a/agent/config/restarter.service b/agent/config/restarter.service deleted file mode 100644 index 6b8ee093a..000000000 --- a/agent/config/restarter.service +++ /dev/null @@ -1,7 +0,0 @@ -[Unit] -Description=restarts dead containers -Requires=docker.service - -[Service] -Type=oneshot -ExecStart=/usr/local/bin/appmgr repair-app-status \ No newline at end of file diff --git a/agent/config/restarter.timer b/agent/config/restarter.timer deleted file mode 100644 index c9d7ff6fe..000000000 --- a/agent/config/restarter.timer +++ /dev/null @@ -1,9 +0,0 @@ -[Unit] -Description=restarter - -[Timer] -OnUnitActiveSec=60s -OnBootSec=60s - -[Install] -WantedBy=timers.target \ No newline at end of file diff --git a/agent/config/routes b/agent/config/routes deleted file mode 100644 index 467ccc691..000000000 --- a/agent/config/routes +++ /dev/null @@ -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 \ No newline at end of file diff --git a/agent/config/settings.yml b/agent/config/settings.yml deleted file mode 100644 index 87c812765..000000000 --- a/agent/config/settings.yml +++ /dev/null @@ -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 diff --git a/agent/config/torrc b/agent/config/torrc deleted file mode 100644 index 68ede8e27..000000000 --- a/agent/config/torrc +++ /dev/null @@ -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 \ No newline at end of file diff --git a/agent/hie.yaml b/agent/hie.yaml deleted file mode 100644 index ed5bc79c8..000000000 --- a/agent/hie.yaml +++ /dev/null @@ -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" \ No newline at end of file diff --git a/agent/migrations/0.1.0::0.1.0 b/agent/migrations/0.1.0::0.1.0 deleted file mode 100644 index b928005e2..000000000 --- a/agent/migrations/0.1.0::0.1.0 +++ /dev/null @@ -1 +0,0 @@ -SELECT TRUE; \ No newline at end of file diff --git a/agent/migrations/0.1.0::0.1.1 b/agent/migrations/0.1.0::0.1.1 deleted file mode 100644 index cb9f5d239..000000000 --- a/agent/migrations/0.1.0::0.1.1 +++ /dev/null @@ -1 +0,0 @@ -CREATE TABLE "replay_nonce"("id" VARCHAR PRIMARY KEY,"created_at" TIMESTAMP NOT NULL); \ No newline at end of file diff --git a/agent/migrations/0.1.1::0.1.2 b/agent/migrations/0.1.1::0.1.2 deleted file mode 100644 index b928005e2..000000000 --- a/agent/migrations/0.1.1::0.1.2 +++ /dev/null @@ -1 +0,0 @@ -SELECT TRUE; \ No newline at end of file diff --git a/agent/migrations/0.1.2::0.1.3 b/agent/migrations/0.1.2::0.1.3 deleted file mode 100644 index b928005e2..000000000 --- a/agent/migrations/0.1.2::0.1.3 +++ /dev/null @@ -1 +0,0 @@ -SELECT TRUE; \ No newline at end of file diff --git a/agent/migrations/0.1.3::0.1.4 b/agent/migrations/0.1.3::0.1.4 deleted file mode 100644 index 3471bf585..000000000 --- a/agent/migrations/0.1.3::0.1.4 +++ /dev/null @@ -1 +0,0 @@ -SELECT TRUE; diff --git a/agent/migrations/0.1.4::0.1.5 b/agent/migrations/0.1.4::0.1.5 deleted file mode 100644 index 3471bf585..000000000 --- a/agent/migrations/0.1.4::0.1.5 +++ /dev/null @@ -1 +0,0 @@ -SELECT TRUE; diff --git a/agent/migrations/0.1.5::0.2.0 b/agent/migrations/0.1.5::0.2.0 deleted file mode 100644 index fa220ddf7..000000000 --- a/agent/migrations/0.1.5::0.2.0 +++ /dev/null @@ -1,2 +0,0 @@ -DROP TABLE authorized_key; -DROP TABLE replay_nonce; diff --git a/agent/migrations/0.2.0::0.2.1 b/agent/migrations/0.2.0::0.2.1 deleted file mode 100644 index b928005e2..000000000 --- a/agent/migrations/0.2.0::0.2.1 +++ /dev/null @@ -1 +0,0 @@ -SELECT TRUE; \ No newline at end of file diff --git a/agent/migrations/0.2.10::0.2.11 b/agent/migrations/0.2.10::0.2.11 deleted file mode 100644 index b928005e2..000000000 --- a/agent/migrations/0.2.10::0.2.11 +++ /dev/null @@ -1 +0,0 @@ -SELECT TRUE; \ No newline at end of file diff --git a/agent/migrations/0.2.11::0.2.12 b/agent/migrations/0.2.11::0.2.12 deleted file mode 100644 index b928005e2..000000000 --- a/agent/migrations/0.2.11::0.2.12 +++ /dev/null @@ -1 +0,0 @@ -SELECT TRUE; \ No newline at end of file diff --git a/agent/migrations/0.2.12::0.2.13 b/agent/migrations/0.2.12::0.2.13 deleted file mode 100644 index b928005e2..000000000 --- a/agent/migrations/0.2.12::0.2.13 +++ /dev/null @@ -1 +0,0 @@ -SELECT TRUE; \ No newline at end of file diff --git a/agent/migrations/0.2.13::0.2.14 b/agent/migrations/0.2.13::0.2.14 deleted file mode 100644 index b928005e2..000000000 --- a/agent/migrations/0.2.13::0.2.14 +++ /dev/null @@ -1 +0,0 @@ -SELECT TRUE; \ No newline at end of file diff --git a/agent/migrations/0.2.14::0.2.15 b/agent/migrations/0.2.14::0.2.15 deleted file mode 100644 index b928005e2..000000000 --- a/agent/migrations/0.2.14::0.2.15 +++ /dev/null @@ -1 +0,0 @@ -SELECT TRUE; \ No newline at end of file diff --git a/agent/migrations/0.2.15::0.2.16 b/agent/migrations/0.2.15::0.2.16 deleted file mode 100644 index b928005e2..000000000 --- a/agent/migrations/0.2.15::0.2.16 +++ /dev/null @@ -1 +0,0 @@ -SELECT TRUE; \ No newline at end of file diff --git a/agent/migrations/0.2.16::0.2.17 b/agent/migrations/0.2.16::0.2.17 deleted file mode 100644 index 3471bf585..000000000 --- a/agent/migrations/0.2.16::0.2.17 +++ /dev/null @@ -1 +0,0 @@ -SELECT TRUE; diff --git a/agent/migrations/0.2.1::0.2.2 b/agent/migrations/0.2.1::0.2.2 deleted file mode 100644 index 3471bf585..000000000 --- a/agent/migrations/0.2.1::0.2.2 +++ /dev/null @@ -1 +0,0 @@ -SELECT TRUE; diff --git a/agent/migrations/0.2.2::0.2.3 b/agent/migrations/0.2.2::0.2.3 deleted file mode 100644 index b928005e2..000000000 --- a/agent/migrations/0.2.2::0.2.3 +++ /dev/null @@ -1 +0,0 @@ -SELECT TRUE; \ No newline at end of file diff --git a/agent/migrations/0.2.3::0.2.4 b/agent/migrations/0.2.3::0.2.4 deleted file mode 100644 index b928005e2..000000000 --- a/agent/migrations/0.2.3::0.2.4 +++ /dev/null @@ -1 +0,0 @@ -SELECT TRUE; \ No newline at end of file diff --git a/agent/migrations/0.2.4::0.2.5 b/agent/migrations/0.2.4::0.2.5 deleted file mode 100644 index b928005e2..000000000 --- a/agent/migrations/0.2.4::0.2.5 +++ /dev/null @@ -1 +0,0 @@ -SELECT TRUE; \ No newline at end of file diff --git a/agent/migrations/0.2.5::0.2.6 b/agent/migrations/0.2.5::0.2.6 deleted file mode 100644 index b928005e2..000000000 --- a/agent/migrations/0.2.5::0.2.6 +++ /dev/null @@ -1 +0,0 @@ -SELECT TRUE; \ No newline at end of file diff --git a/agent/migrations/0.2.6::0.2.7 b/agent/migrations/0.2.6::0.2.7 deleted file mode 100644 index b928005e2..000000000 --- a/agent/migrations/0.2.6::0.2.7 +++ /dev/null @@ -1 +0,0 @@ -SELECT TRUE; \ No newline at end of file diff --git a/agent/migrations/0.2.7::0.2.8 b/agent/migrations/0.2.7::0.2.8 deleted file mode 100644 index b928005e2..000000000 --- a/agent/migrations/0.2.7::0.2.8 +++ /dev/null @@ -1 +0,0 @@ -SELECT TRUE; \ No newline at end of file diff --git a/agent/migrations/0.2.8::0.2.9 b/agent/migrations/0.2.8::0.2.9 deleted file mode 100644 index b928005e2..000000000 --- a/agent/migrations/0.2.8::0.2.9 +++ /dev/null @@ -1 +0,0 @@ -SELECT TRUE; \ No newline at end of file diff --git a/agent/migrations/0.2.9::0.2.10 b/agent/migrations/0.2.9::0.2.10 deleted file mode 100644 index b928005e2..000000000 --- a/agent/migrations/0.2.9::0.2.10 +++ /dev/null @@ -1 +0,0 @@ -SELECT TRUE; \ No newline at end of file diff --git a/agent/package.yaml b/agent/package.yaml deleted file mode 100644 index 06866f920..000000000 --- a/agent/package.yaml +++ /dev/null @@ -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/* diff --git a/agent/src/Application.hs b/agent/src/Application.hs deleted file mode 100644 index 160d795d7..000000000 --- a/agent/src/Application.hs +++ /dev/null @@ -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 - diff --git a/agent/src/Auth.hs b/agent/src/Auth.hs deleted file mode 100644 index 069495337..000000000 --- a/agent/src/Auth.hs +++ /dev/null @@ -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 -|] diff --git a/agent/src/Constants.hs b/agent/src/Constants.hs deleted file mode 100644 index 158c2bc80..000000000 --- a/agent/src/Constants.hs +++ /dev/null @@ -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 diff --git a/agent/src/Daemon/AppNotifications.hs b/agent/src/Daemon/AppNotifications.hs deleted file mode 100644 index afb3f074b..000000000 --- a/agent/src/Daemon/AppNotifications.hs +++ /dev/null @@ -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 () diff --git a/agent/src/Daemon/RefreshProcDev.hs b/agent/src/Daemon/RefreshProcDev.hs deleted file mode 100644 index f958c1d72..000000000 --- a/agent/src/Daemon/RefreshProcDev.hs +++ /dev/null @@ -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) - diff --git a/agent/src/Daemon/SslRenew.hs b/agent/src/Daemon/SslRenew.hs deleted file mode 100644 index 23524ce45..000000000 --- a/agent/src/Daemon/SslRenew.hs +++ /dev/null @@ -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 diff --git a/agent/src/Daemon/TorHealth.hs b/agent/src/Daemon/TorHealth.hs deleted file mode 100644 index 51b8d675b..000000000 --- a/agent/src/Daemon/TorHealth.hs +++ /dev/null @@ -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 diff --git a/agent/src/Daemon/ZeroConf.hs b/agent/src/Daemon/ZeroConf.hs deleted file mode 100644 index 0d44f2c6c..000000000 --- a/agent/src/Daemon/ZeroConf.hs +++ /dev/null @@ -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' - - diff --git a/agent/src/Foundation.hs b/agent/src/Foundation.hs deleted file mode 100644 index c5c04f78f..000000000 --- a/agent/src/Foundation.hs +++ /dev/null @@ -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 diff --git a/agent/src/Handler/Apps.hs b/agent/src/Handler/Apps.hs deleted file mode 100644 index ac769b265..000000000 --- a/agent/src/Handler/Apps.hs +++ /dev/null @@ -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" diff --git a/agent/src/Handler/Authenticate.hs b/agent/src/Handler/Authenticate.hs deleted file mode 100644 index 2e6476971..000000000 --- a/agent/src/Handler/Authenticate.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Handler.Authenticate where - -import Startlude - -import Foundation - --- handled by auth switch in Foundation -getAuthenticateR :: Handler () -getAuthenticateR = pure () diff --git a/agent/src/Handler/Backups.hs b/agent/src/Handler/Backups.hs deleted file mode 100644 index a8994c84c..000000000 --- a/agent/src/Handler/Backups.hs +++ /dev/null @@ -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] diff --git a/agent/src/Handler/Hosts.hs b/agent/src/Handler/Hosts.hs deleted file mode 100644 index 73af73a15..000000000 --- a/agent/src/Handler/Hosts.hs +++ /dev/null @@ -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 diff --git a/agent/src/Handler/Icons.hs b/agent/src/Handler/Icons.hs deleted file mode 100644 index 110cdb331..000000000 --- a/agent/src/Handler/Icons.hs +++ /dev/null @@ -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 diff --git a/agent/src/Handler/Login.hs b/agent/src/Handler/Login.hs deleted file mode 100644 index d4241fd9b..000000000 --- a/agent/src/Handler/Login.hs +++ /dev/null @@ -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' - diff --git a/agent/src/Handler/Network.hs b/agent/src/Handler/Network.hs deleted file mode 100644 index f34a99b29..000000000 --- a/agent/src/Handler/Network.hs +++ /dev/null @@ -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 diff --git a/agent/src/Handler/Notifications.hs b/agent/src/Handler/Notifications.hs deleted file mode 100644 index 9500b3c42..000000000 --- a/agent/src/Handler/Notifications.hs +++ /dev/null @@ -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) diff --git a/agent/src/Handler/PasswordUpdate.hs b/agent/src/Handler/PasswordUpdate.hs deleted file mode 100644 index afcbb1e22..000000000 --- a/agent/src/Handler/PasswordUpdate.hs +++ /dev/null @@ -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') diff --git a/agent/src/Handler/PowerOff.hs b/agent/src/Handler/PowerOff.hs deleted file mode 100644 index d48552723..000000000 --- a/agent/src/Handler/PowerOff.hs +++ /dev/null @@ -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 () \ No newline at end of file diff --git a/agent/src/Handler/Register.hs b/agent/src/Handler/Register.hs deleted file mode 100644 index 4f295e251..000000000 --- a/agent/src/Handler/Register.hs +++ /dev/null @@ -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 { .. } diff --git a/agent/src/Handler/Register/Nginx.hs b/agent/src/Handler/Register/Nginx.hs deleted file mode 100644 index 4d38353db..000000000 --- a/agent/src/Handler/Register/Nginx.hs +++ /dev/null @@ -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 diff --git a/agent/src/Handler/Register/Tor.hs b/agent/src/Handler/Register/Tor.hs deleted file mode 100644 index d93f3c24e..000000000 --- a/agent/src/Handler/Register/Tor.hs +++ /dev/null @@ -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 \ No newline at end of file diff --git a/agent/src/Handler/SelfUpdate.hs b/agent/src/Handler/SelfUpdate.hs deleted file mode 100644 index c94da316d..000000000 --- a/agent/src/Handler/SelfUpdate.hs +++ /dev/null @@ -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 diff --git a/agent/src/Handler/SshKeys.hs b/agent/src/Handler/SshKeys.hs deleted file mode 100644 index 6224bb1e2..000000000 --- a/agent/src/Handler/SshKeys.hs +++ /dev/null @@ -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 diff --git a/agent/src/Handler/Status.hs b/agent/src/Handler/Status.hs deleted file mode 100644 index 43ebf95ac..000000000 --- a/agent/src/Handler/Status.hs +++ /dev/null @@ -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" diff --git a/agent/src/Handler/Tor.hs b/agent/src/Handler/Tor.hs deleted file mode 100644 index a12f9b6bf..000000000 --- a/agent/src/Handler/Tor.hs +++ /dev/null @@ -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 diff --git a/agent/src/Handler/Types/Apps.hs b/agent/src/Handler/Types/Apps.hs deleted file mode 100644 index 8d97ee431..000000000 --- a/agent/src/Handler/Types/Apps.hs +++ /dev/null @@ -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] diff --git a/agent/src/Handler/Types/HmacSig.hs b/agent/src/Handler/Types/HmacSig.hs deleted file mode 100644 index 73a0bf624..000000000 --- a/agent/src/Handler/Types/HmacSig.hs +++ /dev/null @@ -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 diff --git a/agent/src/Handler/Types/Hosts.hs b/agent/src/Handler/Types/Hosts.hs deleted file mode 100644 index 20b18b6e1..000000000 --- a/agent/src/Handler/Types/Hosts.hs +++ /dev/null @@ -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 diff --git a/agent/src/Handler/Types/Metrics.hs b/agent/src/Handler/Types/Metrics.hs deleted file mode 100644 index 9427179b5..000000000 --- a/agent/src/Handler/Types/Metrics.hs +++ /dev/null @@ -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 } diff --git a/agent/src/Handler/Types/Parse.hs b/agent/src/Handler/Types/Parse.hs deleted file mode 100644 index 6ddba1f32..000000000 --- a/agent/src/Handler/Types/Parse.hs +++ /dev/null @@ -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 diff --git a/agent/src/Handler/Types/Register.hs b/agent/src/Handler/Types/Register.hs deleted file mode 100644 index ccc78f28c..000000000 --- a/agent/src/Handler/Types/Register.hs +++ /dev/null @@ -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 diff --git a/agent/src/Handler/Types/V0/Base.hs b/agent/src/Handler/Types/V0/Base.hs deleted file mode 100644 index f55618e4d..000000000 --- a/agent/src/Handler/Types/V0/Base.hs +++ /dev/null @@ -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 diff --git a/agent/src/Handler/Types/V0/Specs.hs b/agent/src/Handler/Types/V0/Specs.hs deleted file mode 100644 index 6fd69c8fb..000000000 --- a/agent/src/Handler/Types/V0/Specs.hs +++ /dev/null @@ -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 diff --git a/agent/src/Handler/Types/V0/Ssh.hs b/agent/src/Handler/Types/V0/Ssh.hs deleted file mode 100644 index 35dd6c8dc..000000000 --- a/agent/src/Handler/Types/V0/Ssh.hs +++ /dev/null @@ -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 diff --git a/agent/src/Handler/Types/V0/Wifi.hs b/agent/src/Handler/Types/V0/Wifi.hs deleted file mode 100644 index e52193c6d..000000000 --- a/agent/src/Handler/Types/V0/Wifi.hs +++ /dev/null @@ -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 diff --git a/agent/src/Handler/Util.hs b/agent/src/Handler/Util.hs deleted file mode 100644 index 5349b3dc9..000000000 --- a/agent/src/Handler/Util.hs +++ /dev/null @@ -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 diff --git a/agent/src/Handler/V0.hs b/agent/src/Handler/V0.hs deleted file mode 100644 index 4d59df2c9..000000000 --- a/agent/src/Handler/V0.hs +++ /dev/null @@ -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 diff --git a/agent/src/Handler/Wifi.hs b/agent/src/Handler/Wifi.hs deleted file mode 100644 index 0b973ca87..000000000 --- a/agent/src/Handler/Wifi.hs +++ /dev/null @@ -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 diff --git a/agent/src/Lib/Algebra/Domain/AppMgr.hs b/agent/src/Lib/Algebra/Domain/AppMgr.hs deleted file mode 100644 index 067b36a3d..000000000 --- a/agent/src/Lib/Algebra/Domain/AppMgr.hs +++ /dev/null @@ -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) diff --git a/agent/src/Lib/Algebra/Domain/AppMgr/TH.hs b/agent/src/Lib/Algebra/Domain/AppMgr/TH.hs deleted file mode 100644 index bf516c54d..000000000 --- a/agent/src/Lib/Algebra/Domain/AppMgr/TH.hs +++ /dev/null @@ -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" - } diff --git a/agent/src/Lib/Algebra/Domain/AppMgr/Types.hs b/agent/src/Lib/Algebra/Domain/AppMgr/Types.hs deleted file mode 100644 index 6947edb92..000000000 --- a/agent/src/Lib/Algebra/Domain/AppMgr/Types.hs +++ /dev/null @@ -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) |]) - diff --git a/agent/src/Lib/Algebra/State/RegistryUrl.hs b/agent/src/Lib/Algebra/State/RegistryUrl.hs deleted file mode 100644 index 683b75227..000000000 --- a/agent/src/Lib/Algebra/State/RegistryUrl.hs +++ /dev/null @@ -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 - diff --git a/agent/src/Lib/Avahi.hs b/agent/src/Lib/Avahi.hs deleted file mode 100644 index ca74aea65..000000000 --- a/agent/src/Lib/Avahi.hs +++ /dev/null @@ -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| - - - - #{name} - - #{protocol} - #{port} - -|] - -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 diff --git a/agent/src/Lib/Background.hs b/agent/src/Lib/Background.hs deleted file mode 100644 index c6fa11e06..000000000 --- a/agent/src/Lib/Background.hs +++ /dev/null @@ -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 diff --git a/agent/src/Lib/ClientManifest.hs b/agent/src/Lib/ClientManifest.hs deleted file mode 100644 index 1cc3f6059..000000000 --- a/agent/src/Lib/ClientManifest.hs +++ /dev/null @@ -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 - diff --git a/agent/src/Lib/Crypto.hs b/agent/src/Lib/Crypto.hs deleted file mode 100644 index 205356e7b..000000000 --- a/agent/src/Lib/Crypto.hs +++ /dev/null @@ -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 diff --git a/agent/src/Lib/Database.hs b/agent/src/Lib/Database.hs deleted file mode 100644 index 043b05eeb..000000000 --- a/agent/src/Lib/Database.hs +++ /dev/null @@ -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 diff --git a/agent/src/Lib/Error.hs b/agent/src/Lib/Error.hs deleted file mode 100644 index 0dfa6f59f..000000000 --- a/agent/src/Lib/Error.hs +++ /dev/null @@ -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 #-} - diff --git a/agent/src/Lib/External/AppManifest.hs b/agent/src/Lib/External/AppManifest.hs deleted file mode 100644 index ed675db9a..000000000 --- a/agent/src/Lib/External/AppManifest.hs +++ /dev/null @@ -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 { .. } diff --git a/agent/src/Lib/External/AppMgr.hs b/agent/src/Lib/External/AppMgr.hs deleted file mode 100644 index da3ad3054..000000000 --- a/agent/src/Lib/External/AppMgr.hs +++ /dev/null @@ -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 - ] diff --git a/agent/src/Lib/External/Metrics/Df.hs b/agent/src/Lib/External/Metrics/Df.hs deleted file mode 100644 index cc9bd8d53..000000000 --- a/agent/src/Lib/External/Metrics/Df.hs +++ /dev/null @@ -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 diff --git a/agent/src/Lib/External/Metrics/Iotop.hs b/agent/src/Lib/External/Metrics/Iotop.hs deleted file mode 100644 index 306892b78..000000000 --- a/agent/src/Lib/External/Metrics/Iotop.hs +++ /dev/null @@ -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]+)" - diff --git a/agent/src/Lib/External/Metrics/ProcDev.hs b/agent/src/Lib/External/Metrics/ProcDev.hs deleted file mode 100644 index aba8910c8..000000000 --- a/agent/src/Lib/External/Metrics/ProcDev.hs +++ /dev/null @@ -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 diff --git a/agent/src/Lib/External/Metrics/Temperature.hs b/agent/src/Lib/External/Metrics/Temperature.hs deleted file mode 100644 index 7a5664da6..000000000 --- a/agent/src/Lib/External/Metrics/Temperature.hs +++ /dev/null @@ -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 diff --git a/agent/src/Lib/External/Metrics/Top.hs b/agent/src/Lib/External/Metrics/Top.hs deleted file mode 100644 index 41d99048b..000000000 --- a/agent/src/Lib/External/Metrics/Top.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} - -module Lib.External.Metrics.Top where - -import Startlude - -import qualified Data.HashMap.Strict as HM -import System.Process - -import Lib.Error -import Lib.External.Metrics.Types -import Lib.External.Util -import Util.Text - -data TopMetrics = TopMetrics - { metricMemPercentageUsed :: Maybe Percentage - , metricMemFree :: Maybe MebiBytes - , metricMemUsed :: Maybe MebiBytes - , metricSwapTotal :: Maybe MebiBytes - , metricSwapUsed :: Maybe MebiBytes - , metricCpuIdle :: Maybe Percentage - , metricCpuUserSpace :: Maybe Percentage - , metricWait :: Maybe Percentage - , metricCpuPercentageUsed :: Maybe Percentage - } - deriving (Eq, Show) - -getTopMetrics :: MonadIO m => S9ErrT m TopMetrics -getTopMetrics = fmap parseTop runTop - -runTop :: MonadIO m => S9ErrT m Text -runTop = do - (_, output, err') <- liftIO $ readProcessWithExitCode "top" ["-bn1"] "" - unless (null err') $ throwE . MetricE $ "top command failed with " <> toS err' - pure $ toS output - -parseTop :: Text -> TopMetrics -parseTop t = TopMetrics { metricMemPercentageUsed = getMemPercentageUsed <$> mem - , metricMemFree = MebiBytes . memFree <$> mem - , metricMemUsed = MebiBytes . memUsed <$> mem - , metricSwapTotal = MebiBytes . memTotal <$> swapS - , metricSwapUsed = MebiBytes . memUsed <$> swapS - , metricCpuIdle = cpuId <$> cpu - , metricCpuUserSpace = cpuUs <$> cpu - , metricWait = cpuWa <$> cpu - , metricCpuPercentageUsed = getCpuPercentageUsed <$> cpu - } - where - topLines = lines t - cpu = getCpuAggregates topLines - mem = getMemAggregates topLines - swapS = getSwapAggregates topLines - -memHeader :: Text -memHeader = "MiB Mem" - -swapHeader :: Text -swapHeader = "MiB Swap" - -data TopMemAggregates = TopMemAggregates - { memTotal :: Double - , memFree :: Double - , memUsed :: Double - } - deriving (Eq, Show) - -cpuHeader :: Text -cpuHeader = "%Cpu(s)" - -data TopCpuAggregates = TopCpuAggregates - { cpuUs :: Percentage - , cpuSy :: Percentage - , cpuNi :: Percentage - , cpuId :: Percentage - , cpuWa :: Percentage - , cpuHi :: Percentage - , cpuSi :: Percentage - , cpuSt :: Percentage - } - deriving (Eq, Show) - -getMemAggregates :: [Text] -> Maybe TopMemAggregates -getMemAggregates topRes = do - memLine <- getLineByHeader memHeader topRes - swapLine <- getLineByHeader swapHeader topRes - let stats = HM.fromList $ getStats readMaybe memLine - memTotal <- HM.lookup "total" stats - memFree <- HM.lookup "avail" (HM.fromList $ getStats readMaybe swapLine) - memUsed <- HM.lookup "used" stats - pure TopMemAggregates { .. } - -getSwapAggregates :: [Text] -> Maybe TopMemAggregates -getSwapAggregates topRes = do - swapLine <- getLineByHeader swapHeader topRes - let stats = HM.fromList $ getStats readMaybe swapLine - memTotal <- HM.lookup "total" stats - memFree <- HM.lookup "free" stats - memUsed <- HM.lookup "used" stats - pure TopMemAggregates { .. } - -getCpuAggregates :: [Text] -> Maybe TopCpuAggregates -getCpuAggregates topRes = do - memLine <- getLineByHeader cpuHeader topRes - let stats = HM.fromList $ getStats (mkPercentage <=< readMaybe) memLine - cpuUs <- HM.lookup "us" stats - cpuSy <- HM.lookup "sy" stats - cpuNi <- HM.lookup "ni" stats - cpuId <- HM.lookup "id" stats - cpuWa <- HM.lookup "wa" stats - cpuHi <- HM.lookup "hi" stats - cpuSi <- HM.lookup "si" stats - cpuSt <- HM.lookup "st" stats - pure TopCpuAggregates { .. } - -getCpuPercentageUsed :: TopCpuAggregates -> Percentage -getCpuPercentageUsed TopCpuAggregates {..} = Percentage (100 - unPercent cpuId) - -getMemPercentageUsed :: TopMemAggregates -> Percentage -getMemPercentageUsed TopMemAggregates {..} = Percentage . truncateTo @Double 10 . (* 100) $ memUsed / memTotal - -getStats :: (Text -> Maybe a) -> Text -> [(Text, a)] -getStats parseData = mapMaybe (parseToPair parseData) . fmap (words . toS) . getMatches statRegex . toS - where statRegex = "[0-9]+(.[0-9][0-9]?)? ([\x21-\x7E][^(,|.)]+)" diff --git a/agent/src/Lib/External/Metrics/Types.hs b/agent/src/Lib/External/Metrics/Types.hs deleted file mode 100644 index acb2840d7..000000000 --- a/agent/src/Lib/External/Metrics/Types.hs +++ /dev/null @@ -1,89 +0,0 @@ -module Lib.External.Metrics.Types where - -import Startlude - -import Data.Aeson -import qualified GHC.Read ( Read(..) - , readsPrec - ) -import qualified GHC.Show ( Show(..) ) - -import Lib.External.Util - -class Metric a where - mUnit :: a -> Text - mValue :: a -> Double - -toMetricJson :: Metric a => a -> Value -toMetricJson x = object ["value" .= truncateToS 2 (mValue x), "unit" .= mUnit x] -toMetricShow :: Metric a => a -> String -toMetricShow a = show (mValue a) <> " " <> toS (mUnit a) - -newtype Percentage = Percentage { unPercent :: Double } deriving (Eq) -instance Metric Percentage where - mValue (Percentage p) = p - mUnit _ = "%" -instance ToJSON Percentage where - toJSON = toMetricJson -instance Show Percentage where - show = toMetricShow -instance Read Percentage where - readsPrec _ s = case reverse s of - '%' : rest -> case GHC.Read.readsPrec 0 (reverse rest) of - [(result, "")] -> case mkPercentage result of - Just p -> [(p, "")] - _ -> [] - _ -> [] - _ -> [] - -mkPercentage :: Double -> Maybe Percentage -mkPercentage s | 0 <= s && s <= 100 = Just $ Percentage s - | otherwise = Nothing - -newtype MebiBytes = MebiBytes Double - deriving stock Eq - deriving newtype Num - -instance Metric MebiBytes where - mValue (MebiBytes p) = p - mUnit _ = "MiB" -instance ToJSON MebiBytes where - toJSON = toMetricJson -instance Show MebiBytes where - show = toMetricShow - -newtype BytesPerSecond = BytesPerSecond Double - deriving stock Eq - deriving newtype Num - -instance Metric BytesPerSecond where - mValue (BytesPerSecond p) = p - mUnit _ = "B/s" -instance ToJSON BytesPerSecond where - toJSON = toMetricJson -instance Show BytesPerSecond where - show = toMetricShow - -newtype Gigabytes = Gigabytes Double - deriving stock Eq - deriving newtype Num - -instance Metric Gigabytes where - mValue (Gigabytes p) = p - mUnit _ = "Gb" -instance ToJSON Gigabytes where - toJSON = toMetricJson -instance Show Gigabytes where - show = toMetricShow - -newtype Celsius = Celsius { unCelsius :: Double } - deriving stock Eq - deriving newtype Num - -instance Metric Celsius where - mValue (Celsius c) = c - mUnit _ = "°C" -instance ToJSON Celsius where - toJSON = toMetricJson -instance Show Celsius where - show = toMetricShow diff --git a/agent/src/Lib/External/Registry.hs b/agent/src/Lib/External/Registry.hs deleted file mode 100644 index 89c3cef64..000000000 --- a/agent/src/Lib/External/Registry.hs +++ /dev/null @@ -1,208 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} -module Lib.External.Registry where - -import Startlude hiding ( (<.>) - , Reader - , ask - , runReader - ) -import Startlude.ByteStream hiding ( count ) - -import Conduit -import Control.Algebra -import Control.Effect.Error -import Control.Effect.Lift -import Control.Effect.Reader.Labelled -import Control.Monad.Fail ( fail ) -import Control.Monad.Trans.Resource -import qualified Data.ByteString.Streaming.HTTP - as S -import qualified Data.HashMap.Strict as HM -import Data.Maybe ( fromJust ) -import Data.String.Interpolate.IsString -import Data.Yaml -import Network.HTTP.Client.Conduit ( Manager ) -import Network.HTTP.Simple -import System.Directory -import System.Process - -import Constants -import qualified Data.Aeson.Types ( parseEither ) -import Data.Time.ISO8601 ( parseISO8601 ) -import Lib.Algebra.State.RegistryUrl -import Lib.Error -import Lib.External.AppManifest -import Lib.SystemPaths -import Lib.Types.Core -import Lib.Types.Emver -import Lib.Types.ServerApp - -newtype AppIndexRes = AppIndexRes - { storeApps :: [StoreApp] } deriving (Eq, Show) - -newtype RegistryVersionForSpecRes = RegistryVersionForSpecRes - { registryVersionForSpec :: Maybe Version } deriving (Eq, Show) - -instance FromJSON RegistryVersionForSpecRes where - parseJSON Null = pure (RegistryVersionForSpecRes Nothing) - parseJSON (Object o) = do - registryVersionForSpec <- o .:? "version" - pure . RegistryVersionForSpecRes $ registryVersionForSpec - parseJSON _ = fail "expected null or object" - -tmpAgentFileName :: Text -tmpAgentFileName = "agent-tmp" - -agentFileName :: Text -agentFileName = "agent" - -userAgentHeader :: ByteString -userAgentHeader = [i|EmbassyOS/#{agentVersion}|] - -setUserAgent :: Request -> Request -setUserAgent = setRequestHeader "User-Agent" [userAgentHeader] - -getYoungAgentBinary :: (Has RegistryUrl sig m, HasLabelled "filesystemBase" (Reader Text) sig m, Has (Lift IO) sig m) - => VersionRange - -> m () -getYoungAgentBinary avs = do - base <- ask @"filesystemBase" - let tmpAgentPath = toS $ executablePath `relativeTo` base tmpAgentFileName - tmpExists <- sendIO $ doesPathExist tmpAgentPath - when tmpExists $ sendIO $ removeFile tmpAgentPath - url <- registryAppAgentUrl avs - request <- sendIO . fmap setUserAgent . parseRequestThrow $ toS url - sendIO $ runConduitRes $ httpSource request getResponseBody .| sinkFile tmpAgentPath - sendIO $ void $ readProcessWithExitCode "chmod" ["700", tmpAgentPath] "" - -getLifelineBinary :: (Has RegistryUrl sig m, HasFilesystemBase sig m, MonadIO m) => VersionRange -> m () -getLifelineBinary avs = do - base <- ask @"filesystemBase" - let lifelineTarget = lifelineBinaryPath `relativeTo` base - url <- registryUrl - request <- liftIO . fmap setUserAgent . parseRequestThrow $ toS (url "sys/lifeline?spec=" <> show avs) - liftIO $ runConduitRes $ httpSource request getResponseBody .| sinkFile (toS lifelineTarget) - liftIO $ void $ readProcessWithExitCode "chmod" ["700", toS lifelineTarget] "" - -getAppIndex :: (MonadIO m, Has (Error S9Error) sig m, Has RegistryUrl sig m) => m AppIndexRes -getAppIndex = do - manifestPath <- registryManifestUrl - req <- liftIO $ fmap setUserAgent . parseRequestThrow $ toS manifestPath - val <- (liftIO . try @SomeException) (httpBS req) >>= \case - Left _ -> throwError RegistryUnreachableE - Right a -> pure $ getResponseBody a - parseBsManifest val >>= \case - Left e -> throwError $ RegistryParseE manifestPath . toS $ e - Right a -> pure a - -getAppManifest :: (MonadIO m, Has (Error S9Error) sig m, Has RegistryUrl sig m) => AppId -> m AppManifest -getAppManifest appId = do - let path = "/apps/manifest/" <> unAppId appId - v <- registryRequest path - case Data.Aeson.Types.parseEither parseJSON v of - Left e -> throwError $ RegistryParseE path . toS $ e - Right a -> pure a - -getStoreAppInfo :: (MonadIO m, Has RegistryUrl sig m, Has (Error S9Error) sig m) => AppId -> m (Maybe StoreApp) -getStoreAppInfo name = find ((== name) . storeAppId) . storeApps <$> getAppIndex - -parseBsManifest :: Has RegistryUrl sig m => ByteString -> m (Either String AppIndexRes) -parseBsManifest bs = do - parseRegistryRes' <- parseRegistryRes - pure $ parseEither parseRegistryRes' . fromJust . decodeThrow $ bs - -parseRegistryRes :: Has RegistryUrl sig m => m (Value -> Parser AppIndexRes) -parseRegistryRes = do - parseAppData' <- parseAppData - pure $ withObject "app registry response" $ \obj -> do - let keyVals = HM.toList obj - let mManifestApps = fmap (\(k, v) -> parseMaybe (parseAppData' (AppId k)) v) keyVals - pure . AppIndexRes . catMaybes $ mManifestApps - -registryUrl :: (Has RegistryUrl sig m) => m Text -registryUrl = maybe "https://registry.start9labs.com:443" show <$> getRegistryUrl - -registryManifestUrl :: Has RegistryUrl sig m => m Text -registryManifestUrl = registryUrl <&> ( "apps") - -registryAppAgentUrl :: Has RegistryUrl sig m => VersionRange -> m Text -registryAppAgentUrl avs = registryUrl <&> ( ("sys/agent?spec=" <> show avs)) - -registryCheckVersionForSpecUrl :: Has RegistryUrl sig m => VersionRange -> m Text -registryCheckVersionForSpecUrl avs = registryUrl <&> ( ("sys/version/agent?spec=" <> show avs)) - -parseAppData :: Has RegistryUrl sig m => m (AppId -> Value -> Parser StoreApp) -parseAppData = do - url <- registryUrl - pure $ \storeAppId -> withObject "appmgr app data" $ \ad -> do - storeAppTitle <- ad .: "title" - storeAppDescriptionShort <- ad .: "description" >>= (.: "short") - storeAppDescriptionLong <- ad .: "description" >>= (.: "long") - storeAppIconUrl <- fmap (\typ -> toS $ url "icons" show storeAppId <.> typ) $ ad .: "icon-type" - storeAppVersions <- ad .: "version-info" >>= \case - [] -> fail "No Valid Version Info" - (x : xs) -> pure $ x :| xs - storeAppTimestamp <- ad .: "timestamp" >>= maybe (fail "Invalid ISO8601 Timestamp") pure . parseISO8601 - pure StoreApp { .. } - -getAppVersionForSpec :: (Has RegistryUrl sig m, Has (Error S9Error) sig m, MonadIO m) - => AppId - -> VersionRange - -> m Version -getAppVersionForSpec appId spec = do - let path = "apps/version" show appId <> "?spec=" <> show spec - val <- registryRequest path - parseOrThrow path val $ withObject "version response" $ \o -> do - v <- o .: "version" - pure v - -getLatestAgentVersion :: (Has RegistryUrl sig m, Has (Error S9Error) sig m, MonadIO m) => m (Version, Maybe Text) -getLatestAgentVersion = do - val <- registryRequest agentVersionPath - parseOrThrow agentVersionPath val $ withObject "version response" $ \o -> do - v <- o .: "version" - rn <- o .:? "release-notes" - pure (v, rn) - where agentVersionPath = "sys/version/agent" - -getLatestAgentVersionForSpec :: (Has RegistryUrl sig m, Has (Lift IO) sig m, Has (Error S9Error) sig m) - => VersionRange - -> m (Maybe Version) -getLatestAgentVersionForSpec avs = do - url <- registryUrl - req <- sendIO $ fmap setUserAgent . parseRequestThrow . toS $ url agentVersionPath - res <- fmap (first jsonToS9Exception) . sendIO $ try @JSONException $ parseRes req - case res of - Left e -> throwError e - Right a -> pure a - where - parseRes r = registryVersionForSpec . getResponseBody <$> httpJSON r - agentVersionPath = "sys/version/agent?spec=" <> show avs - jsonToS9Exception = RegistryParseE (toS agentVersionPath) . show - -getAmbassadorUiForSpec :: (Has RegistryUrl sig m, HasLabelled "httpManager" (Reader Manager) sig m, MonadResource m) - => VersionRange - -> ByteStream m () -getAmbassadorUiForSpec avs = do - url <- lift registryUrl - manager <- lift $ ask @"httpManager" - let target = url "sys/ambassador-ui.tar.gz?spec=" <> show avs - req <- liftResourceT $ lift $ fmap setUserAgent . parseRequestThrow . toS $ target - resp <- lift $ S.http req manager - getResponseBody resp - -registryRequest :: (Has RegistryUrl sig m, Has (Error S9Error) sig m, MonadIO m) => Text -> m Value -registryRequest path = do - url <- registryUrl - req <- liftIO . fmap setUserAgent . parseRequestThrow . toS $ url path - (liftIO . try @SomeException) (httpJSON req) >>= \case - Left _ -> throwError RegistryUnreachableE - Right a -> pure $ getResponseBody a - -parseOrThrow :: (Has (Error S9Error) sig m) => Text -> a -> (a -> Parser b) -> m b -parseOrThrow path val parser = case parseEither parser val of - Left e -> throwError (RegistryParseE path $ toS e) - Right a -> pure a diff --git a/agent/src/Lib/External/Specs/CPU.hs b/agent/src/Lib/External/Specs/CPU.hs deleted file mode 100644 index afd2d1930..000000000 --- a/agent/src/Lib/External/Specs/CPU.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -module Lib.External.Specs.CPU - ( getCpuInfo - ) -where - -import Startlude -import Protolude.Unsafe ( unsafeFromJust ) - -import Data.String.Interpolate.IsString -import System.Process - -import Lib.External.Specs.Common - -lscpu :: IO Text -lscpu = toS <$> readProcess "lscpu" [] "" - -getModelName :: Text -> Text -getModelName = unsafeFromJust . getSpec "Model name" - -getCores :: Text -> Text -getCores = unsafeFromJust . getSpec "CPU(s)" - -getClockSpeed :: Text -> Text -getClockSpeed = (<> "MHz") . unsafeFromJust . getSpec "CPU max" - -getCpuInfo :: IO Text -getCpuInfo = lscpu <&> do - model <- getModelName - cores <- getCores - clock <- getClockSpeed - pure $ [i|#{model}: #{cores} cores @ #{clock}|] diff --git a/agent/src/Lib/External/Specs/Common.hs b/agent/src/Lib/External/Specs/Common.hs deleted file mode 100644 index df68ab37d..000000000 --- a/agent/src/Lib/External/Specs/Common.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Lib.External.Specs.Common where - -import Startlude - -import qualified Data.Text as T - -getSpec :: Text -> Text -> Maybe Text -getSpec spec output = do - mi <- modelItem - fmap T.strip $ T.splitOn ":" mi `atMay` 1 - where - items = lines output - modelItem = find (spec `T.isPrefixOf`) items diff --git a/agent/src/Lib/External/Specs/Memory.hs b/agent/src/Lib/External/Specs/Memory.hs deleted file mode 100644 index 0bfc20a17..000000000 --- a/agent/src/Lib/External/Specs/Memory.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Lib.External.Specs.Memory where - -import Startlude -import Protolude.Unsafe ( unsafeFromJust ) - -import Lib.External.Specs.Common - -catMem :: IO Text -catMem = readFile "/proc/meminfo" - -getMem :: IO Text -getMem = unsafeFromJust . getSpec "MemTotal" <$> catMem diff --git a/agent/src/Lib/External/Util.hs b/agent/src/Lib/External/Util.hs deleted file mode 100644 index c4cc91223..000000000 --- a/agent/src/Lib/External/Util.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE TupleSections #-} -module Lib.External.Util where - -import Startlude - -getLineByHeader :: Text -> [Text] -> Maybe Text -getLineByHeader t = find (isPrefixOf (toS t :: String) . toS) - -truncateTo :: RealFloat a => Int -> a -> Double -truncateTo n x = realToFrac $ fromIntegral (floor (x * t) :: Integer) / t where t = 10 ^ n - -truncateToS :: Int -> Double -> Double -truncateToS n x = fromIntegral (floor (x * t) :: Integer) / t where t = 10 ^ n - -parseToPair :: (Text -> Maybe a) -> [Text] -> Maybe (Text, a) -parseToPair parse (k : v : _) = ((k, ) <$> parse v) <|> ((v, ) <$> parse k) -parseToPair _ _ = Nothing diff --git a/agent/src/Lib/External/WpaSupplicant.hs b/agent/src/Lib/External/WpaSupplicant.hs deleted file mode 100644 index 1e961eab2..000000000 --- a/agent/src/Lib/External/WpaSupplicant.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -module Lib.External.WpaSupplicant where - -import Startlude - -import Data.Bitraversable -import qualified Data.HashMap.Strict as HM -import Data.String.Interpolate.IsString -import qualified Data.Text as T -import System.Process -import Control.Concurrent.Async.Lifted - as LAsync -import Control.Monad.Trans.Control ( MonadBaseControl ) - -runWlan0 :: ReaderT Text m a -> m a -runWlan0 = flip runReaderT "wlan0" - -isConnectedToEthernet :: MonadIO m => m Bool -isConnectedToEthernet = do - liftIO $ not . null . filter (T.isInfixOf "inet ") . lines . toS <$> readProcess "ifconfig" ["eth0"] "" - --- There be bug here: if you're in the US, and add a network in Sweden, you'll set your wpa supplicant to be looking for networks in Sweden. --- so you won't be autoconnecting to anything in the US till you add another US guy. -addNetwork :: MonadIO m => Text -> Text -> Text -> ReaderT Interface m () -addNetwork ssid psk country = do - interface <- ask - networkId <- checkNetwork ssid >>= \case - -- If the network already exists, we will update its password. - Just nId -> do - void . liftIO $ readProcess "wpa_cli" ["-i", toS interface, "new_password", toS nId, [i|"#{psk}"|]] "" - pure nId - - -- Otherwise we create the network in the wpa_supplicant - Nothing -> do - nId <- liftIO $ T.strip . toS <$> readProcess "wpa_cli" ["-i", toS interface, "add_network"] "" - void . liftIO $ readProcess "wpa_cli" - ["-i", toS interface, "set_network", toS nId, "ssid", [i|"#{ssid}"|]] - "" - void . liftIO $ readProcess "wpa_cli" ["-i", toS interface, "set_network", toS nId, "psk", [i|"#{psk}"|]] "" - void . liftIO $ readProcess "wpa_cli" ["-i", toS interface, "set_network", toS nId, "scan_ssid", "1"] "" - pure nId - - void . liftIO $ readProcess "wpa_cli" ["-i", toS interface, "set", "country", toS country] "" - void . liftIO $ readProcess "wpa_cli" ["-i", toS interface, "enable_network", toS networkId] "" - void . liftIO $ readProcess "wpa_cli" ["-i", toS interface, "save_config"] "" - -removeNetwork :: MonadIO m => Text -> ReaderT Interface m () -removeNetwork ssid = do - interface <- ask - checkNetwork ssid >>= \case - Nothing -> pure () - Just x -> liftIO $ do - void $ readProcess "wpa_cli" ["-i", toS interface, "remove_network", [i|#{x}|]] "" - void $ readProcess "wpa_cli" ["-i", toS interface, "save_config"] "" - void $ readProcess "wpa_cli" ["-i", toS interface, "reconfigure"] "" - -listNetworks :: MonadIO m => ReaderT Interface m [Text] -listNetworks = do - interface <- ask - liftIO $ mapMaybe (`atMay` 1) . drop 1 . fmap (T.splitOn "\t") . lines . toS <$> readProcess - "wpa_cli" - ["-i", toS interface, "list_networks"] - "" - -type Interface = Text -getCurrentNetwork :: (MonadBaseControl IO m, MonadIO m) => ReaderT Interface m (Maybe Text) -getCurrentNetwork = do - interface <- ask @Text - liftIO $ guarded (/= "") . T.init . toS <$> readProcess "iwgetid" [toS interface, "--raw"] "" - -selectNetwork :: (MonadBaseControl IO m, MonadIO m) => Text -> Text -> ReaderT Interface m Bool -selectNetwork ssid country = checkNetwork ssid >>= \case - Nothing -> putStrLn @Text "SSID Not Found" *> pure False - Just nId -> do - interface <- ask - void . liftIO $ readProcess "wpa_cli" ["-i", toS interface, "select_network", toS nId] "" - void . liftIO $ readProcess "wpa_cli" ["-i", toS interface, "set", "country", toS country] "" - void . liftIO $ readProcess "wpa_cli" ["-i", toS interface, "save_config"] "" - mNew <- join . hush <$> LAsync.race (liftIO $ threadDelay 20_000_000) - (runMaybeT . asum $ repeat (MaybeT getCurrentNetwork)) - listNetworks >>= \nets -> - for_ nets $ \net -> liftIO $ readProcess "wpa_cli" ["-i", toS interface, "enable_network", toS net] "" - pure $ case mNew of - Nothing -> False - Just newCurrent -> newCurrent == ssid - -type NetworkId = Text -checkNetwork :: MonadIO m => Text -> ReaderT Interface m (Maybe NetworkId) -checkNetwork ssid = do - interface <- ask - HM.lookup ssid - . HM.fromList - . mapMaybe (bisequenceA . ((`atMay` 1) &&& (`atMay` 0))) - . drop 1 - . fmap (T.splitOn "\t") - . lines - . toS - <$> liftIO (readProcess "wpa_cli" ["-i", toS interface, "list_networks"] "") - --- TODO: Live Testing in GHCI -runWpa :: ReaderT Interface m a -> m a -runWpa = flip runReaderT "wlp5s0" diff --git a/agent/src/Lib/IconCache.hs b/agent/src/Lib/IconCache.hs deleted file mode 100644 index a0685aafb..000000000 --- a/agent/src/Lib/IconCache.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -module Lib.IconCache where - -import Startlude hiding ( ask - , catch - , throwIO - , Reader - ) - -import Conduit -import Control.Concurrent.STM.TVar -import Control.Effect.Reader.Labelled -import Crypto.Hash -import qualified Data.Conduit.Binary as CB -import qualified Data.HashMap.Strict as HM -import Data.String.Interpolate.IsString -import Network.HTTP.Simple -import System.Directory -import System.FilePath -import System.IO.Error -import UnliftIO.Exception - -import Lib.Error -import Lib.SystemPaths hiding ( () ) -import Lib.Types.Core -import Database.Persist.Sql ( runSqlPool - , repsert - , ConnectionPool - , delete - ) -import Model -import Control.Effect.Error -import Crypto.Hash.Conduit ( hashFile ) -import Util.File ( removeFileIfExists ) - -type HasIconTags sig m = HasLabelled "iconTagCache" (Reader (TVar (HM.HashMap AppId (Digest MD5)))) sig m - -findIcon :: (HasFilesystemBase sig m, MonadIO m) => AppId -> m (Maybe FilePath) -findIcon appId = do - bp <- toS <$> getAbsoluteLocationFor iconBasePath - icons <- liftIO $ (listDirectory bp) `catch` \(e :: IOException) -> - if isDoesNotExistError e then createDirectoryIfMissing True bp *> pure [] else throwIO e - pure $ (bp ) <$> find ((show appId ==) . takeBaseName) icons - -saveIcon :: ( HasFilesystemBase sig m - , HasIconTags sig m - , HasLabelled "databaseConnection" (Reader ConnectionPool) sig m - , Has (Error S9Error) sig m - , MonadIO m - ) - => String - -> m () -saveIcon url = do - bp <- toS <$> getAbsoluteLocationFor iconBasePath - req <- case parseRequest url of - Nothing -> throwError $ RegistryParseE (toS url) "invalid url" - Just x -> pure x - let saveAction = runConduit $ httpSource req getResponseBody .| CB.sinkFileCautious (bp takeFileName url) - liftIO $ runResourceT $ saveAction `catch` \(e :: IOException) -> if isDoesNotExistError e - then do - liftIO $ createDirectoryIfMissing True bp - saveAction - else throwIO e - tag <- hashFile (bp takeFileName url) - saveTag (AppId . toS $ takeFileName url) tag - -saveTag :: (HasIconTags sig m, HasLabelled "databaseConnection" (Reader ConnectionPool) sig m, MonadIO m) - => AppId - -> Digest MD5 - -> m () -saveTag appId tag = do - cache <- ask @"iconTagCache" - pool <- ask @"databaseConnection" - liftIO $ runSqlPool (repsert (IconDigestKey appId) (IconDigest tag)) pool `catch` \(e :: SomeException) -> - putStrLn @Text [i|Icon Cache Insertion Failed!: #{appId}, #{tag}, #{e}|] - liftIO $ atomically $ modifyTVar cache $ HM.insert appId tag - -clearIcon :: ( MonadIO m - , HasLabelled "iconTagCache" (Reader (TVar (HM.HashMap AppId v0))) sig m - , HasLabelled "databaseConnection" (Reader ConnectionPool) sig m - , HasLabelled "filesystemBase" (Reader Text) sig m - ) - => AppId - -> m () -clearIcon appId = do - db <- ask @"databaseConnection" - iconTags <- ask @"iconTagCache" - liftIO . atomically $ modifyTVar iconTags (HM.delete appId) - liftIO $ runSqlPool (delete (IconDigestKey appId)) db - findIcon appId >>= \case - Nothing -> pure () - Just x -> removeFileIfExists x diff --git a/agent/src/Lib/Metrics.hs b/agent/src/Lib/Metrics.hs deleted file mode 100644 index 21eac32db..000000000 --- a/agent/src/Lib/Metrics.hs +++ /dev/null @@ -1,158 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - -module Lib.Metrics where - -import Startlude - -import Data.Aeson -import Data.IORef - -import Foundation -import Lib.Error -import Lib.External.Metrics.Df -import Lib.External.Metrics.Iotop -import Lib.External.Metrics.ProcDev -import Lib.External.Metrics.Temperature -import Lib.External.Metrics.Top -import Lib.External.Metrics.Types - --- will throw only if one of '$ top', '$ iotop, '$ procDev' commands fails on the command line. -getServerMetrics :: MonadIO m => AgentCtx -> S9ErrT m ServerMetrics -getServerMetrics agentCtx = do - temp <- getTemperature - df <- getDfMetrics - top <- getTopMetrics - iotop <- getIotopMetrics - (_, _, procDev) <- liftIO . readIORef . appProcDevMomentCache $ agentCtx - - pure $ fromCommandLineMetrics (temp, df, top, iotop, procDev) - -data ServerMetrics = ServerMetrics - { serverMetricsTemperature :: Maybe Celsius - - , serverMetricMemPercentageUsed :: Maybe Percentage - , serverMetricMemFree :: Maybe MebiBytes - , serverMetricMemUsed :: Maybe MebiBytes - , serverMetricSwapTotal :: Maybe MebiBytes - , serverMetricSwapUsed :: Maybe MebiBytes - - , serverMetricCpuIdle :: Maybe Percentage - , serverMetricCpuUserSpace :: Maybe Percentage - , serverMetricWait :: Maybe Percentage - , serverMetricCpuPercentageUsed :: Maybe Percentage - - , serverMetricCurrentRead :: Maybe BytesPerSecond - , serverMetricCurrentWrite :: Maybe BytesPerSecond - , serverMetricTotalRead :: Maybe BytesPerSecond - , serverMetricTotalWrite :: Maybe BytesPerSecond - - , serverMetricRBytesPerSecond :: Maybe BytesPerSecond - , serverMetricRPacketsPerSecond :: Maybe BytesPerSecond - , serverMetricRErrorsPerSecond :: Maybe BytesPerSecond - , serverMetricTBytesPerSecond :: Maybe BytesPerSecond - , serverMetricTPacketsPerSecond :: Maybe BytesPerSecond - , serverMetricTErrorsPerSecond :: Maybe BytesPerSecond - - , serverMetricDiskSize :: Maybe Gigabytes - , serverMetricDiskUsed :: Maybe Gigabytes - , serverMetricDiskAvailable :: Maybe Gigabytes - , serverMetricDiskUsedPercentage :: Maybe Percentage - } deriving (Eq, Show) - -instance ToJSON ServerMetrics where - toJSON ServerMetrics {..} = object - [ "GENERAL" .= object ["Temperature" .= serverMetricsTemperature] - , "MEMORY" .= object - [ "Percent Used" .= serverMetricMemPercentageUsed - , "Free" .= serverMetricMemFree - , "Used" .= serverMetricMemUsed - , "Swap Used" .= serverMetricSwapUsed - , "Swap Free" .= serverMetricSwapTotal ?-? serverMetricSwapUsed - ] - , "CPU" .= object - [ "Percent Used" .= serverMetricCpuPercentageUsed - , "Percent Free" .= serverMetricCpuIdle - , "Percent User Space" .= serverMetricCpuUserSpace - , "Percent IO Wait" .= serverMetricWait - ] - , "DISK" .= object - [ "Percent Used" .= serverMetricDiskUsedPercentage - , "Size" .= serverMetricDiskSize - , "Used" .= serverMetricDiskUsed - , "Free" .= serverMetricDiskAvailable - , "Total Read" .= serverMetricTotalRead - , "Total Write" .= serverMetricTotalWrite - , "Current Read" .= serverMetricCurrentRead - , "Current Write" .= serverMetricCurrentWrite - ] - , "NETWORK" .= object - [ "Bytes Received" .= serverMetricRBytesPerSecond - , "Packets Received" .= serverMetricRPacketsPerSecond - , "Errors Received" .= serverMetricRErrorsPerSecond - , "Bytes Transmitted" .= serverMetricTBytesPerSecond - , "Packets Transmitted" .= serverMetricTPacketsPerSecond - , "Errors Transmitted" .= serverMetricTErrorsPerSecond - ] - ] - toEncoding ServerMetrics {..} = (pairs . fold) - [ "GENERAL" .= object ["Temperature" .= serverMetricsTemperature] - , "MEMORY" .= object - [ "Percent Used" .= serverMetricMemPercentageUsed - , "Free" .= serverMetricMemFree - , "Used" .= serverMetricMemUsed - , "Swap Used" .= serverMetricSwapUsed - , "Swap Free" .= serverMetricSwapTotal ?-? serverMetricSwapUsed - ] - , "CPU" .= object - [ "Percent Used" .= serverMetricCpuPercentageUsed - , "Percent Free" .= serverMetricCpuIdle - , "Percent User Space" .= serverMetricCpuUserSpace - , "Percent IO Wait" .= serverMetricWait - ] - , "DISK" .= object - [ "Percent Used" .= serverMetricDiskUsedPercentage - , "Size" .= serverMetricDiskSize - , "Used" .= serverMetricDiskUsed - , "Free" .= serverMetricDiskAvailable - , "Total Read" .= serverMetricTotalRead - , "Total Write" .= serverMetricTotalWrite - , "Current Read" .= serverMetricCurrentRead - , "Current Write" .= serverMetricCurrentWrite - ] - , "NETWORK" .= object - [ "Bytes Received" .= serverMetricRBytesPerSecond - , "Packets Received" .= serverMetricRPacketsPerSecond - , "Errors Received" .= serverMetricRErrorsPerSecond - , "Bytes Transmitted" .= serverMetricTBytesPerSecond - , "Packets Transmitted" .= serverMetricTPacketsPerSecond - , "Errors Transmitted" .= serverMetricTErrorsPerSecond - ] - ] - -fromCommandLineMetrics :: (Maybe Celsius, DfMetrics, TopMetrics, IotopMetrics, ProcDevMetrics) -> ServerMetrics -fromCommandLineMetrics (temp, DfMetrics {..}, TopMetrics {..}, IotopMetrics {..}, ProcDevMetrics {..}) = ServerMetrics - { serverMetricsTemperature = temp - , serverMetricMemPercentageUsed = metricMemPercentageUsed - , serverMetricMemFree = metricMemFree - , serverMetricMemUsed = metricMemUsed - , serverMetricSwapTotal = metricSwapTotal - , serverMetricSwapUsed = metricSwapUsed - , serverMetricCpuIdle = metricCpuIdle - , serverMetricCpuUserSpace = metricCpuUserSpace - , serverMetricWait = metricWait - , serverMetricCpuPercentageUsed = metricCpuPercentageUsed - , serverMetricCurrentRead = metricCurrentRead - , serverMetricCurrentWrite = metricCurrentWrite - , serverMetricTotalRead = metricTotalRead - , serverMetricTotalWrite = metricTotalWrite - , serverMetricRBytesPerSecond = metricRBytesPerSecond - , serverMetricRPacketsPerSecond = metricRPacketsPerSecond - , serverMetricRErrorsPerSecond = metricRErrorsPerSecond - , serverMetricTBytesPerSecond = metricTBytesPerSecond - , serverMetricTPacketsPerSecond = metricTPacketsPerSecond - , serverMetricTErrorsPerSecond = metricTErrorsPerSecond - , serverMetricDiskSize = metricDiskSize - , serverMetricDiskUsed = metricDiskUsed - , serverMetricDiskAvailable = metricDiskAvailable - , serverMetricDiskUsedPercentage = metricDiskUsedPercentage - } diff --git a/agent/src/Lib/Migration.hs b/agent/src/Lib/Migration.hs deleted file mode 100644 index f6585c3a8..000000000 --- a/agent/src/Lib/Migration.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} - -module Lib.Migration where - -import Data.Aeson -import Data.Aeson.Types -import Data.FileEmbed -import Data.Text ( split - , splitOn - , strip - ) -import Database.Persist.Sql -import Lib.Error -import Lib.Types.Emver -import Model -import Startlude - -ioMigrationDbVersion :: ConnectionPool -> Version -> Version -> IO () -ioMigrationDbVersion dbConn sourceVersion targetVersion = do - putStrLn @Text $ "Executing migrations from " <> show sourceVersion <> " to " <> show targetVersion - runSqlPool (migrateDbVersions sourceVersion targetVersion & handleS9ErrNuclear) dbConn - -getCurrentDbVersion :: MonadIO m => ReaderT SqlBackend m (Maybe Version) -getCurrentDbVersion = - fmap (executedMigrationTgtVersion . entityVal) <$> selectFirst [] [Desc ExecutedMigrationCreatedAt] - -getMigrations :: [MigrationFile] -getMigrations = mapMaybe toMigrationFile $(embedDir "./migrations") - -migrateDbVersions :: MonadIO m => Version -> Version -> S9ErrT (ReaderT SqlBackend m) () -migrateDbVersions sourceVersion targetVersion = case mkMigrationCollection sourceVersion targetVersion getMigrations of - Just (MigrationCollection migrations) -> lift $ traverse executeMigration migrations $> () - Nothing -> - throwE . PersistentE $ "No path of migrations from " <> show sourceVersion <> " to " <> show targetVersion - -executeMigration :: MonadIO m => MigrationFile -> ReaderT SqlBackend m () -executeMigration mf = migrateSql mf >> insertMigration mf $> () - -insertMigration :: MonadIO m => MigrationFile -> ReaderT SqlBackend m (Key ExecutedMigration) -insertMigration (MigrationFile source target _) = do - now <- liftIO getCurrentTime - fmap entityKey . insertEntity $ ExecutedMigration now now source target - -migrateSql :: MonadIO m => MigrationFile -> ReaderT SqlBackend m () -migrateSql MigrationFile { sqlContent } = do - print sqlContent' - traverse_ runIt sqlContent' - where - runIt = liftA2 (*>) (liftIO . putStrLn) $ flip (rawSql @(Single Int)) [] . (<> ";") . strip - sqlContent' = filter (/= "") . fmap strip . split (== ';') $ decodeUtf8 sqlContent - -toMigrationFile :: (FilePath, ByteString) -> Maybe MigrationFile -toMigrationFile (fp, bs) = case splitOn "::" (toS fp) of - [source, target] -> do - sourceVersion <- parseMaybe parseJSON $ String source - targetVersion <- parseMaybe parseJSON $ String target - let sqlContent = bs - pure MigrationFile { .. } - _ -> Nothing - -newtype MigrationCollection = MigrationCollection { unMigrations :: [MigrationFile] } deriving (Eq, Show) -mkMigrationCollection :: Version -> Version -> [MigrationFile] -> Maybe MigrationCollection -mkMigrationCollection source target migrations - | null migrations - = Nothing - | source == target - = Just $ MigrationCollection [] - | otherwise - = let mNext = maximumByMay targetVersion $ filter - (\m -> sourceVersion m == source && targetVersion m > source && targetVersion m <= target) - migrations - in case mNext of - Nothing -> Nothing - Just nextMig -> - MigrationCollection - . (nextMig :) - . unMigrations - <$> mkMigrationCollection (targetVersion nextMig) target migrations - where - maximumByMay :: (Foldable t, Ord b) => (a -> b) -> t a -> Maybe a - maximumByMay f as = - let reducer x acc = case acc of - Nothing -> Just x - Just y -> if f x > f y then Just x else Just y - in foldr reducer Nothing as - -data MigrationFile = MigrationFile - { sourceVersion :: Version - , targetVersion :: Version - , sqlContent :: ByteString - } - deriving (Eq, Show) diff --git a/agent/src/Lib/Notifications.hs b/agent/src/Lib/Notifications.hs deleted file mode 100644 index 0ee484f51..000000000 --- a/agent/src/Lib/Notifications.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -module Lib.Notifications where - -import Startlude hiding ( get ) - -import Data.String.Interpolate.IsString -import Data.UUID.V4 -import Database.Persist -import Database.Persist.Sql - -import Lib.Error -import Lib.Types.Core -import Lib.Types.Emver -import Model - -emit :: MonadIO m => AppId -> Version -> AgentNotification -> SqlPersistT m (Entity Notification) -emit appId version ty = do - uuid <- liftIO nextRandom - now <- liftIO getCurrentTime - let k = NotificationKey uuid - let v = Notification now Nothing appId version (toCode ty) (toTitle ty) (toMessage appId version ty) - insertKey k v - putStrLn $ toMessage appId version ty - pure $ Entity k v - -archive :: MonadIO m => [Key Notification] -> SqlPersistT m [Entity Notification] -archive eventIds = do - now <- liftIO getCurrentTime - events <- for eventIds $ flip updateGet [NotificationArchivedAt =. Just now] - pure $ zipWith Entity eventIds events - -data AgentNotification = - InstallSuccess - | InstallFailedGetApp - | InstallFailedAppMgrExitCode Int - | InstallFailedS9Error S9Error - | BackupSucceeded - | BackupFailed S9Error - | RestoreSucceeded - | RestoreFailed S9Error - | RestartFailed S9Error - | DockerFuckening - | CertRenewFailed ExitCode String String - | OsUpdateSucceeded - | OsUpdateFailed Text - --- CODES --- RULES: --- The first digit indicates the call to action and the tone of the error code as follows --- 0: General Information, No Action Required, Neutral Tone --- 1: Success Message, No Action Required, Positive Tone --- 2: Warning, Action Possible but NOT Required, Negative Tone --- 3: Error, Action Required, Negative Tone --- --- The second digit indicates where the error was originated from as follows --- 0: Originates from Agent --- 1: Originates from App (Not presently used) --- 2: Originates from Agent ABOUT THE AGENT --- --- The remaining section of the code may be as long as you want but must be at least one digit --- EXAMPLES: --- 100 --- |||> Code "0" --- ||> Originates from Agent --- |> Success Message --- --- 213 --- |||> Code "3" --- ||> Originates from App --- |> Warning Message --- -toCode :: AgentNotification -> Text -toCode InstallSuccess = "100" -toCode BackupSucceeded = "101" -toCode RestoreSucceeded = "102" -toCode OsUpdateSucceeded = "103" -toCode InstallFailedGetApp = "300" -toCode (InstallFailedAppMgrExitCode _) = "301" -toCode DockerFuckening = "302" -toCode (InstallFailedS9Error _) = "303" -toCode (BackupFailed _) = "304" -toCode (RestoreFailed _) = "305" -toCode (RestartFailed _) = "306" -toCode CertRenewFailed{} = "320" - -toTitle :: AgentNotification -> Text -toTitle InstallSuccess = "Install succeeded" -toTitle BackupSucceeded = "Backup succeeded" -toTitle RestoreSucceeded = "Restore succeeded" -toTitle OsUpdateSucceeded = "EmbassyOS Update Succeeded" -toTitle InstallFailedGetApp = "Install failed" -toTitle (InstallFailedAppMgrExitCode _) = "Install failed" -toTitle (InstallFailedS9Error _) = "Install failed" -toTitle (BackupFailed _) = "Backup failed" -toTitle (RestoreFailed _) = "Restore failed" -toTitle (RestartFailed _) = "Restart failed" -toTitle DockerFuckening = "App unstoppable" -toTitle CertRenewFailed{} = "Embassy Certificate Renewal Failed" - -toMessage :: AppId -> Version -> AgentNotification -> Text -toMessage appId version InstallSuccess = [i|Successfully installed #{appId} at version #{version}|] -toMessage appId version n@InstallFailedGetApp = - [i|Failed to install #{appId} at version #{version}, this should be impossible, contact support and give them the code #{toCode n}|] -toMessage appId version n@(InstallFailedAppMgrExitCode ec) - = [i|Failed to install #{appId} at version #{version}, many things could cause this, contact support and give them the code #{toCode n}.#{ec}|] -toMessage appId version n@(InstallFailedS9Error e) - = [i|Failed to install #{appId} at version #{version}, the dependency reverse index could not be updated, contact support and give them the code #{toCode n}.#{errorCode $ toError e}|] -toMessage appId _version DockerFuckening - = [i|Despite attempting to stop #{appId}, it is still running. This is a known issue that can only be solved by restarting the server|] -toMessage appId _version BackupSucceeded = [i|Successfully backed up #{appId}|] -toMessage appId _version RestoreSucceeded = [i|Successfully restored #{appId}|] -toMessage appId _version (BackupFailed reason) = [i|Failed to back up #{appId}: #{errorMessage $ toError reason}|] -toMessage appId _version (RestoreFailed reason) = [i|Failed to restore #{appId}: #{errorMessage $ toError reason}|] -toMessage appId _version (RestartFailed reason) = - [i|Failed to restart #{appId}: #{errorMessage $ toError reason}. Please manually restart|] -toMessage _ version (CertRenewFailed ec o e) = [i|Failed to renew SSL Certificates for EmbassyOS (#{version}) -ExitCode: #{ec} -Stdout: -#{o} -Stderr: -#{e} -|] -toMessage _ version OsUpdateSucceeded = [i|The update to EmbassyOS #{version} succeeded.|] diff --git a/agent/src/Lib/Password.hs b/agent/src/Lib/Password.hs deleted file mode 100644 index 9d3cc6454..000000000 --- a/agent/src/Lib/Password.hs +++ /dev/null @@ -1,77 +0,0 @@ -module Lib.Password where - -import Startlude -import Yesod.Auth.Util.PasswordStore ( makePassword - , verifyPassword - , passwordStrength - ) -import qualified Data.ByteString.Char8 as BS - ( pack - , unpack - ) -import Data.Text ( pack - , unpack - ) - -import Model - --- Root account identifier -rootAccountName :: Text -rootAccountName = "embassy-root" - - --- | Default strength used for passwords (see "Yesod.Auth.Util.PasswordStore" --- for details). -defaultStrength :: Int -defaultStrength = 17 - --- | The type representing account information stored in the database should --- be an instance of this class. It just provides the getter and setter --- used by the functions in this module. -class HasPasswordHash account where - getPasswordHash :: account -> Text - setPasswordHash :: Text -> account -> account - - {-# MINIMAL getPasswordHash, setPasswordHash #-} - - --- | Calculate a new-style password hash using "Yesod.Auth.Util.PasswordStore". -passwordHash :: MonadIO m => Int -> Text -> m Text -passwordHash strength pwd = do - h <- liftIO $ makePassword (BS.pack $ unpack pwd) strength - return $ pack $ BS.unpack h - --- | Set password for account, using the given strength setting. Use this --- function, or 'setPassword', to produce a account record containing the --- hashed password. Unlike previous versions of this module, no separate --- salt field is required for new passwords (but it may still be required --- for compatibility while old password hashes remain in the database). --- --- This function does not change the database; the calling application --- is responsible for saving the data which is returned. -setPasswordStrength :: (MonadIO m, HasPasswordHash account) => Int -> Text -> account -> m account -setPasswordStrength strength pwd u = do - hashed <- passwordHash strength pwd - return $ setPasswordHash hashed u - --- | As 'setPasswordStrength', but using the 'defaultStrength' -setPassword :: (MonadIO m, HasPasswordHash account) => Text -> account -> m account -setPassword = setPasswordStrength defaultStrength - -validatePass :: HasPasswordHash u => u -> Text -> Bool -validatePass account password = do - let h = getPasswordHash account - -- NB plaintext password characters are truncated to 8 bits here, - -- and also in passwordHash above (the hash is already 8 bit). - -- This is for historical compatibility, but in practice it is - -- unlikely to reduce the entropy of most users' alphabets by much. - let hash' = BS.pack $ unpack h - password' = BS.pack $ unpack password - if passwordStrength hash' > 0 - -- Will give >0 for valid hash format, else treat as if wrong password - then verifyPassword password' hash' - else False - -instance HasPasswordHash Account where - getPasswordHash = accountPassword - setPasswordHash h u = u { accountPassword = h } diff --git a/agent/src/Lib/ProductKey.hs b/agent/src/Lib/ProductKey.hs deleted file mode 100644 index 729197e9f..000000000 --- a/agent/src/Lib/ProductKey.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Lib.ProductKey where - -import Startlude -import Protolude.Unsafe ( unsafeHead ) - -import System.FilePath - -productKeyPath :: FilePath -> FilePath -productKeyPath rt = rt "root/agent/product_key" - -getProductKey :: Text -> IO Text -getProductKey rt = unsafeHead . lines <$> readFile (productKeyPath $ toS rt) diff --git a/agent/src/Lib/SelfUpdate.hs b/agent/src/Lib/SelfUpdate.hs deleted file mode 100644 index 505f799af..000000000 --- a/agent/src/Lib/SelfUpdate.hs +++ /dev/null @@ -1,239 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -module Lib.SelfUpdate where - -import Startlude hiding ( handle - , runReader - ) - -import Control.Carrier.Error.Either -import Control.Lens -import Data.Aeson -import qualified Data.ByteString.Char8 as B8 -import Data.IORef -import Data.List -import Data.String.Interpolate.IsString -import System.Posix.Files -import System.Process - -import Constants -import Database.Persist.Sqlite ( runSqlPool ) -import Foundation -import Handler.Types.V0.Base -import Lib.Algebra.State.RegistryUrl -import Lib.Error -import Lib.External.Registry -import qualified Lib.Notifications as Notifications -import Lib.Sound as Sound -import Lib.Synchronizers -import Lib.SystemPaths -import Lib.Types.Core -import Lib.Types.Emver -import Lib.WebServer -import Settings -import UnliftIO.Exception ( handle ) - -youngAgentPort :: Word16 -youngAgentPort = 5960 - -waitForUpdateSignal :: AgentCtx -> IO () -waitForUpdateSignal foundation = do - eNewVersion <- runS9ErrT $ do - spec <- lift . takeMVar . appSelfUpdateSpecification $ foundation - let settings = appSettings foundation - v <- interp settings (getLatestAgentVersionForSpec spec) >>= \case - Nothing -> throwE $ UpdateSelfE GetLatestCompliantVersion "Not Found" - Just v -> pure v - liftIO $ writeIORef (appIsUpdating foundation) (Just v) - updateAgent foundation spec - case eNewVersion of - Right (newVersion, youngAgentProcess) -> do - putStrLn @Text $ "New agent up and running: " <> show newVersion - runReaderT replaceExecutableWithYoungAgent (appSettings foundation) - killYoungAgent youngAgentProcess - shutdownAll [] - Left e@(UpdateSelfE GetYoungAgentBinary _) -> do - logerror e - writeIORef (appIsUpdating foundation) Nothing - waitForNextUpdateSignal - Left e@(UpdateSelfE ShutdownWeb _) -> do - logerror e - writeIORef (appIsUpdating foundation) Nothing - waitForNextUpdateSignal - Left e@(UpdateSelfE StartupYoungAgent _) -> do - logerror e - writeIORef (appIsUpdating foundation) Nothing - waitForNextUpdateSignal - Left e@(UpdateSelfE (PingYoungAgent youngAgentProcess) _) -> do - logerror e - killYoungAgent youngAgentProcess - writeIORef (appIsUpdating foundation) Nothing - waitForNextUpdateSignal - Left e -> do -- unreachable - logerror e - waitForNextUpdateSignal - where - waitForNextUpdateSignal = waitForUpdateSignal foundation - logerror = putStrLn @Text . show - interp s = ExceptT . liftIO . runError . injectFilesystemBaseFromContext s . runRegistryUrlIOC - - -updateAgent :: AgentCtx -> VersionRange -> S9ErrT IO (Version, ProcessHandle) -updateAgent foundation avs = do - -- get and save the binary of the new agent app - putStrLn @Text $ "Acquiring young agent binary for specification: " <> show avs - (tryTo . interp settings . getYoungAgentBinary $ avs) >>= \case - Left e -> throwE $ UpdateSelfE GetYoungAgentBinary (show e) - Right _ -> putStrLn @Text "Succeeded" - - -- start the new agent app. This is non blocking as a success would block indefinitely - startupYoungAgentProcessHandle <- startup 5 - - putStrLn @Text $ "Beginning young agent ping attempts..." - let attemptPing = do - lift (threadDelay delayBetweenAttempts) - tryTo pingYoungAgent >>= \case - Left e -> do - putStrLn @Text (show e) - pure (Left e) - x -> pure x - retryAction attempts attemptPing >>= \case - Left e -> throwE $ UpdateSelfE (PingYoungAgent startupYoungAgentProcessHandle) (show e) - Right av -> putStrLn @Text "Succeeded" >> pure (av, startupYoungAgentProcessHandle) - where - tryTo = lift . try @SomeException - settings = appSettings foundation - attempts = 8 - delayBetweenAttempts = 5 * 1000000 :: Int -- 5 seconds - startup :: Int -> S9ErrT IO ProcessHandle - startup startupAttempts = do - putStrLn @Text $ "Starting up young agent..." - tryTo (runReaderT startupYoungAgent $ appSettings foundation) >>= \case - Left e -> if "busy" `isInfixOf` show e && startupAttempts > 0-- sometimes the file handle hasn't closed yet - then do - putStrLn @Text "agent-tmp busy, reattempting in 500ms" - liftIO (threadDelay 500_000) - startup (startupAttempts - 1) - else do - putStrLn @Text (show e) - throwE $ UpdateSelfE StartupYoungAgent (show e) - Right ph -> putStrLn @Text "Succeeded" >> pure ph - interp s = liftIO . injectFilesystemBaseFromContext s . injectFilesystemBaseFromContext s . runRegistryUrlIOC - - - -retryAction :: Monad m => Integer -> m (Either e a) -> m (Either e a) -retryAction 1 action = action -retryAction maxTries action = do - success <- action - case success of - Right a -> pure $ Right a - Left _ -> retryAction (maxTries - 1) action - -replaceExecutableWithYoungAgent :: (MonadReader AppSettings m, MonadIO m) => m () -replaceExecutableWithYoungAgent = do - rt <- asks appFilesystemBase - let tmpAgent = (executablePath `relativeTo` rt) tmpAgentFileName - let agent = (executablePath `relativeTo` rt) agentFileName - - liftIO $ removeLink (toS agent) - liftIO $ rename (toS tmpAgent) (toS agent) - - --- We assume that all app versions must listen on the same port. -youngAgentUrl :: Text -youngAgentUrl = "http://localhost:" <> show youngAgentPort - -pingYoungAgent :: IO Version -pingYoungAgent = do - (code, st_out, st_err) <- readProcessWithExitCode "curl" [toS $ toS youngAgentUrl "version"] "" - putStrLn st_out - putStrLn st_err - case code of - ExitSuccess -> case decodeStrict $ B8.pack st_out of - Nothing -> throwIO . InternalS9Error $ "unparseable version: " <> toS st_out - Just (AppVersionRes av) -> pure av - ExitFailure e -> throwIO . InternalS9Error $ "curl failure with exit code: " <> show e - -startupYoungAgent :: (MonadReader AppSettings m, MonadIO m) => m ProcessHandle -startupYoungAgent = do - rt <- asks appFilesystemBase - let cmd = (proc (toS $ (executablePath `relativeTo` rt) tmpAgentFileName) ["--port", show youngAgentPort]) - { create_group = True - } - ph <- liftIO $ view _4 <$> createProcess cmd - liftIO $ threadDelay 1_000_000 -- 1 second - liftIO $ getProcessExitCode ph >>= \case - Nothing -> pure ph - Just e -> throwIO . InternalS9Error $ "young agent exited prematurely with exit code: " <> show e - -killYoungAgent :: ProcessHandle -> IO () -killYoungAgent p = do - mEC <- getProcessExitCode p - case mEC of - Nothing -> interruptProcessGroupOf p - Just _ -> pure () - threadDelay appEndEstimate - where appEndEstimate = 10 * 1000000 :: Int --10 seconds - -runSyncOps :: [SyncOp] -> ReaderT AgentCtx IO [(Bool, Bool)] -runSyncOps syncOps = do - ctx <- ask - let setUpdate b = if b - then liftIO $ writeIORef (appIsUpdating ctx) (Just agentVersion) - else liftIO $ writeIORef (appIsUpdating ctx) Nothing - res <- for syncOps $ \syncOp -> do - shouldRun <- syncOpShouldRun syncOp - putStrLn @Text [i|Sync Op "#{syncOpName syncOp}" should run: #{shouldRun}|] - when shouldRun $ do - putStrLn @Text [i|Running Sync Op: #{syncOpName syncOp}|] - setUpdate True - syncOpRun syncOp - pure $ (syncOpRequiresReboot syncOp, shouldRun) - setUpdate False - pure res - -synchronizeSystemState :: AgentCtx -> Version -> IO () -synchronizeSystemState ctx _version = handle @_ @SomeException cleanup $ flip runReaderT ctx $ do - (restartsAndRuns, mTid) <- case synchronizer of - Synchronizer { synchronizerOperations } -> flip runStateT Nothing $ for synchronizerOperations $ \syncOp -> do - shouldRun <- lift $ syncOpShouldRun syncOp - putStrLn @Text [i|Sync Op "#{syncOpName syncOp}" should run: #{shouldRun}|] - when shouldRun $ do - tid <- get >>= \case - Nothing -> do - tid <- liftIO . forkIO . forever $ playSong 300 updateInProgress *> threadDelay 20_000_000 - put (Just tid) - pure tid - Just tid -> pure tid - putStrLn @Text [i|Running Sync Op: #{syncOpName syncOp}|] - setUpdate True - lift $ handle @_ @SomeException (\e -> lift $ killThread tid *> cleanup e) $ syncOpRun syncOp - pure $ (syncOpRequiresReboot syncOp, shouldRun) - case mTid of - Nothing -> pure () - Just tid -> liftIO $ killThread tid - setUpdate False - when (any snd restartsAndRuns) $ liftIO $ do - _ <- flip runSqlPool (appConnPool ctx) - $ Notifications.emit (AppId "embassy-os") agentVersion Notifications.OsUpdateSucceeded - playSong 400 marioPowerUp - when (any (uncurry (&&)) restartsAndRuns) $ liftIO do - callCommand "/bin/sync" - callCommand "/sbin/reboot" - where - setUpdate :: MonadIO m => Bool -> m () - setUpdate b = if b - then liftIO $ writeIORef (appIsUpdating ctx) (Just agentVersion) - else liftIO $ writeIORef (appIsUpdating ctx) Nothing - cleanup :: SomeException -> IO () - cleanup e = do - void $ try @SomeException Sound.stop - void $ try @SomeException Sound.unexport - let e' = InternalE $ show e - setUpdate False - flip runReaderT ctx $ cantFail $ failUpdate e' - diff --git a/agent/src/Lib/Sound.hs b/agent/src/Lib/Sound.hs deleted file mode 100644 index 358836b6f..000000000 --- a/agent/src/Lib/Sound.hs +++ /dev/null @@ -1,248 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -module Lib.Sound where - -import Startlude hiding ( rotate ) - -import Control.Monad.Trans.Cont -import Control.Carrier.Writer.Strict -import System.FileLock - -import Util.Function - --- General - -rotate :: forall a . (Enum a, Bounded a) => a -> Int -> a -rotate base step = toEnum $ (fromEnum base + step) `mod` size + (fromEnum $ minBound @a) - where size = fromEnum (maxBound @a) - fromEnum (minBound @a) + 1 -{-# INLINE rotate #-} - - --- Interface - -export :: IO () -export = writeFile "/sys/class/pwm/pwmchip0/export" "0" - -unexport :: IO () -unexport = writeFile "/sys/class/pwm/pwmchip0/unexport" "0" - - --- Constants - -semitoneK :: Double -semitoneK = 2 ** (1 / 12) -{-# INLINE semitoneK #-} - - --- Data Types - -data Note = Note Semitone Word8 - deriving (Eq, Show) - -data Semitone = - C - | Db - | D - | Eb - | E - | F - | Gb - | G - | Ab - | A - | Bb - | B - deriving (Eq, Ord, Show, Enum, Bounded) - -newtype Interval = Interval Int deriving newtype (Num) - -data TimeSlice = - Sixteenth - | Eighth - | Quarter - | Half - | Whole - | Triplet TimeSlice - | Dot TimeSlice - | Tie TimeSlice TimeSlice - deriving (Eq, Show) - - --- Theory Manipulation - -interval :: Interval -> Note -> Note -interval (Interval n) (Note step octave) = - let (o', s') = n `quotRem` 12 - newStep = step `rotate` s' - offset = if - | newStep > step && s' < 0 -> subtract 1 - | newStep < step && s' > 0 -> (+ 1) - | otherwise -> id - in Note newStep (offset $ octave + fromIntegral o') -{-# INLINE interval #-} - -minorThird :: Interval -minorThird = Interval 3 - -majorThird :: Interval -majorThird = Interval 3 - -fourth :: Interval -fourth = Interval 5 - -fifth :: Interval -fifth = Interval 7 - -circleOfFourths :: Note -> [Note] -circleOfFourths = iterate (interval fourth) - -circleOfFifths :: Note -> [Note] -circleOfFifths = iterate (interval fifth) - --- Theory To Interface Target - -noteFreq :: Note -> Double -noteFreq (Note semi oct) = semitoneK ** (fromIntegral $ fromEnum semi) * c0 * (2 ** fromIntegral oct) - where - a4 = 440 - c0 = a4 / (semitoneK ** 9) / (2 ** 4) - --- tempo is in quarters per minute -timeSliceToMicro :: Word16 -> TimeSlice -> Int -timeSliceToMicro tempo timeSlice = case timeSlice of - Sixteenth -> uspq `div` 4 - Eighth -> uspq `div` 2 - Quarter -> uspq - Half -> uspq * 2 - Whole -> uspq * 4 - Triplet timeSlice' -> timeSliceToMicro tempo timeSlice' * 2 `div` 3 - Dot timeSlice' -> timeSliceToMicro tempo timeSlice' * 3 `div` 2 - Tie ts1 ts2 -> timeSliceToMicro tempo ts1 + timeSliceToMicro tempo ts2 - where uspq = floor @Double $ 60 / fromIntegral tempo * 1_000_000 - - --- Player - -periodFile :: FilePath -periodFile = "/sys/class/pwm/pwmchip0/pwm0/period" - -dutyFile :: FilePath -dutyFile = "/sys/class/pwm/pwmchip0/pwm0/duty_cycle" - -switchFile :: FilePath -switchFile = "/sys/class/pwm/pwmchip0/pwm0/enable" - -play :: Note -> IO () -play note' = do - prd' <- readFile periodFile - case prd' of - "0\n" -> writeFile periodFile "1000" - _ -> pure () - let prd = round @_ @Int $ 1 / noteFreq note' * 1_000_000_000 -- pwm needs it in nanos - writeFile dutyFile "0" - writeFile periodFile (show prd) - writeFile dutyFile (show $ prd `div` 2) - writeFile switchFile "1" - -stop :: IO () -stop = writeFile switchFile "0" - -playForDuration :: Note -> Int -> IO () -playForDuration note' duration = handle @SomeException (\e -> stop *> throwIO e) $ do - play note' - threadDelay (floor @Double $ fromIntegral duration * 0.95) - stop - threadDelay (ceiling @Double $ fromIntegral duration * 0.05) - -time :: IO () -> IO (UTCTime, UTCTime) -time action = do - t0 <- getCurrentTime - action - t1 <- getCurrentTime - pure (t0, t1) - -playSong :: Word16 -> Song -> IO () -playSong = flip runCont id .* playSong' -{-# INLINE playSong #-} - -playSongTimed :: Word16 -> Song -> IO (UTCTime, UTCTime) -playSongTimed tempo song = runCont (playSong' tempo song) time -{-# INLINE playSongTimed #-} - -playSong' :: Word16 -> Song -> Cont (IO b) (IO ()) -playSong' tempo song = cont $ \f -> bracket acquire release $ \_ -> f $ do - for_ song $ \(n, ts) -> do - let duration = timeSliceToMicro tempo ts - case n of - Nothing -> threadDelay duration - Just x -> playForDuration x duration - where - soundLock = "/root/agent/sound.lock" - acquire = do - l <- lockFile soundLock Exclusive - export - pure l - release l = do - void $ try @SomeException stop - void $ try @SomeException unexport - unlockFile l - - --- Songs - -type Song = [(Maybe Note, TimeSlice)] - -marioDeath :: Song -marioDeath = - [ (Just $ Note B 4, Quarter) - , (Just $ Note F 5, Quarter) - , (Nothing , Quarter) - , (Just $ Note F 5, Quarter) - , (Just $ Note F 5, Triplet Half) - , (Just $ Note E 5, Triplet Half) - , (Just $ Note D 5, Triplet Half) - , (Just $ Note C 5, Quarter) - , (Just $ Note E 4, Quarter) - , (Nothing , Quarter) - , (Just $ Note E 4, Quarter) - , (Just $ Note C 4, Half) - ] - -marioPowerUp :: Song -marioPowerUp = - [ (Just $ Note G 4 , Triplet Eighth) - , (Just $ Note B 4 , Triplet Eighth) - , (Just $ Note D 5 , Triplet Eighth) - , (Just $ Note G 5 , Triplet Eighth) - , (Just $ Note B 5 , Triplet Eighth) - , (Just $ Note Ab 4, Triplet Eighth) - , (Just $ Note C 5 , Triplet Eighth) - , (Just $ Note Eb 5, Triplet Eighth) - , (Just $ Note Ab 5, Triplet Eighth) - , (Just $ Note C 5 , Triplet Eighth) - , (Just $ Note Bb 4, Triplet Eighth) - , (Just $ Note D 5 , Triplet Eighth) - , (Just $ Note F 5 , Triplet Eighth) - , (Just $ Note Bb 5, Triplet Eighth) - , (Just $ Note D 6 , Triplet Eighth) - ] - -marioCoin :: Song -marioCoin = [(Just $ Note B 5, Eighth), (Just $ Note E 6, Tie (Dot Quarter) Half)] - -updateInProgress :: Song -updateInProgress = take 6 $ (, Triplet Eighth) . Just <$> circleOfFifths (Note A 3) - -beethoven :: Song -beethoven = run . execWriter $ do - tell $ replicate 3 (Just $ Note E 5, Eighth) - tell $ [(Just $ Note C 5, Half)] - tell $ [(Nothing @Note, Eighth)] - tell $ replicate 3 (Just $ Note D 5, Eighth) - tell $ [(Just $ Note B 5, Half)] - -restoreActionInProgress :: Song -restoreActionInProgress = take 5 $ (, Triplet Eighth) . Just <$> circleOfFourths (Note C 4) - -backupActionInProgress :: [(Maybe Note, TimeSlice)] -backupActionInProgress = reverse restoreActionInProgress diff --git a/agent/src/Lib/Ssh.hs b/agent/src/Lib/Ssh.hs deleted file mode 100644 index 9ebbe573b..000000000 --- a/agent/src/Lib/Ssh.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE TupleSections #-} -module Lib.Ssh where - -import Startlude - -import Control.Lens -import Crypto.Hash -import Data.Aeson -import Data.ByteArray hiding ( null - , view - ) -import Data.ByteArray.Encoding -import Data.ByteString.Builder -import Data.ByteString.Lazy ( toStrict ) -import Data.List ( partition ) -import qualified Data.Text as T -import System.Directory - -import Lib.SystemPaths -import Settings - -data SshAlg = RSA | ECDSA | Ed25519 | DSA deriving (Eq, Show) -instance ToJSON SshAlg where - toJSON = String . \case - RSA -> "ssh-rsa" - ECDSA -> "ecdsa-sha2-nistp256" - Ed25519 -> "ssh-ed25519" - DSA -> "ssh-dss" - -getSshKeys :: (MonadReader AppSettings m, MonadIO m) => m [Text] -getSshKeys = do - base <- asks appFilesystemBase - liftIO $ doesFileExist (toS $ sshKeysFilePath `relativeTo` base) >>= \case - False -> pure [] - True -> lines . T.strip <$> readFile (toS $ sshKeysFilePath `relativeTo` base) - -fingerprint :: Text -> Either String (SshAlg, Text, Text) -fingerprint sshKey = do - (alg, b64, host) <- case T.split isSpace sshKey of - [alg, bin, host] -> (, encodeUtf8 bin, host) <$> parseAlg alg - [alg, bin] -> (, encodeUtf8 bin, "") <$> parseAlg alg - _ -> Left $ "Invalid SSH Key: " <> toS sshKey - bin <- convertFromBase @_ @ByteString Base64 b64 - let dig = unpack . convert @_ @ByteString $ hashWith MD5 bin - let hex = fmap (byteString . convertToBase @ByteString Base16 . singleton) dig - let colons = intersperse (charUtf8 ':') hex - pure . (alg, , host) . decodeUtf8 . toStrict . toLazyByteString $ fold colons - where - - parseAlg :: Text -> Either String SshAlg - parseAlg alg = case alg of - "ssh-rsa" -> Right RSA - "ecdsa-sha2-nistp256" -> Right ECDSA - "ssh-ed25519" -> Right Ed25519 - "ssh-dss" -> Right DSA - _ -> Left $ "Invalid SSH Alg: " <> toS alg - -createSshKey :: (MonadReader AppSettings m, MonadIO m) => Text -> m () -createSshKey key = do - base <- asks appFilesystemBase - let writeFirstKeyToFile k = writeFile (toS $ sshKeysFilePath `relativeTo` base) (k <> "\n") - liftIO $ doesFileExist (toS $ sshKeysFilePath `relativeTo` base) >>= \case - False -> writeFirstKeyToFile sanitizedKey - True -> addKeyToFile (toS $ sshKeysFilePath `relativeTo` base) sanitizedKey - where sanitizedKey = T.strip key - -addKeyToFile :: FilePath -> Text -> IO () -addKeyToFile path k = do - oldKeys <- filter (not . T.null) . lines <$> readFile path - writeFile path $ unlines (k : oldKeys) - --- true if key deleted, false if key did not exist -deleteSshKey :: (MonadReader AppSettings m, MonadIO m) => Text -> m Bool -deleteSshKey fp = do - base <- asks appFilesystemBase - let rewriteFile others = liftIO $ writeFile (toS $ sshKeysFilePath `relativeTo` base) $ unlines others - getSshKeys >>= \case - [] -> pure False - keys -> do - let (existed, others) = partition ((Right fp ==) . fmap (view _2) . fingerprint) keys - if null existed then pure False else rewriteFile others >> pure True diff --git a/agent/src/Lib/Ssl.hs b/agent/src/Lib/Ssl.hs deleted file mode 100644 index f4d2f605d..000000000 --- a/agent/src/Lib/Ssl.hs +++ /dev/null @@ -1,365 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE QuasiQuotes #-} -module Lib.Ssl - ( DeriveCertificate(..) - , root_CA_CERT_NAME - , writeRootCaCert - , writeIntermediateCert - , domain_CSR_CONF - , writeLeafCert - , root_CA_OPENSSL_CONF - , intermediate_CA_OPENSSL_CONF - , segment - ) where - -import Startlude - -import Control.Lens -import Data.String.Interpolate.IsString -import System.Process - -root_CA_CERT_NAME :: Text -root_CA_CERT_NAME = "Embassy Local Root CA" - -root_CA_OPENSSL_CONF :: FilePath -> ByteString -root_CA_OPENSSL_CONF path = [i| -# OpenSSL root CA configuration file. -# Copy to `/root/ca/openssl.cnf`. - -[ ca ] -# `man ca` -default_ca = CA_default - -[ CA_default ] -# Directory and file locations. -dir = #{path} -certs = $dir/certs -crl_dir = $dir/crl -new_certs_dir = $dir/newcerts -database = $dir/index.txt -serial = $dir/serial -RANDFILE = $dir/private/.rand - -# The root key and root certificate. -private_key = $dir/private/ca.key.pem -certificate = $dir/certs/ca.cert.pem - -# For certificate revocation lists. -crlnumber = $dir/crlnumber -crl = $dir/crl/ca.crl.pem -crl_extensions = crl_ext -default_crl_days = 30 - -# SHA-1 is deprecated, so use SHA-2 instead. -default_md = sha256 - -name_opt = ca_default -cert_opt = ca_default -default_days = 375 -preserve = no -policy = policy_loose - -[ policy_loose ] -# Allow the intermediate CA to sign a more diverse range of certificates. -# See the POLICY FORMAT section of the `ca` man page. -countryName = optional -stateOrProvinceName = optional -localityName = optional -organizationName = optional -organizationalUnitName = optional -commonName = supplied -emailAddress = optional - -[ req ] -# Options for the `req` tool (`man req`). -default_bits = 4096 -distinguished_name = req_distinguished_name -string_mask = utf8only -prompt = no - -# SHA-1 is deprecated, so use SHA-2 instead. -default_md = sha256 - -# Extension to add when the -x509 option is used. -x509_extensions = v3_ca - -[ req_distinguished_name ] -# See . -CN = #{root_CA_CERT_NAME} -O = Start9 Labs -OU = Embassy - -[ v3_ca ] -# Extensions for a typical CA (`man x509v3_config`). -subjectKeyIdentifier = hash -authorityKeyIdentifier = keyid:always,issuer -basicConstraints = critical, CA:true -keyUsage = critical, digitalSignature, cRLSign, keyCertSign - -[ v3_intermediate_ca ] -# Extensions for a typical intermediate CA (`man x509v3_config`). -subjectKeyIdentifier = hash -authorityKeyIdentifier = keyid:always,issuer -basicConstraints = critical, CA:true, pathlen:0 -keyUsage = critical, digitalSignature, cRLSign, keyCertSign - -[ usr_cert ] -# Extensions for client certificates (`man x509v3_config`). -basicConstraints = CA:FALSE -nsCertType = client, email -nsComment = "OpenSSL Generated Client Certificate" -subjectKeyIdentifier = hash -authorityKeyIdentifier = keyid,issuer -keyUsage = critical, nonRepudiation, digitalSignature, keyEncipherment -extendedKeyUsage = clientAuth, emailProtection - -[ server_cert ] -# Extensions for server certificates (`man x509v3_config`). -basicConstraints = CA:FALSE -nsCertType = server -nsComment = "OpenSSL Generated Server Certificate" -subjectKeyIdentifier = hash -authorityKeyIdentifier = keyid,issuer:always -keyUsage = critical, digitalSignature, keyEncipherment -extendedKeyUsage = serverAuth - -[ crl_ext ] -# Extension for CRLs (`man x509v3_config`). -authorityKeyIdentifier=keyid:always - -[ ocsp ] -# Extension for OCSP signing certificates (`man ocsp`). -basicConstraints = CA:FALSE -subjectKeyIdentifier = hash -authorityKeyIdentifier = keyid,issuer -keyUsage = critical, digitalSignature -extendedKeyUsage = critical, OCSPSigning -|] - -intermediate_CA_OPENSSL_CONF :: Text -> ByteString -intermediate_CA_OPENSSL_CONF path = [i| -# OpenSSL intermediate CA configuration file. -# Copy to `/root/ca/intermediate/openssl.cnf`. - -[ ca ] -# `man ca` -default_ca = CA_default - -[ CA_default ] -# Directory and file locations. -dir = #{path} -certs = $dir/certs -crl_dir = $dir/crl -new_certs_dir = $dir/newcerts -database = $dir/index.txt -serial = $dir/serial -RANDFILE = $dir/private/.rand - -# The root key and root certificate. -private_key = $dir/private/intermediate.key.pem -certificate = $dir/certs/intermediate.cert.pem - -# For certificate revocation lists. -crlnumber = $dir/crlnumber -crl = $dir/crl/intermediate.crl.pem -crl_extensions = crl_ext -default_crl_days = 30 - -# SHA-1 is deprecated, so use SHA-2 instead. -default_md = sha256 - -name_opt = ca_default -cert_opt = ca_default -default_days = 375 -preserve = no -copy_extensions = copy -policy = policy_loose - - -[ policy_loose ] -# Allow the intermediate CA to sign a more diverse range of certificates. -# See the POLICY FORMAT section of the `ca` man page. -countryName = optional -stateOrProvinceName = optional -localityName = optional -organizationName = optional -organizationalUnitName = optional -commonName = supplied -emailAddress = optional - -[ req ] -# Options for the `req` tool (`man req`). -default_bits = 4096 -distinguished_name = req_distinguished_name -string_mask = utf8only -prompt = no - -# SHA-1 is deprecated, so use SHA-2 instead. -default_md = sha256 - -# Extension to add when the -x509 option is used. -x509_extensions = v3_ca - -[ req_distinguished_name ] -CN = Embassy Local Intermediate CA -O = Start9 Labs -OU = Embassy - -[ v3_ca ] -# Extensions for a typical CA (`man x509v3_config`). -subjectKeyIdentifier = hash -authorityKeyIdentifier = keyid:always,issuer -basicConstraints = critical, CA:true -keyUsage = critical, digitalSignature, cRLSign, keyCertSign - -[ v3_intermediate_ca ] -# Extensions for a typical intermediate CA (`man x509v3_config`). -subjectKeyIdentifier = hash -authorityKeyIdentifier = keyid:always,issuer -basicConstraints = critical, CA:true, pathlen:0 -keyUsage = critical, digitalSignature, cRLSign, keyCertSign - -[ usr_cert ] -# Extensions for client certificates (`man x509v3_config`). -basicConstraints = CA:FALSE -nsCertType = client, email -nsComment = "OpenSSL Generated Client Certificate" -subjectKeyIdentifier = hash -authorityKeyIdentifier = keyid,issuer -keyUsage = critical, nonRepudiation, digitalSignature, keyEncipherment -extendedKeyUsage = clientAuth, emailProtection - -[ server_cert ] -# Extensions for server certificates (`man x509v3_config`). -basicConstraints = CA:FALSE -nsCertType = server -nsComment = "OpenSSL Generated Server Certificate" -subjectKeyIdentifier = hash -authorityKeyIdentifier = keyid,issuer:always -keyUsage = critical, digitalSignature, keyEncipherment -extendedKeyUsage = serverAuth - -[ crl_ext ] -# Extension for CRLs (`man x509v3_config`). -authorityKeyIdentifier=keyid:always - -[ ocsp ] -# Extension for OCSP signing certificates (`man ocsp`). -basicConstraints = CA:FALSE -subjectKeyIdentifier = hash -authorityKeyIdentifier = keyid,issuer -keyUsage = critical, digitalSignature -extendedKeyUsage = critical, OCSPSigning -|] - -domain_CSR_CONF :: Text -> ByteString -domain_CSR_CONF name = [i| -[req] -default_bits = 4096 -default_md = sha256 -distinguished_name = req_distinguished_name -prompt = no - -[req_distinguished_name] -CN = #{name} -O = Start9 Labs -OU = Embassy -|] - -writeRootCaCert :: MonadIO m => FilePath -> FilePath -> FilePath -> m (ExitCode, String, String) -writeRootCaCert confPath keyFilePath certFileDestinationPath = liftIO $ readProcessWithExitCode - "openssl" - [ "req" - , -- use x509 - "-new" - , -- new request - "-x509" - , -- self signed x509 - "-nodes" - , -- no passphrase - "-days" - , -- expires in... - "3650" - , -- valid for 10 years. Max is 20 years - "-key" - , -- source private key - toS keyFilePath - , "-out" - -- target cert path - , toS certFileDestinationPath - , "-config" - -- configured by... - , toS confPath - ] - "" - -data DeriveCertificate = DeriveCertificate - { applicantConfPath :: FilePath - , applicantKeyPath :: FilePath - , applicantCertPath :: FilePath - , signingConfPath :: FilePath - , signingKeyPath :: FilePath - , signingCertPath :: FilePath - , duration :: Integer - } -writeIntermediateCert :: MonadIO m => DeriveCertificate -> m (ExitCode, String, String) -writeIntermediateCert DeriveCertificate {..} = liftIO $ interpret $ do - -- openssl genrsa -out dump/int.key 4096 - segment $ openssl [i|ecparam -genkey -name prime256v1 -noout -out #{applicantKeyPath}|] - -- openssl req -new -config dump/int-csr.conf -key dump/int.key -nodes -out dump/int.csr - segment $ openssl [i|req -new - -config #{applicantConfPath} - -key #{applicantKeyPath} - -nodes - -out #{applicantCertPath <> ".csr"}|] - -- openssl x509 -CA dump/ca.crt -CAkey dump/ca.key -CAcreateserial -days 3650 -req -in dump/int.csr -out dump/int.crt - segment $ openssl [i|ca -batch - -config #{signingConfPath} - -rand_serial - -keyfile #{signingKeyPath} - -cert #{signingCertPath} - -extensions v3_intermediate_ca - -days #{duration} - -notext - -in #{applicantCertPath <> ".csr"} - -out #{applicantCertPath}|] - liftIO $ readFile signingCertPath >>= appendFile applicantCertPath - -writeLeafCert :: MonadIO m => DeriveCertificate -> Text -> Text -> m (ExitCode, String, String) -writeLeafCert DeriveCertificate {..} hostname torAddress = liftIO $ interpret $ do - segment $ openssl [i|ecparam -genkey -name prime256v1 -noout -out #{applicantKeyPath}|] - segment $ openssl [i|req -config #{applicantConfPath} - -key #{applicantKeyPath} - -new - -addext subjectAltName=DNS:#{hostname},DNS:*.#{hostname},DNS:#{torAddress},DNS:*.#{torAddress} - -out #{applicantCertPath <> ".csr"}|] - segment $ openssl [i|ca -batch - -config #{signingConfPath} - -rand_serial - -keyfile #{signingKeyPath} - -cert #{signingCertPath} - -extensions server_cert - -days #{duration} - -notext - -in #{applicantCertPath <> ".csr"} - -out #{applicantCertPath} - |] - liftIO $ readFile signingCertPath >>= appendFile applicantCertPath - -openssl :: MonadIO m => Text -> m (ExitCode, String, String) -openssl = liftIO . ($ "") . readProcessWithExitCode "openssl" . fmap toS . words -{-# INLINE openssl #-} - -interpret :: MonadIO m => ExceptT ExitCode (StateT (String, String) m) () -> m (ExitCode, String, String) -interpret = fmap (over _1 (either id (const ExitSuccess)) . regroup) . flip runStateT ("", "") . runExceptT -{-# INLINE interpret #-} - -regroup :: (a, (b, c)) -> (a, b, c) -regroup (a, (b, c)) = (a, b, c) -{-# INLINE regroup #-} - -segment :: MonadIO m => m (ExitCode, String, String) -> ExceptT ExitCode (StateT (String, String) m) () -segment action = (lift . lift) action >>= \case - (ExitSuccess, o, e) -> modify (bimap (<> o) (<> e)) - (ec , o, e) -> modify (bimap (<> o) (<> e)) *> throwE ec -{-# INLINE segment #-} diff --git a/agent/src/Lib/Synchronizers.hs b/agent/src/Lib/Synchronizers.hs deleted file mode 100644 index d5b96e18e..000000000 --- a/agent/src/Lib/Synchronizers.hs +++ /dev/null @@ -1,667 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-type-defaults #-} -{-# LANGUAGE ExtendedDefaultRules #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -module Lib.Synchronizers where - -import Startlude hiding ( check - , err - ) -import qualified Startlude.ByteStream as ByteStream -import qualified Startlude.ByteStream.Char8 as ByteStream - -import Control.Carrier.Lift ( runM ) -import qualified Control.Effect.Reader.Labelled - as Fused -import Control.Monad.Trans.Reader ( mapReaderT ) -import Control.Monad.Trans.Resource -import Data.Attoparsec.Text -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as B8 -import qualified Data.Conduit as Conduit -import qualified Data.Conduit.Combinators as Conduit -import Data.Conduit.Shell hiding ( arch - , hostname - , patch - , split - , stream - ) -import qualified Data.Conduit.Tar as Conduit -import Data.FileEmbed -import qualified Data.HashMap.Strict as HM -import Data.IORef -import Data.String.Interpolate.IsString -import qualified Data.Yaml as Yaml -import Exinst -import qualified Streaming.Conduit as Conduit -import qualified Streaming.Prelude as Stream -import qualified Streaming.Zip as Stream -import System.Directory -import System.FilePath ( () - , joinPath - , splitPath - ) -import System.FilePath.Posix ( takeDirectory ) -import System.IO.Error -import System.Posix.Files -import System.Process ( callCommand ) - -import Constants -import Control.Effect.Error hiding ( run ) -import Control.Effect.Labelled ( runLabelled ) -import Daemon.ZeroConf ( getStart9AgentHostname ) -import Data.ByteString.Char8 ( split ) -import qualified Data.ByteString.Char8 as C8 -import Data.Conduit.List ( consume ) -import qualified Data.Text as T -import Database.Persist.Sqlite ( runSqlPool ) -import Foundation -import Handler.Network -import qualified Lib.Algebra.Domain.AppMgr as AppMgr2 -import Lib.ClientManifest -import Lib.Error -import qualified Lib.External.AppMgr as AppMgr -import Lib.External.Registry -import qualified Lib.Notifications as Notifications -import Lib.Sound -import Lib.Ssl -import Lib.SystemCtl -import Lib.SystemPaths hiding ( () ) -import Lib.Tor -import Lib.Types.Core -import Lib.Types.Emver -import Lib.Types.NetAddress -import Settings -import Util.File - - -data Synchronizer = Synchronizer - { synchronizerVersion :: Version - , synchronizerOperations :: [SyncOp] - } - -data SyncOp = SyncOp - { syncOpName :: Text - , syncOpShouldRun :: ReaderT AgentCtx IO Bool -- emit true if op is to be run - , syncOpRun :: ReaderT AgentCtx IO () - , syncOpRequiresReboot :: Bool - } - -data Arch = ArmV7 | ArmV8 deriving (Show) -data KernelVersion = KernelVersion - { kernelVersionNumber :: Version - , kernelVersionArch :: Arch - } - deriving Show - -parseKernelVersion :: Parser KernelVersion -parseKernelVersion = do - major' <- decimal - minor' <- char '.' *> decimal - patch' <- char '.' *> decimal - arch <- string "-v7l+" $> ArmV7 <|> string "-v8+" $> ArmV8 - pure $ KernelVersion (Version (major', minor', patch', 0)) arch - -synchronizer :: Synchronizer -synchronizer = sync_0_2_17 -{-# INLINE synchronizer #-} - -sync_0_2_17 :: Synchronizer -sync_0_2_17 = Synchronizer - "0.2.17" - [ syncCreateAgentTmp - , syncCreateSshDir - , syncRemoveAvahiSystemdDependency - , syncInstallLibAvahi - , syncInstallAppMgr - , syncFullUpgrade - , sync32BitKernel - , syncInstallNginx - , syncWriteNginxConf - , syncInstallDuplicity - , syncInstallExfatFuse - , syncInstallExfatUtils - , syncUpgradeTor - , syncInstallAmbassadorUI - , syncOpenHttpPorts - , syncUpgradeLifeline - , syncPrepSslRootCaDir - , syncPrepSslIntermediateCaDir - , syncPersistLogs - , syncConvertEcdsaCerts - , syncRestarterService - , syncInstallEject - , syncDropCertificateUniqueness - , syncRemoveDefaultNginxCfg - ] - -syncCreateAgentTmp :: SyncOp -syncCreateAgentTmp = SyncOp "Create Agent Tmp Dir" check migrate False - where - check = do - s <- asks appSettings - tmp <- injectFilesystemBaseFromContext s $ getAbsoluteLocationFor agentTmpDirectory - liftIO $ not <$> doesPathExist (toS tmp) - migrate = do - s <- asks appSettings - tmp <- injectFilesystemBaseFromContext s $ getAbsoluteLocationFor agentTmpDirectory - liftIO $ createDirectoryIfMissing True (toS tmp) - -syncCreateSshDir :: SyncOp -syncCreateSshDir = SyncOp "Create SSH directory" check migrate False - where - check = do - base <- asks $ appFilesystemBase . appSettings - liftIO $ not <$> doesPathExist (toS $ sshKeysDirectory `relativeTo` base) - migrate = do - base <- asks $ appFilesystemBase . appSettings - liftIO $ createDirectoryIfMissing False (toS $ sshKeysDirectory `relativeTo` base) - -syncRemoveAvahiSystemdDependency :: SyncOp -syncRemoveAvahiSystemdDependency = SyncOp "Remove Avahi Systemd Dependency" check migrate False - where - wanted = decodeUtf8 $(embedFile "config/agent.service") - check = do - base <- asks $ appFilesystemBase . appSettings - content <- liftIO $ readFile (toS $ agentServicePath `relativeTo` base) - pure (content /= wanted) - migrate = do - base <- asks $ appFilesystemBase . appSettings - liftIO $ writeFile (toS $ agentServicePath `relativeTo` base) wanted - void $ liftIO systemCtlDaemonReload - --- the main purpose of this is the kernel upgrade but it does upgrade all packages on the system, maybe we should --- reconsider the heavy handed approach here -syncFullUpgrade :: SyncOp -syncFullUpgrade = SyncOp "Full Upgrade" check migrate True - where - check = liftIO . run $ do - v <- decodeUtf8 <<$>> (uname ("-r" :: Text) $| conduit await) - case parse parseKernelVersion <$> v of - Just (Done _ (KernelVersion (Version av) _)) -> if av < (4, 19, 118, 0) then pure True else pure False - _ -> pure False - migrate = liftIO . run $ do - shell "apt-get update --allow-releaseinfo-change" - shell "apt-get full-upgrade -y" - -sync32BitKernel :: SyncOp -sync32BitKernel = SyncOp "32 Bit Kernel Switch" check migrate True - where - getBootCfgPath = getAbsoluteLocationFor bootConfigPath - check = do - settings <- asks appSettings - cfg <- injectFilesystemBaseFromContext settings getBootCfgPath - liftIO . run $ isNothing <$> (shell [i|grep "arm_64bit=0" #{cfg} || true|] $| conduit await) - migrate = do - base <- asks $ appFilesystemBase . appSettings - let tmpFile = bootConfigTempPath `relativeTo` base - let bootCfg = bootConfigPath `relativeTo` base - contents <- liftIO $ readFile (toS bootCfg) - let contents' = unlines . (<> ["arm_64bit=0"]) . filter (/= "arm_64bit=1") . lines $ contents - liftIO $ writeFile (toS tmpFile) contents' - liftIO $ renameFile (toS tmpFile) (toS bootCfg) - -syncInstallNginx :: SyncOp -syncInstallNginx = SyncOp "Install Nginx" check migrate False - where - check = liftIO . run $ fmap isNothing (shell [i|which nginx || true|] $| conduit await) - migrate = liftIO . run $ do - shell "apt-get update --allow-releaseinfo-change" - shell "apt-get install nginx -y" - -syncInstallEject :: SyncOp -syncInstallEject = SyncOp "Install Eject" check migrate False - where - check = liftIO . run $ fmap isNothing (shell [i|which eject || true|] $| conduit await) - migrate = liftIO . run $ do - shell "apt-get update --allow-releaseinfo-change" - shell "apt-get install eject -y" - -syncInstallDuplicity :: SyncOp -syncInstallDuplicity = SyncOp "Install duplicity" check migrate False - where - check = liftIO . run $ fmap isNothing (shell [i|which duplicity || true|] $| conduit await) - migrate = liftIO . run $ do - shell "apt-get update --allow-releaseinfo-change" - shell "apt-get install -y duplicity" - -syncInstallExfatFuse :: SyncOp -syncInstallExfatFuse = SyncOp "Install exfat-fuse" check migrate False - where - check = - liftIO - $ (run (shell [i|dpkg -l|] $| shell [i|grep exfat-fuse|] $| conduit await) $> False) - `catch` \(e :: ProcessException) -> case e of - ProcessException _ (ExitFailure 1) -> pure True - _ -> throwIO e - migrate = liftIO . run $ do - shell "apt-get update --allow-releaseinfo-change" - shell "apt-get install -y exfat-fuse" - -syncInstallExfatUtils :: SyncOp -syncInstallExfatUtils = SyncOp "Install exfat-utils" check migrate False - where - check = - liftIO - $ (run (shell [i|dpkg -l|] $| shell [i|grep exfat-utils|] $| conduit await) $> False) - `catch` \(e :: ProcessException) -> case e of - ProcessException _ (ExitFailure 1) -> pure True - _ -> throwIO e - migrate = liftIO . run $ do - shell "apt-get update --allow-releaseinfo-change" - shell "apt-get install -y exfat-utils" - -syncInstallLibAvahi :: SyncOp -syncInstallLibAvahi = SyncOp "Install libavahi-client" check migrate False - where - check = - liftIO - $ (run (shell [i|dpkg -l|] $| shell [i|grep libavahi-client3|] $| conduit await) $> False) - `catch` \(e :: ProcessException) -> case e of - ProcessException _ (ExitFailure 1) -> pure True - _ -> throwIO e - migrate = liftIO . run $ do - shell "apt-get update --allow-releaseinfo-change" - shell "apt-get install -y libavahi-client3" - -syncWriteConf :: Text -> ByteString -> SystemPath -> SyncOp -syncWriteConf name contents' confLocation = SyncOp [i|Write #{name} Conf|] check migrate False - where - contents = decodeUtf8 contents' - check = do - base <- asks $ appFilesystemBase . appSettings - conf <- - liftIO - $ (Just <$> readFile (toS $ confLocation `relativeTo` base)) - `catch` (\(e :: IOException) -> if isDoesNotExistError e then pure Nothing else throwIO e) - pure $ case conf of - Nothing -> True - Just co -> co /= contents - migrate = do - base <- asks $ appFilesystemBase . appSettings - void . liftIO $ createDirectoryIfMissing True (takeDirectory (toS $ confLocation `relativeTo` base)) - liftIO $ writeFile (toS $ confLocation `relativeTo` base) contents - -syncPrepSslRootCaDir :: SyncOp -syncPrepSslRootCaDir = SyncOp "Create Embassy Root CA Environment" check migrate False - where - check = do - base <- asks $ appFilesystemBase . appSettings - liftIO . fmap not . doesPathExist . toS $ rootCaDirectory `relativeTo` base - migrate = do - base <- asks $ appFilesystemBase . appSettings - liftIO $ do - createDirectoryIfMissing True . toS $ rootCaDirectory `relativeTo` base - for_ ["/certs", "/crl", "/newcerts", "/private"] $ \p -> do - createDirectoryIfMissing True . toS $ p `relativeTo` (rootCaDirectory `relativeTo` base) - setFileMode (toS $ (rootCaDirectory <> "/private") `relativeTo` base) (7 `shiftL` 6) - writeFile (toS $ (rootCaDirectory <> "/index.txt") `relativeTo` base) "" - writeFile (toS $ (rootCaDirectory <> "/serial") `relativeTo` base) "1000" - BS.writeFile (toS $ rootCaOpenSslConfPath `relativeTo` base) - (root_CA_OPENSSL_CONF . toS $ rootCaDirectory `relativeTo` base) - -syncPrepSslIntermediateCaDir :: SyncOp -syncPrepSslIntermediateCaDir = SyncOp "Create Embassy Intermediate CA Environment" check migrate False - where - check = do - base <- asks $ appFilesystemBase . appSettings - liftIO . fmap not . doesPathExist . toS $ intermediateCaDirectory `relativeTo` base - migrate = do - base <- asks $ appFilesystemBase . appSettings - liftIO $ do - createDirectoryIfMissing True . toS $ intermediateCaDirectory `relativeTo` base - for_ ["/certs", "/crl", "/newcerts", "/private"] $ \p -> do - createDirectoryIfMissing True . toS $ (intermediateCaDirectory <> p) `relativeTo` base - setFileMode (toS $ (intermediateCaDirectory <> "/private") `relativeTo` base) (7 `shiftL` 6) - writeFile (toS $ (intermediateCaDirectory <> "/index.txt") `relativeTo` base) "" - writeFile (toS $ (intermediateCaDirectory <> "/serial") `relativeTo` base) "1000" - BS.writeFile (toS $ intermediateCaOpenSslConfPath `relativeTo` base) - (intermediate_CA_OPENSSL_CONF . toS $ intermediateCaDirectory `relativeTo` base) - -syncWriteNginxConf :: SyncOp -syncWriteNginxConf = syncWriteConf "Nginx" $(embedFile "config/nginx.conf") nginxConfig - -syncInstallAmbassadorUI :: SyncOp -syncInstallAmbassadorUI = SyncOp "Install Ambassador UI" check migrate False - where - check = do - base <- asks (appFilesystemBase . appSettings) - liftIO (doesPathExist (toS $ ambassadorUiPath `relativeTo` base)) >>= \case - True -> do - manifest <- liftIO $ readFile (toS $ ambassadorUiManifestPath `relativeTo` base) - case Yaml.decodeEither' (encodeUtf8 manifest) of - Left _ -> pure False - Right (Some1 _ cm) -> case cm of - (V0 cmv0) -> pure $ clientManifestV0AppVersion cmv0 /= agentVersion - False -> pure True - migrate = mapReaderT runResourceT $ do - base <- asks (appFilesystemBase . appSettings) - liftIO $ removePathForcibly (toS $ ambassadorUiPath `relativeTo` base) - - void - . runInContext - -- untar and save to path - $ streamUntar (ambassadorUiPath `relativeTo` base) - -- unzip - . Stream.gunzip - -- download - $ getAmbassadorUiForSpec (exactly agentVersion) - - runM $ injectFilesystemBase base $ do - -- if the ssl config has already been setup, we want to override the config with new UI details - -- otherwise we leave it alone - whenM (liftIO $ doesFileExist (toS $ nginxSitesAvailable nginxSslConf `relativeTo` base)) $ do - sid <- getStart9AgentHostname - let hostname = sid <> ".local" - installAmbassadorUiNginxHTTPS - (NginxSiteConfOverride - hostname - 443 - (Just $ NginxSsl { nginxSslKeyPath = entityKeyPath sid - , nginxSslCertPath = entityCertPath sid - , nginxSslOnlyServerNames = [hostname] - } - ) - ) - nginxSslConf - installAmbassadorUiNginxHTTP nginxTorConf - - streamUntar :: (MonadResource m, MonadThrow m) => Text -> ByteStream.ByteStream m () -> m () - streamUntar root stream = Conduit.runConduit $ Conduit.fromBStream stream .| Conduit.untar \f -> do - let path = toS . (toS root ) . joinPath . drop 1 . splitPath . B8.unpack . Conduit.filePath $ f - print path - if Conduit.fileType f == Conduit.FTDirectory - then liftIO $ createDirectoryIfMissing True path - else Conduit.sinkFile path - -installAmbassadorUiNginxHTTP :: (MonadIO m, HasFilesystemBase sig m) => SystemPath -> m () -installAmbassadorUiNginxHTTP = installAmbassadorUiNginx Nothing - -installAmbassadorUiNginxHTTPS :: (MonadIO m, HasFilesystemBase sig m) => NginxSiteConfOverride -> SystemPath -> m () -installAmbassadorUiNginxHTTPS o = installAmbassadorUiNginx $ Just o - --- Private. Installs an nginx conf from client-manifest to 'fileName' and restarts nginx. -installAmbassadorUiNginx :: (MonadIO m, HasFilesystemBase sig m) - => Maybe NginxSiteConfOverride - -> SystemPath -- nginx conf file name - -> m () -installAmbassadorUiNginx mSslOverrides fileName = do - base <- Fused.ask @"filesystemBase" - - -- parse app manifest - -- generate nginx conf from app manifest - -- write conf to ambassador target location - appEnv <- flip runReaderT base . handleS9ErrNuclear $ liftA2 - (HM.intersectionWith (,)) - (AppMgr2.runAppMgrCliC $ HM.mapMaybe AppMgr2.infoResTorAddress <$> AppMgr2.list [AppMgr2.flags| |]) - AppMgr.readLanIps -- TODO: get appmgr to expose this or guarantee its structure - agentTor <- getAgentHiddenServiceUrl - let fullEnv = HM.insert (AppId "start9-ambassador") (TorAddress agentTor, LanIp "127.0.0.1") appEnv - - removeFileIfExists $ nginxAvailableConf base - removeFileIfExists $ nginxEnabledConf base - - flip runReaderT fullEnv - $ transpile mSslOverrides (ambassadorUiClientManifiest base) (nginxAvailableConf base) - >>= \case - True -> pure () - False -> throwIO . InternalS9Error $ "Failed to write ambassador ui nginx config " <> show fileName - liftIO $ createSymbolicLink (nginxAvailableConf base) (nginxEnabledConf base) - - -- restart nginx - void . liftIO $ systemCtl RestartService "nginx" - where - ambassadorUiClientManifiest b = toS $ (ambassadorUiPath <> "/client-manifest.yaml") `relativeTo` b - nginxAvailableConf b = toS $ nginxSitesAvailable fileName `relativeTo` b - nginxEnabledConf b = toS $ nginxSitesEnabled fileName `relativeTo` b - -syncOpenHttpPorts :: SyncOp -syncOpenHttpPorts = SyncOp "Open Hidden Service Port 80" check migrate False - where - check = runResourceT $ do - base <- asks $ appFilesystemBase . appSettings - res <- - ByteStream.readFile (toS $ AppMgr.torrcBase `relativeTo` base) - & ByteStream.lines - & Stream.mapped ByteStream.toStrict - & Stream.map decodeUtf8 - & Stream.filter - ( ( (== ["HiddenServicePort", "443", "127.0.0.1:443"]) - <||> (== ["HiddenServicePort", "80", "127.0.0.1:80"]) - ) - . words - ) - & Stream.toList_ - if length res < 2 then pure True else pure False - migrate = cantFail . flip catchE failUpdate $ do - lift $ syncOpRun $ syncWriteConf "Torrc" $(embedFile "config/torrc") AppMgr.torrcBase - AppMgr.torReload - -syncInstallAppMgr :: SyncOp -syncInstallAppMgr = SyncOp "Install AppMgr" check migrate False - where - check = runExceptT AppMgr.getAppMgrVersion >>= \case - Left _ -> pure True - Right v -> not . (v <||) <$> asks (appMgrVersionSpec . appSettings) - migrate = fmap (either absurd id) . runExceptT . flip catchE failUpdate $ do - lan <- asks appLanThread - avs <- asks $ appMgrVersionSpec . appSettings - av <- AppMgr.installNewAppMgr avs - unless (av <|| avs) $ throwE $ AppMgrVersionE av avs - flip runReaderT lan $ runLabelled @"lanThread" $ postResetLanLogic -- to accommodate 0.2.x -> 0.2.9 where previous appmgr didn't correctly set up lan - -syncUpgradeLifeline :: SyncOp -syncUpgradeLifeline = SyncOp "Upgrade Lifeline" check migrate False - where - clearResets :: SystemPath - clearResets = "/usr/local/bin/clear-resets.sh" - check = do - base <- asks $ appFilesystemBase . appSettings - liftIO $ doesFileExist . toS $ clearResets `relativeTo` base - migrate = do - base <- asks $ appFilesystemBase . appSettings - removeFileIfExists . toS $ lifelineBinaryPath `relativeTo` base - mapReaderT runResourceT $ runInContext $ getLifelineBinary (exactly "0.2.0") - removeFileIfExists . toS $ clearResets `relativeTo` base - -syncPersistLogs :: SyncOp -syncPersistLogs = - (syncWriteConf "Journald" $(embedFile "config/journald.conf") journaldConfig) { syncOpRequiresReboot = True } - -syncRepairSsl :: SyncOp -syncRepairSsl = SyncOp "Repair SSL Certs" check migrate False - where - check = do - base <- asks $ appFilesystemBase . appSettings - let p = toS $ sslDirectory `relativeTo` base - liftIO $ not <$> doesDirectoryExist p - migrate = do - base <- asks $ appFilesystemBase . appSettings - let newCerts = toS $ (agentTmpDirectory <> sslDirectory) `relativeTo` base - liftIO $ renameDirectory newCerts (toS $ sslDirectory `relativeTo` base) - liftIO $ systemCtl RestartService "nginx" $> () - -syncConvertEcdsaCerts :: SyncOp -syncConvertEcdsaCerts = SyncOp "Convert Intermediate Cert to ECDSA P256" check migrate False - where - check = do - fs <- asks $ appFilesystemBase . appSettings - let intCertKey = toS $ intermediateCaKeyPath `relativeTo` fs - exists <- liftIO $ doesPathExist intCertKey - if exists - then do - header <- liftIO $ headMay . lines <$> readFile intCertKey - pure $ case header of - Nothing -> False - Just y -> "BEGIN RSA PRIVATE KEY" `T.isInfixOf` y - else pure False - migrate = cantFail $ do - base <- asks $ appFilesystemBase . appSettings - (runM . runExceptT) (injectFilesystemBase base replaceDerivativeCerts) >>= \case - Left e -> failUpdate e - Right () -> pure () - - -replaceDerivativeCerts :: (HasFilesystemBase sig m, Fused.Has (Error S9Error) sig m, MonadIO m) => m () -replaceDerivativeCerts = do - sid <- getStart9AgentHostname - let hostname = sid <> ".local" - torAddr <- getAgentHiddenServiceUrl - - caKeyPath <- toS <$> getAbsoluteLocationFor rootCaKeyPath - caConfPath <- toS <$> getAbsoluteLocationFor rootCaOpenSslConfPath - caCertPath <- toS <$> getAbsoluteLocationFor rootCaCertPath - - 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) - - -- ensure duplicate certificates are acceptable - base <- Fused.ask @"filesystemBase" - liftIO $ BS.writeFile (toS $ (rootCaDirectory <> "index.txt.attr") `relativeTo` base) "unique_subject = no\n" - liftIO $ BS.writeFile (toS $ (intermediateCaDirectory <> "index.txt.attr") `relativeTo` base) - "unique_subject = no\n" - - (ec, out, err) <- 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 ec - putStrLn @String $ "stdout: " <> out - putStrLn @String $ "stderr: " <> err - case ec of - ExitSuccess -> pure () - ExitFailure n -> throwError $ OpenSslE "leaf" n out err - - (ec', out', err') <- writeLeafCert - DeriveCertificate { applicantConfPath = entConfPathTmp - , applicantKeyPath = entKeyPathTmp - , applicantCertPath = entCertPathTmp - , signingConfPath = intCaConfPath - , signingKeyPath = intCaKeyPath - , signingCertPath = intCaCertPath - , duration = 365 - } - hostname - torAddr - liftIO $ do - putStrLn @Text "openssl logs" - putStrLn @Text "exit code: " - print ec - putStrLn @String $ "stdout: " <> out' - putStrLn @String $ "stderr: " <> err' - case ec' of - ExitSuccess -> pure () - ExitFailure n -> throwError $ OpenSslE "leaf" n out' err' - - sslDir <- toS <$> getAbsoluteLocationFor sslDirectory - liftIO $ removePathForcibly sslDir - liftIO $ renameDirectory sslDirTmp sslDir - liftIO $ systemCtl RestartService "nginx" $> () - -syncRestarterService :: SyncOp -syncRestarterService = SyncOp "Install Restarter Service" check migrate True - where - wantedService = $(embedFile "config/restarter.service") - wantedTimer = $(embedFile "config/restarter.timer") - check = do - base <- asks $ appFilesystemBase . appSettings - liftIO $ not <$> doesPathExist - (toS $ "/etc/systemd/system/timers.target.wants/restarter.timer" `relativeTo` base) - migrate = do - base <- asks $ appFilesystemBase . appSettings - liftIO $ BS.writeFile (toS $ "/etc/systemd/system/restarter.service" `relativeTo` base) wantedService - liftIO $ BS.writeFile (toS $ "/etc/systemd/system/restarter.timer" `relativeTo` base) wantedTimer - liftIO $ callCommand "systemctl enable restarter.service" - liftIO $ callCommand "systemctl enable restarter.timer" - -syncUpgradeTor :: SyncOp -syncUpgradeTor = SyncOp "Install Latest Tor" check migrate False - where - check = run $ do - mTorVersion <- (shell "dpkg -s tor" $| shell "grep '^Version'" $| shell "cut -d ' ' -f2" $| conduit await) - let torVersion = case mTorVersion of - Nothing -> panic "invalid output from dpkg, can't read tor version" - Just x -> x - pure $ compareTorVersions torVersion "0.3.5.15-1" == LT - migrate = liftIO . run $ do - shell "apt-get update --allow-releaseinfo-change" - availVersions <- - (shell "apt-cache madison tor" $| shell "cut -d '|' -f2" $| shell "xargs" $| conduit consume) - latest <- case lastMay $ sortBy compareTorVersions availVersions of - Nothing -> throwIO $ ErrorCall "No available versions of tor" - Just x -> pure x - shell $ "apt-get install -y tor=" <> if "0.3.5.15-1" `elem` availVersions - then "0.3.5.15-1" - else (C8.unpack latest) - compareTorVersions :: ByteString -> ByteString -> Ordering - compareTorVersions a b = - let a' = (traverse (readMaybe @Int . decodeUtf8) . (split '.' <=< split '-') $ a) - b' = (traverse (readMaybe @Int . decodeUtf8) . (split '.' <=< split '-') $ b) - in case liftA2 compare a' b' of - Nothing -> panic "invalid tor version string" - Just x -> x - - -syncDropCertificateUniqueness :: SyncOp -syncDropCertificateUniqueness = SyncOp "Eliminate OpenSSL unique_subject=yes" check migrate False - where - uni = "unique_subject = no\n" - check = do - base <- asks $ appFilesystemBase . appSettings - contentsRoot <- - liftIO - $ (fmap Just . BS.readFile . toS $ (rootCaDirectory <> "index.txt.attr") `relativeTo` base) - `catch` \(e :: IOException) -> if isDoesNotExistError e then pure Nothing else throwIO e - contentsInt <- - liftIO - $ (fmap Just . BS.readFile . toS $ (intermediateCaDirectory <> "index.txt.attr") `relativeTo` base) - `catch` \(e :: IOException) -> if isDoesNotExistError e then pure Nothing else throwIO e - case (contentsRoot, contentsInt) of - (Just root, Just int) -> pure $ uni /= root || uni /= int - _ -> pure True - migrate = do - base <- asks $ appFilesystemBase . appSettings - liftIO $ BS.writeFile (toS $ (rootCaDirectory <> "index.txt.attr") `relativeTo` base) uni - liftIO $ BS.writeFile (toS $ (intermediateCaDirectory <> "index.txt.attr") `relativeTo` base) uni - -syncRemoveDefaultNginxCfg :: SyncOp -syncRemoveDefaultNginxCfg = SyncOp "Remove Default Nginx Configuration" check migrate False - where - check = do - base <- asks $ appFilesystemBase . appSettings - liftIO $ doesPathExist (toS $ nginxSitesEnabled "default" `relativeTo` base) - migrate = do - base <- asks $ appFilesystemBase . appSettings - liftIO $ removeFileIfExists (toS $ nginxSitesEnabled "default" `relativeTo` base) - liftIO $ systemCtl RestartService "nginx" $> () - -failUpdate :: S9Error -> ExceptT Void (ReaderT AgentCtx IO) () -failUpdate e = do - ref <- asks appIsUpdateFailed - pool <- asks appConnPool - let msg = errorMessage (toError e) - putStrLn $ "UPDATE FAILED: " <> msg - _ <- liftIO . flip runSqlPool pool $ Notifications.emit (AppId "embassy-os") - agentVersion - (Notifications.OsUpdateFailed msg) - liftIO $ playSong 216 beethoven - liftIO $ writeIORef ref (Just e) - -cantFail :: Monad m => ExceptT Void m a -> m a -cantFail = fmap (either absurd id) . runExceptT diff --git a/agent/src/Lib/SystemCtl.hs b/agent/src/Lib/SystemCtl.hs deleted file mode 100644 index 8b19c1e2d..000000000 --- a/agent/src/Lib/SystemCtl.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Lib.SystemCtl where - -import Startlude hiding ( words ) -import Protolude.Unsafe ( unsafeHead ) - -import Data.String -import System.Process -import Text.Casing - -data ServiceAction = - StartService - | StopService - | RestartService - deriving (Eq, Show) - -toAction :: ServiceAction -> String -toAction = fmap toLower . unsafeHead . words . wordify . show - -systemCtl :: ServiceAction -> Text -> IO ExitCode -systemCtl action service = rawSystem "systemctl" [toAction action, toS service] - -systemCtlDaemonReload :: IO ExitCode -systemCtlDaemonReload = rawSystem "systemctl" ["daemon-reload"] diff --git a/agent/src/Lib/SystemPaths.hs b/agent/src/Lib/SystemPaths.hs deleted file mode 100644 index 84bf2f59f..000000000 --- a/agent/src/Lib/SystemPaths.hs +++ /dev/null @@ -1,259 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module Lib.SystemPaths where - -import Startlude hiding ( (<.>) - , Reader - , ask - , runReader - ) - -import Control.Effect.Labelled ( Labelled - , runLabelled - ) -import Control.Effect.Reader.Labelled -import Data.List -import qualified Data.Text as T -import qualified Protolude.Base as P - ( show ) -import System.IO.Error ( isDoesNotExistError ) -import System.Directory - -import Lib.Types.Core -import Settings - -strJoin :: Char -> Text -> Text -> Text -strJoin c a b = case (T.unsnoc a, T.uncons b) of - (Nothing , Nothing ) -> "" - (Nothing , Just _ ) -> b - (Just _ , Nothing ) -> a - (Just (_, c0), Just (c1, s)) -> case (c0 == c, c1 == c) of - (True , True ) -> a <> s - (False, False) -> a <> T.singleton c <> b - _ -> a <> b - -() :: Text -> Text -> Text -() = strJoin '/' - -(<.>) :: Text -> Text -> Text -(<.>) = strJoin '.' - --- system paths behave the same as FilePaths mostly except that they can be rebased onto alternative roots so that things --- can be tested in an isolated way. This uses a church encoding. -newtype SystemPath = SystemPath { relativeTo :: Text -> Text } -instance Eq SystemPath where - (==) a b = a `relativeTo` "/" == b `relativeTo` "/" -instance Show SystemPath where - show sp = P.show $ sp `relativeTo` "/" -instance Semigroup SystemPath where - (SystemPath f) <> (SystemPath g) = SystemPath $ g . f -instance Monoid SystemPath where - mempty = SystemPath id -instance IsString SystemPath where - fromString (c : cs) = case c of - '/' -> relBase . toS $ cs - _ -> relBase . toS $ c : cs - fromString [] = mempty - -leaf :: SystemPath -> Text -leaf = last . T.splitOn "/" . show - -relBase :: Text -> SystemPath -relBase = SystemPath . flip () - -type HasFilesystemBase sig m = HasLabelled "filesystemBase" (Reader Text) sig m - -injectFilesystemBase :: Monad m => Text -> Labelled "filesystemBase" (ReaderT Text) m a -> m a -injectFilesystemBase fsbase = flip runReaderT fsbase . runLabelled @"filesystemBase" - -injectFilesystemBaseFromContext :: Monad m => AppSettings -> Labelled "filesystemBase" (ReaderT Text) m a -> m a -injectFilesystemBaseFromContext = injectFilesystemBase . appFilesystemBase - -getAbsoluteLocationFor :: HasFilesystemBase sig m => SystemPath -> m Text -getAbsoluteLocationFor path = do - base <- ask @"filesystemBase" - pure $ path `relativeTo` base - -readSystemPath :: (HasFilesystemBase sig m, MonadIO m) => SystemPath -> m (Maybe Text) -readSystemPath path = do - loadPath <- getAbsoluteLocationFor path - liftIO - $ (Just <$> readFile (toS loadPath)) - `catch` (\(e :: IOException) -> if isDoesNotExistError e then pure Nothing else throwIO e) - -existsSystemPath :: (HasFilesystemBase sig m, MonadIO m) => SystemPath -> m Bool -existsSystemPath path = do - checkPath <- getAbsoluteLocationFor path - liftIO . doesPathExist $ toS checkPath - --- like the above, but throws IO error if file not found -readSystemPath' :: (HasFilesystemBase sig m, MonadIO m) => SystemPath -> m Text -readSystemPath' path = do - loadPath <- getAbsoluteLocationFor path - liftIO . readFile . toS $ loadPath - -writeSystemPath :: (HasFilesystemBase sig m, MonadIO m) => SystemPath -> Text -> m () -writeSystemPath path contents = do - loadPath <- getAbsoluteLocationFor path - liftIO $ writeFile (toS loadPath) contents - -deleteSystemPath :: (HasFilesystemBase sig m, MonadIO m) => SystemPath -> m () -deleteSystemPath path = do - loadPath <- getAbsoluteLocationFor path - liftIO $ removePathForcibly (toS loadPath) - -dbPath :: (HasFilesystemBase sig m, HasLabelled "sqlDatabase" (Reader Text) sig m) => m Text -dbPath = do - rt <- ask @"filesystemBase" - dbName <- ask @"sqlDatabase" - pure $ rt "root/agent" toS dbName - -uiPath :: SystemPath -uiPath = "/var/www/html" - -agentDataDirectory :: SystemPath -agentDataDirectory = "/root/agent" - -agentTmpDirectory :: SystemPath -agentTmpDirectory = "/root/agent/tmp" - -bootConfigPath :: SystemPath -bootConfigPath = "/boot/config.txt" - -bootConfigTempPath :: SystemPath -bootConfigTempPath = "/boot/config_tmp.txt" - -executablePath :: SystemPath -executablePath = "/usr/local/bin" - --- Caches -- - -iconBasePath :: SystemPath -iconBasePath = "/root/agent/icons" - --- Nginx -- - -nginxConfig :: SystemPath -nginxConfig = "/etc/nginx/nginx.conf" - -journaldConfig :: SystemPath -journaldConfig = "/etc/systemd/journald.conf" - -nginxSitesAvailable :: SystemPath -> SystemPath -nginxSitesAvailable = ("/etc/nginx/sites-available" <>) - -nginxSitesEnabled :: SystemPath -> SystemPath -nginxSitesEnabled = ("/etc/nginx/sites-enabled" <>) - -nginxTorConf :: SystemPath -nginxTorConf = "/start9-ambassador.conf" - -nginxSslConf :: SystemPath -nginxSslConf = "/start9-ambassador-ssl.conf" - --- SSH -- - -sshKeysDirectory :: SystemPath -sshKeysDirectory = "/home/pi/.ssh" - -sshKeysFilePath :: SystemPath -sshKeysFilePath = sshKeysDirectory <> "authorized_keys" - --- Zero Conf -- - -avahiPath :: SystemPath -avahiPath = "/etc/avahi" - -avahiServiceFolder :: SystemPath -avahiServiceFolder = avahiPath <> "services" - -avahiServicePath :: Text -> SystemPath -avahiServicePath svc = avahiServiceFolder <> relBase (svc <.> "service") - --- Ambassador UI -- - -ambassadorUiPath :: SystemPath -ambassadorUiPath = uiPath <> "/start9-ambassador" - -ambassadorUiManifestPath :: SystemPath -ambassadorUiManifestPath = ambassadorUiPath <> "/client-manifest.yaml" - --- Tor -- - -agentTorHiddenServiceDirectory :: SystemPath -agentTorHiddenServiceDirectory = "/var/lib/tor/agent" - -agentTorHiddenServiceHostnamePath :: SystemPath -agentTorHiddenServiceHostnamePath = agentTorHiddenServiceDirectory <> "/hostname" - -agentTorHiddenServicePrivateKeyPath :: SystemPath -agentTorHiddenServicePrivateKeyPath = agentTorHiddenServiceDirectory <> "/hs_ed25519_secret_key" - --- Server Config -- - -serverNamePath :: SystemPath -serverNamePath = "/root/agent/name.txt" - -disableAutoCheckUpdatesPath :: SystemPath -disableAutoCheckUpdatesPath = "/root/agent/.disableAutoCheckUpdates" - -altRegistryUrlPath :: SystemPath -altRegistryUrlPath = "/root/agent/alt_registry_url.txt" - --- Session Auth Key -- - -sessionSigningKeyPath :: SystemPath -sessionSigningKeyPath = "/root/agent/start9.aes" - --- AppMgr -- - -appMgrRootPath :: SystemPath -appMgrRootPath = "/root/appmgr" - -appMgrAppPath :: AppId -> SystemPath -appMgrAppPath = ((appMgrRootPath <> "apps") <>) . relBase . unAppId - -lifelineBinaryPath :: SystemPath -lifelineBinaryPath = "/usr/local/bin/lifeline" - --- Open SSL -- - -rootCaDirectory :: SystemPath -rootCaDirectory = agentDataDirectory <> "/ca" - -rootCaKeyPath :: SystemPath -rootCaKeyPath = rootCaDirectory <> "/private/embassy-root-ca.key.pem" - -rootCaCertPath :: SystemPath -rootCaCertPath = rootCaDirectory <> "/certs/embassy-root-ca.cert.pem" - -rootCaOpenSslConfPath :: SystemPath -rootCaOpenSslConfPath = rootCaDirectory <> "/openssl.conf" - -intermediateCaDirectory :: SystemPath -intermediateCaDirectory = rootCaDirectory <> "/intermediate" - -intermediateCaKeyPath :: SystemPath -intermediateCaKeyPath = intermediateCaDirectory <> "/private/embassy-int-ca.key.pem" - -intermediateCaCertPath :: SystemPath -intermediateCaCertPath = intermediateCaDirectory <> "/certs/embassy-int-ca.crt.pem" - -intermediateCaOpenSslConfPath :: SystemPath -intermediateCaOpenSslConfPath = intermediateCaDirectory <> "/openssl.conf" - -sslDirectory :: SystemPath -sslDirectory = "/etc/nginx/ssl" - -entityKeyPath :: Text -> SystemPath -entityKeyPath hostname = sslDirectory <> relBase ("/" <> hostname <> "-local.key.pem") - -entityCertPath :: Text -> SystemPath -entityCertPath hostname = sslDirectory <> relBase ("/" <> hostname <> "-local.crt.pem") - -entityConfPath :: Text -> SystemPath -entityConfPath hostname = sslDirectory <> relBase ("/" <> hostname <> "-local.conf") - --- Systemd - -agentServicePath :: SystemPath -agentServicePath = "/etc/systemd/system/agent.service" diff --git a/agent/src/Lib/Tor.hs b/agent/src/Lib/Tor.hs deleted file mode 100644 index 9558c757f..000000000 --- a/agent/src/Lib/Tor.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Lib.Tor where - -import Startlude - -import qualified Data.Text as T -import Network.HTTP.Client -import Network.Connection - -import Lib.SystemPaths -import Network.HTTP.Client.TLS ( mkManagerSettings ) -import Data.Default - -getAgentHiddenServiceUrl :: (HasFilesystemBase sig m, MonadIO m) => m Text -getAgentHiddenServiceUrl = T.strip <$> readSystemPath' agentTorHiddenServiceHostnamePath - -getAgentHiddenServiceUrlMaybe :: (HasFilesystemBase sig m, MonadIO m) => m (Maybe Text) -getAgentHiddenServiceUrlMaybe = fmap T.strip <$> readSystemPath agentTorHiddenServiceHostnamePath - --- | 'newTorManager' currently assumes the tor client lives on the localhost. The port comes in over an argument. --- If this is insufficient in the future, feel free to parameterize the host. -newTorManager :: Word16 -> IO Manager -newTorManager = newManager . mkManagerSettings def . Just . SockSettingsSimple "127.0.0.1" . fromIntegral diff --git a/agent/src/Lib/TyFam/ConditionalData.hs b/agent/src/Lib/TyFam/ConditionalData.hs deleted file mode 100644 index 6d2f62dd5..000000000 --- a/agent/src/Lib/TyFam/ConditionalData.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Lib.TyFam.ConditionalData where - -import Startlude - -import Data.Singletons.TH - -type Include :: Bool -> Type -> Type -type family Include p a where - Include 'True a = a - Include 'False _ = () -genDefunSymbols [''Include] -type Keep :: Type ~> Type -type Keep = IncludeSym1 'True -type Full :: ((Type ~> Type) -> Type) -> Type -type Full t = t Keep -type Strip :: Type ~> Type -type Strip = IncludeSym1 'False -type Stripped :: ((Type ~> Type) -> Type) -> Type -type Stripped t = t Strip diff --git a/agent/src/Lib/Types/Core.hs b/agent/src/Lib/Types/Core.hs deleted file mode 100644 index 4c5ba0063..000000000 --- a/agent/src/Lib/Types/Core.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} -module Lib.Types.Core where - -import Startlude -import qualified GHC.Read ( Read(..) ) -import qualified GHC.Show ( Show(..) ) - -import Data.Aeson ( withText - , FromJSON(parseJSON) - , FromJSONKey(fromJSONKey) - , Value(String) - , ToJSON(toJSON) - , ToJSONKey(toJSONKey) - ) -import Data.Functor.Contravariant ( Contravariant(contramap) ) -import Data.Singletons.TH -import Database.Persist ( PersistField(..) - , PersistValue(PersistText) - , SqlType(SqlString) - ) -import Database.Persist.Sql ( PersistFieldSql(..) ) -import Yesod.Core ( PathPiece(..) ) -import Control.Monad.Fail ( MonadFail(fail) ) -import Data.Text ( toUpper ) -import Web.HttpApiData - -newtype AppId = AppId { unAppId :: Text } deriving (Eq, Ord) -deriving newtype instance ToHttpApiData AppId -deriving newtype instance FromHttpApiData AppId - -instance IsString AppId where - fromString = AppId . fromString -instance Show AppId where - show = toS . unAppId -instance Read AppId where - readsPrec _ s = [(AppId $ toS s, "")] -instance Hashable AppId where - hashWithSalt n = hashWithSalt n . unAppId -instance ToJSON AppId where - toJSON = toJSON . unAppId -instance FromJSON AppId where - parseJSON = fmap AppId . parseJSON -instance PathPiece AppId where - toPathPiece = unAppId - fromPathPiece = fmap AppId . fromPathPiece -instance PersistField AppId where - toPersistValue = PersistText . show - fromPersistValue (PersistText t) = Right . AppId $ toS t - fromPersistValue other = Left $ "Invalid AppId: " <> show other -instance PersistFieldSql AppId where - sqlType _ = SqlString -instance FromJSONKey AppId where - fromJSONKey = fmap AppId fromJSONKey -instance ToJSONKey AppId where - toJSONKey = contramap unAppId toJSONKey - - -data AppContainerStatus = - Running - | Stopped - | Paused - | Restarting - | Removing - | Dead deriving (Eq, Show) -instance ToJSON AppContainerStatus where - toJSON Paused = String "STOPPED" -- we never want to show paused to the Front End - toJSON other = String . toUpper . show $ other -instance FromJSON AppContainerStatus where - parseJSON = withText "health status" $ \case - "RUNNING" -> pure Running - "STOPPED" -> pure Stopped - "PAUSED" -> pure Paused - "RESTARTING" -> pure Restarting - "REMOVING" -> pure Removing - "DEAD" -> pure Dead - _ -> fail "unknown status" - -data AppAction = Start | Stop deriving (Eq, Show) - -data BackupJobType = CreateBackup | RestoreBackup deriving (Eq, Show) - -$(singletons [d| - data AppTmpStatus - = Installing - | CreatingBackup - | RestoringBackup - | NeedsConfig - | BrokenDependencies - | Crashed - | StoppingT - | RestartingT - deriving (Eq, Show) |]) - -instance ToJSON AppTmpStatus where - toJSON = String . \case - Installing -> "INSTALLING" - CreatingBackup -> "CREATING_BACKUP" - RestoringBackup -> "RESTORING_BACKUP" - NeedsConfig -> "NEEDS_CONFIG" - BrokenDependencies -> "BROKEN_DEPENDENCIES" - Crashed -> "CRASHED" - RestartingT -> "RESTARTING" - StoppingT -> "STOPPING" - -data AppStatus - = AppStatusTmp AppTmpStatus - | AppStatusAppMgr AppContainerStatus - deriving (Eq, Show) -instance ToJSON AppStatus where - toJSON (AppStatusTmp s) = toJSON s - toJSON (AppStatusAppMgr s) = toJSON s diff --git a/agent/src/Lib/Types/Emver.hs b/agent/src/Lib/Types/Emver.hs deleted file mode 100644 index a7d6ddcc4..000000000 --- a/agent/src/Lib/Types/Emver.hs +++ /dev/null @@ -1,262 +0,0 @@ -{- | -Module : Lib.Types.Emver -Description : Semver with 4th digit extension for Embassy -License : Start9 Non-Commercial -Maintainer : keagan@start9labs.com -Stability : experimental -Portability : portable - -This module was designed to address the problem of releasing updates to Embassy Packages where the upstream project was -either unaware of or apathetic towards supporting their application on the Embassy platform. In most cases, the original -package will support . This leaves us with the problem where we would like -to preserve the original package's version, since one of the goals of the Embassy platform is transparency. However, on -occasion, we have screwed up and published a version of a package that needed to have its metadata updated. In this -scenario we were left with the conundrum of either unilaterally claiming a version number of a package we did not author -or let the issue persist until the next update. Neither of these promote good user experiences, for different reasons. -This module extends the semver standard linked above with a 4th digit, which is given PATCH semantics. --} - -module Lib.Types.Emver - ( major - , minor - , patch - , revision - , satisfies - , (<||) - , (||>) - -- we do not export 'None' because it is useful for its internal algebraic properties only - , VersionRange(Anchor, Any, None) - , Version(..) - , AnyRange(..) - , AllRange(..) - , conj - , disj - , exactly - , parseVersion - , parseRange - ) -where - -import Prelude -import qualified Data.Attoparsec.Text as Atto -import Data.Function -import Data.Functor ( (<&>) - , ($>) - ) -import Control.Applicative ( liftA2 - , Alternative((<|>)) - ) -import Data.String ( IsString(..) ) -import qualified Data.Text as T - --- | AppVersion is the core representation of the SemverQuad type. -newtype Version = Version { unVersion :: (Word, Word, Word, Word) } deriving (Eq, Ord) -instance Show Version where - show (Version (x, y, z, q)) = - let postfix = if q == 0 then "" else '.' : show q in show x <> "." <> show y <> "." <> show z <> postfix -instance IsString Version where - fromString s = either error id $ Atto.parseOnly parseVersion (T.pack s) -instance Read Version where - readsPrec _ s = case Atto.parseOnly parseVersion (T.pack s) of - Left _ -> [] - Right a -> [(a, "")] - --- | A change in the value found at 'major' implies a breaking change in the API that this version number describes -major :: Version -> Word -major (Version (x, _, _, _)) = x - --- | A change in the value found at 'minor' implies a backwards compatible addition to the API that this version number --- describes -minor :: Version -> Word -minor (Version (_, y, _, _)) = y - --- | A change in the value found at 'patch' implies that the implementation of the API has changed without changing the --- invariants promised by the API. In many cases this will be incremented when repairing broken functionality -patch :: Version -> Word -patch (Version (_, _, z, _)) = z - --- | This is the fundamentally new value in comparison to the original semver 2.0 specification. It is given the same --- semantics as 'patch' above, which begs the question, when should you update this value instead of that one. Generally --- speaking, if you are both the package author and maintainer, you should not ever increment this number, as it is --- redundant with 'patch'. However, if you maintain a package on some distribution channel, and you are /not/ the --- original author, then it is encouraged for you to increment 'quad' instead of 'patch'. -revision :: Version -> Word -revision (Version (_, _, _, q)) = q - - --- | 'Operator' is the type that specifies how to compare against the target version. Right represents the ordering, --- Left negates it -type Operator = Either Ordering Ordering - --- | 'VersionRange' is the algebra of sets of versions. They can be constructed by having an 'Anchor' term which --- compares against the target version, or can be described with 'Conj' which is a conjunction, or 'Disj', which is a --- disjunction. The 'Any' and 'All' terms are primarily there to round out the algebra, but 'Any' is also exposed due to --- its usage in semantic versioning in general. The 'None' term is not useful to the end user as there would be no --- reasonable usage of it to describe version sets. It is included for its utility as a unit on 'Disj' and possibly as --- a zero on 'Conj' --- --- Laws (reflected in implementations of smart constructors): --- Commutativity of conjunction: Conj a b === Conj b a --- Commutativity of disjunction: Disj a b === Disj b a --- Associativity of conjunction: Conj (Conj a b) c === Conj a (Conj b c) --- Associativity of disjunction: Disj (Disj a b) c === Disj a (Disj b c) --- Identity of conjunction: Any `Conj` a === a --- Identity of disjunction: None `Disj` a === a --- Zero of conjunction: None `Conj` a === None --- Zero of disjunction: Any `Disj` a === Any --- Distributivity of conjunction over disjunction: Conj a (Disj b c) === Disj (Conj a b) (Conj a c) --- Distributivity of disjunction over conjunction: Disj a (Conj b c) === Conj (Disj a b) (Disj a c) -data VersionRange - = Anchor Operator Version - | Conj VersionRange VersionRange - | Disj VersionRange VersionRange - | Any - | None - deriving (Eq) - --- | Smart constructor for conjunctions. Eagerly evaluates zeros and identities -conj :: VersionRange -> VersionRange -> VersionRange -conj Any b = b -conj a Any = a -conj None _ = None -conj _ None = None -conj a b = Conj a b - --- | Smart constructor for disjunctions. Eagerly evaluates zeros and identities -disj :: VersionRange -> VersionRange -> VersionRange -disj Any _ = Any -disj _ Any = Any -disj None b = b -disj a None = a -disj a b = Disj a b - -exactly :: Version -> VersionRange -exactly = Anchor (Right EQ) - -instance Show VersionRange where - show (Anchor ( Left EQ) v ) = '!' : '=' : show v - show (Anchor ( Right EQ) v ) = '=' : show v - show (Anchor ( Left LT) v ) = '>' : '=' : show v - show (Anchor ( Right LT) v ) = '<' : show v - show (Anchor ( Left GT) v ) = '<' : '=' : show v - show (Anchor ( Right GT) v ) = '>' : show v - show (Conj a@(Disj _ _) b@(Disj _ _)) = paren (show a) <> (' ' : paren (show b)) - show (Conj a@(Disj _ _) b ) = paren (show a) <> (' ' : show b) - show (Conj a b@(Disj _ _)) = show a <> (' ' : paren (show b)) - show (Conj a b ) = show a <> (' ' : show b) - show (Disj a b ) = show a <> " || " <> show b - show Any = "*" - show None = "!" -instance Read VersionRange where - readsPrec _ s = case Atto.parseOnly parseRange (T.pack s) of - Left _ -> [] - Right a -> [(a, "")] - -paren :: String -> String -paren = mappend "(" . flip mappend ")" - -newtype AnyRange = AnyRange { unAnyRange :: VersionRange } -instance Semigroup AnyRange where - (<>) = AnyRange <<$>> disj `on` unAnyRange -instance Monoid AnyRange where - mempty = AnyRange None - -newtype AllRange = AllRange { unAllRange :: VersionRange } -instance Semigroup AllRange where - (<>) = AllRange <<$>> conj `on` unAllRange -instance Monoid AllRange where - mempty = AllRange Any - --- | Predicate for deciding whether the 'Version' is in the 'VersionRange' -satisfies :: Version -> VersionRange -> Bool -satisfies v (Anchor op v') = either (\c x y -> compare x y /= c) (\c x y -> compare x y == c) op v v' -satisfies v (Conj a b ) = v `satisfies` a && v `satisfies` b -satisfies v (Disj a b ) = v `satisfies` a || v `satisfies` b -satisfies _ Any = True -satisfies _ None = False - -(<||) :: Version -> VersionRange -> Bool -(<||) = satisfies -{-# INLINE (<||) #-} - -(||>) :: VersionRange -> Version -> Bool -(||>) = flip satisfies -{-# INLINE (||>) #-} - -(<<$>>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) -(<<$>>) = fmap . fmap -{-# INLINE (<<$>>) #-} - -parseOperator :: Atto.Parser Operator -parseOperator = - (Atto.char '=' $> Right EQ) - <|> (Atto.string "!=" $> Left EQ) - <|> (Atto.string ">=" $> Left LT) - <|> (Atto.string "<=" $> Left GT) - <|> (Atto.char '>' $> Right GT) - <|> (Atto.char '<' $> Right LT) - -parseVersion :: Atto.Parser Version -parseVersion = do - major' <- Atto.decimal <* Atto.char '.' - minor' <- Atto.decimal <* Atto.char '.' - patch' <- Atto.decimal - quad' <- Atto.option 0 $ Atto.char '.' *> Atto.decimal - pure $ Version (major', minor', patch', quad') - --- >>> Atto.parseOnly parseRange "=2.3.4 1.2.3.4 - 2.3.4.5 (>3.0.0 || <3.4.5)" --- Right =2.3.4 >=1.2.3.4 <=2.3.4.5 ((>3.0.0 || <3.4.5)) --- >>> Atto.parseOnly parseRange "0.2.6" --- Right =0.2.6 -parseRange :: Atto.Parser VersionRange -parseRange = s <|> (Atto.char '*' *> pure Any) <|> (Anchor (Right EQ) <$> parseVersion) - where - sub = Atto.char '(' *> Atto.skipSpace *> parseRange <* Atto.skipSpace <* Atto.char ')' - s = - unAnyRange - . foldMap AnyRange - <$> ((p <|> sub) `Atto.sepBy1` (Atto.skipSpace *> Atto.string "||" <* Atto.skipSpace)) - p = unAllRange . foldMap AllRange <$> ((a <|> sub) `Atto.sepBy1` Atto.space) - a = liftA2 Anchor parseOperator parseVersion <|> caret <|> tilde <|> wildcard <|> hyphen - --- >>> liftA2 satisfies (Atto.parseOnly parseVersion "0.20.1.1") (Atto.parseOnly parseRange "^0.20.1") --- Right True -caret :: Atto.Parser VersionRange -caret = (Atto.char '^' *> parseVersion) <&> \case - v@(Version (0, 0, 0, _)) -> Anchor (Right EQ) v - v@(Version (0, 0, z, _)) -> rangeIE v (Version (0, 0, z + 1, 0)) - v@(Version (0, y, _, _)) -> rangeIE v (Version (0, y + 1, 0, 0)) - v@(Version (x, _, _, _)) -> rangeIE v (Version (x + 1, 0, 0, 0)) - --- >>> Atto.parseOnly tilde "~1.2.3.4" --- Right >=1.2.3.4 <1.2.4 -tilde :: Atto.Parser VersionRange -tilde = (Atto.char '~' *> (Atto.decimal `Atto.sepBy1` Atto.char '.')) >>= \case - [x, y, z, q] -> pure $ rangeIE (Version (x, y, z, q)) (Version (x, y, z + 1, 0)) - [x, y, z] -> pure $ rangeIE (Version (x, y, z, 0)) (Version (x, y + 1, 0, 0)) - [x, y] -> pure $ rangeIE (Version (x, y, 0, 0)) (Version (x, y + 1, 0, 0)) - [x] -> pure $ rangeIE (Version (x, 0, 0, 0)) (Version (x + 1, 0, 0, 0)) - o -> fail $ "Invalid number of version numbers: " <> show (length o) - -range :: Bool -> Bool -> Version -> Version -> VersionRange -range inc0 inc1 v0 v1 = - let lo = if inc0 then Left LT else Right GT - hi = if inc1 then Left GT else Right LT - in Conj (Anchor lo v0) (Anchor hi v1) - -rangeIE :: Version -> Version -> VersionRange -rangeIE = range True False - --- >>> Atto.parseOnly wildcard "1.2.3.x" --- Right >=1.2.3 <1.2.4 -wildcard :: Atto.Parser VersionRange -wildcard = (Atto.many1 (Atto.decimal <* Atto.char '.') <* Atto.char 'x') >>= \case - [x, y, z] -> pure $ rangeIE (Version (x, y, z, 0)) (Version (x, y, z + 1, 0)) - [x, y] -> pure $ rangeIE (Version (x, y, 0, 0)) (Version (x, y + 1, 0, 0)) - [x] -> pure $ rangeIE (Version (x, 0, 0, 0)) (Version (x + 1, 0, 0, 0)) - o -> fail $ "Invalid number of version numbers: " <> show (length o) - --- >>> Atto.parseOnly hyphen "0.1.2.3 - 1.2.3.4" --- Right >=0.1.2.3 <=1.2.3.4 -hyphen :: Atto.Parser VersionRange -hyphen = liftA2 (range True True) parseVersion (Atto.skipSpace *> Atto.char '-' *> Atto.skipSpace *> parseVersion) diff --git a/agent/src/Lib/Types/Emver/Orphans.hs b/agent/src/Lib/Types/Emver/Orphans.hs deleted file mode 100644 index caee49c8f..000000000 --- a/agent/src/Lib/Types/Emver/Orphans.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Lib.Types.Emver.Orphans where - -import Startlude - -import Control.Monad.Fail -import Data.Aeson -import qualified Data.Attoparsec.Text as Atto -import qualified Data.Text as T -import Database.Persist -import Database.Persist.Sql -import Web.HttpApiData -import Yesod.Core.Dispatch - -import Lib.Types.Emver - -instance ToJSON Version where - toJSON = String . show -instance FromJSON Version where - parseJSON = withText - "Quad Semver" - \t -> case Atto.parseOnly parseVersion t of - Left e -> fail e - Right a -> pure a -instance ToJSON VersionRange where - toJSON = String . show -instance FromJSON VersionRange where - parseJSON = withText "Quad Semver Range" $ \t -> case Atto.parseOnly parseRange t of - Left e -> fail e - Right a -> pure a - -instance PersistField Version where - toPersistValue = toPersistValue @Text . show - fromPersistValue = first T.pack . Atto.parseOnly parseVersion <=< fromPersistValue -instance PersistFieldSql Version where - sqlType _ = SqlString -instance FromHttpApiData Version where - parseUrlPiece = first toS . Atto.parseOnly parseVersion -instance ToHttpApiData Version where - toUrlPiece = show - -instance PathPiece Version where - toPathPiece = show - fromPathPiece = hush . Atto.parseOnly parseVersion - -instance PathPiece VersionRange where - toPathPiece = show - fromPathPiece = hush . Atto.parseOnly parseRange diff --git a/agent/src/Lib/Types/NetAddress.hs b/agent/src/Lib/Types/NetAddress.hs deleted file mode 100644 index 9b78522b7..000000000 --- a/agent/src/Lib/Types/NetAddress.hs +++ /dev/null @@ -1,17 +0,0 @@ -module Lib.Types.NetAddress where - -import Startlude -import Protolude.Base ( show ) - -newtype TorAddress = TorAddress { unTorAddress :: Text } deriving (Eq) -instance Show TorAddress where - show = toS . unTorAddress - -newtype LanAddress = LanAddress { unLanAddress :: Text } deriving (Eq) -instance Show LanAddress where - show = toS . unLanAddress - -newtype LanIp = LanIp { unLanIp :: Text } deriving (Eq) -instance Show LanIp where - show = toS . unLanIp - diff --git a/agent/src/Lib/Types/ServerApp.hs b/agent/src/Lib/Types/ServerApp.hs deleted file mode 100644 index 9db1c67c9..000000000 --- a/agent/src/Lib/Types/ServerApp.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} -module Lib.Types.ServerApp where - -import Startlude hiding ( break ) - -import Data.Aeson - -import Lib.Types.Core -import Lib.Types.Emver -import Lib.Types.Emver.Orphans ( ) - -data StoreApp = StoreApp - { storeAppId :: AppId - , storeAppTitle :: Text - , storeAppDescriptionShort :: Text - , storeAppDescriptionLong :: Text - , storeAppIconUrl :: Text - , storeAppVersions :: NonEmpty StoreAppVersionInfo - , storeAppTimestamp :: UTCTime - } - deriving (Eq, Show) - -data StoreAppVersionInfo = StoreAppVersionInfo - { storeAppVersionInfoVersion :: Version - , storeAppVersionInfoReleaseNotes :: Text - , storeAppVersionInfoInstallAlert :: Maybe Text - } - deriving (Eq, Show) -instance Ord StoreAppVersionInfo where - compare = compare `on` storeAppVersionInfoVersion -instance FromJSON StoreAppVersionInfo where - parseJSON = withObject "Store App Version Info" $ \o -> do - storeAppVersionInfoVersion <- o .: "version" - storeAppVersionInfoReleaseNotes <- o .: "release-notes" - storeAppVersionInfoInstallAlert <- o .:? "install-alert" - pure StoreAppVersionInfo { .. } -instance ToJSON StoreAppVersionInfo where - toJSON StoreAppVersionInfo {..} = - object ["version" .= storeAppVersionInfoVersion, "releaseNotes" .= storeAppVersionInfoReleaseNotes] diff --git a/agent/src/Lib/Types/Url.hs b/agent/src/Lib/Types/Url.hs deleted file mode 100644 index df164f67b..000000000 --- a/agent/src/Lib/Types/Url.hs +++ /dev/null @@ -1,50 +0,0 @@ -module Lib.Types.Url where - -import Startlude - -import Control.Monad.Fail -import qualified Data.Attoparsec.Text as A -import qualified GHC.Show ( Show(..) ) - --- this is a very weak definition of url, it needs to be fleshed out in accordance with https://www.ietf.org/rfc/rfc1738.txt -data Url = Url - { urlScheme :: Text - , urlHost :: Text - , urlPort :: Word16 - } - deriving Eq -instance Show Url where - show (Url scheme host port) = toS $ scheme <> "://" <> host <> ":" <> show port - -parseUrl :: Text -> Either String Url -parseUrl t = A.parseOnly urlParser (toS t) - -urlParser :: A.Parser Url -urlParser = do - (scheme, defPort) <- A.option ("https", 443) $ schemeParser >>= \case - "http" -> pure ("http", 80) - "https" -> pure ("https", 443) - other -> fail $ "Invalid Scheme: " <> toS other - eHost <- fmap Left (untilParser ":") <|> fmap Right (atLeastParser 2) - case eHost of - Left host -> Url scheme host <$> portParser - Right host -> pure $ Url scheme host defPort - -untilParser :: Text -> A.Parser Text -untilParser t = toS <$> A.manyTill A.anyChar (A.string t) - -atLeastParser :: Int -> A.Parser Text -atLeastParser n = do - minLength <- toS <$> A.count n A.anyChar - rest <- A.takeText - pure $ minLength <> rest - -portParser :: A.Parser Word16 -portParser = do - port <- A.decimal - A.atEnd >>= \case - True -> pure port - False -> fail "invalid port" - -schemeParser :: A.Parser Text -schemeParser = toS <$> A.manyTill A.anyChar (A.string "://") diff --git a/agent/src/Lib/WebServer.hs b/agent/src/Lib/WebServer.hs deleted file mode 100644 index 5cc6b162f..000000000 --- a/agent/src/Lib/WebServer.hs +++ /dev/null @@ -1,188 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Lib.WebServer where - -import Startlude hiding ( exp ) - -import Control.Monad.Logger -import Data.Default -import Data.IORef -import Language.Haskell.TH.Syntax ( qLocation ) -import Network.Wai -import Network.Wai.Handler.Warp ( Settings - , defaultSettings - , defaultShouldDisplayException - , runSettings - , setHost - , setOnException - , setPort - ) -import Network.Wai.Middleware.Cors ( CorsResourcePolicy(..) - , cors - , simpleCorsResourcePolicy - ) -import Network.Wai.Middleware.RequestLogger - ( Destination(Logger) - , IPAddrSource(..) - , OutputFormat(..) - , destination - , mkRequestLogger - , outputFormat - ) -import Yesod.Core -import Yesod.Core.Types hiding ( Logger ) - -import Auth -import Foundation -import Handler.Apps -import Handler.Authenticate -import Handler.Backups -import Handler.Hosts -import Handler.Icons -import Handler.Login -import Handler.Network -import Handler.Notifications -import Handler.PasswordUpdate -import Handler.PowerOff -import Handler.Register -import Handler.SelfUpdate -import Handler.SshKeys -import Handler.Status -import Handler.Wifi -import Handler.V0 -import Settings -import Network.HTTP.Types.Header ( hOrigin ) -import Data.List (lookup) - --- This line actually creates our YesodDispatch instance. It is the second half --- of the call to mkYesodData which occurs in Foundation.hs. Please see the --- comments there for more details. -mkYesodDispatch "AgentCtx" resourcesAgentCtx - -instance YesodSubDispatch Auth AgentCtx where - yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth) - -dynamicCorsResourcePolicy :: Request -> Maybe CorsResourcePolicy -dynamicCorsResourcePolicy req = Just . policy . lookup hOrigin $ requestHeaders req - where - policy o = simpleCorsResourcePolicy - { corsOrigins = (\o' -> ([o'], True)) <$> o - , corsMethods = ["GET", "POST", "HEAD", "PUT", "DELETE", "TRACE", "CONNECT", "OPTIONS", "PATCH"] - , corsRequestHeaders = [ "app-version" - , "Accept" - , "Accept-Charset" - , "Accept-Encoding" - , "Accept-Language" - , "Accept-Ranges" - , "Age" - , "Allow" - , "Authorization" - , "Cache-Control" - , "Connection" - , "Content-Encoding" - , "Content-Language" - , "Content-Length" - , "Content-Location" - , "Content-MD5" - , "Content-Range" - , "Content-Type" - , "Date" - , "ETag" - , "Expect" - , "Expires" - , "From" - , "Host" - , "If-Match" - , "If-Modified-Since" - , "If-None-Match" - , "If-Range" - , "If-Unmodified-Since" - , "Last-Modified" - , "Location" - , "Max-Forwards" - , "Pragma" - , "Proxy-Authenticate" - , "Proxy-Authorization" - , "Range" - , "Referer" - , "Retry-After" - , "Server" - , "TE" - , "Trailer" - , "Transfer-Encoding" - , "Upgrade" - , "User-Agent" - , "Vary" - , "Via" - , "WWW-Authenticate" - , "Warning" - , "Content-Disposition" - , "MIME-Version" - , "Cookie" - , "Set-Cookie" - , "Origin" - , "Prefer" - , "Preference-Applied" - ] - , corsIgnoreFailures = True - } - --- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and --- applying some additional middlewares. -makeApplication :: AgentCtx -> IO Application -makeApplication foundation = do - logWare <- makeLogWare foundation - -- Create the WAI application and apply middlewares - appPlain <- toWaiAppPlain foundation - pure . logWare . cors dynamicCorsResourcePolicy . defaultMiddlewaresNoLogging $ appPlain - -startWeb :: AgentCtx -> IO () -startWeb foundation = do - app <- makeApplication foundation - - putStrLn @Text $ "Launching Web Server on port " <> show (appPort $ appSettings foundation) - action <- async $ runSettings (warpSettings foundation) app - - setWebProcessThreadId (asyncThreadId action) foundation - wait action - -shutdownAll :: [ThreadId] -> IO () -shutdownAll threadIds = do - for_ threadIds killThread - exitSuccess - -shutdownWeb :: AgentCtx -> IO () -shutdownWeb AgentCtx {..} = do - mThreadId <- readIORef appWebServerThreadId - for_ mThreadId $ \tid -> do - killThread tid - writeIORef appWebServerThreadId Nothing - -makeLogWare :: AgentCtx -> IO Middleware -makeLogWare foundation = mkRequestLogger def - { outputFormat = if appDetailedRequestLogging $ appSettings foundation - then Detailed True - else Apache (if appIpFromHeader $ appSettings foundation then FromFallback else FromSocket) - , destination = Logger $ loggerSet $ appLogger foundation - } - --- | Warp settings for the given foundation value. -warpSettings :: AgentCtx -> Settings -warpSettings foundation = - setPort (fromIntegral . appPort $ appSettings foundation) - $ setHost (appHost $ appSettings foundation) - $ setOnException - (\_req e -> when (defaultShouldDisplayException e) $ messageLoggerSource - foundation - (appLogger foundation) - $(qLocation >>= liftLoc) - "yesod" - LevelError - (toLogStr $ "Exception from Warp: " ++ show e) - ) - defaultSettings diff --git a/agent/src/Model.hs b/agent/src/Model.hs deleted file mode 100644 index 336548d7d..000000000 --- a/agent/src/Model.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoDeriveAnyClass #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -module Model where - -import Startlude - -import Crypto.Hash -import Data.UUID -import Database.Persist.TH - -import Lib.Types.Core -import Lib.Types.Emver -import Lib.Types.Emver.Orphans ( ) -import Orphans.Digest ( ) -import Orphans.UUID ( ) - -share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| -Account - createdAt UTCTime - updatedAt UTCTime - name Text - password Text - UniqueAccount name - -ExecutedMigration - createdAt UTCTime - updatedAt UTCTime - srcVersion Version - tgtVersion Version - deriving Eq - deriving Show - -Notification json - Id UUID - createdAt UTCTime - archivedAt UTCTime Maybe - appId AppId - appVersion Version - code Text - title Text - message Text - deriving Eq - deriving Show - -BackupRecord sql=backup - Id UUID - createdAt UTCTime - appId AppId - appVersion Version - succeeded Bool - -IconDigest - Id AppId - tag (Digest MD5) - -WelcomeAck - Id Version -|] diff --git a/agent/src/Orphans/Digest.hs b/agent/src/Orphans/Digest.hs deleted file mode 100644 index 819a55948..000000000 --- a/agent/src/Orphans/Digest.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -module Orphans.Digest where - -import Startlude - -import Crypto.Hash -import Data.ByteArray -import Data.ByteArray.Encoding -import Data.String.Interpolate.IsString -import Database.Persist.Sql -import Web.HttpApiData - -instance HashAlgorithm a => PersistField (Digest a) where - toPersistValue = PersistByteString . convert - fromPersistValue (PersistByteString bs) = - note [i|Invalid Digest: #{decodeUtf8 $ convertToBase Base16 bs}|] . digestFromByteString $ bs - fromPersistValue other = Left $ "Invalid Digest: " <> show other - -instance HashAlgorithm a => PersistFieldSql (Digest a) where - sqlType _ = SqlBlob - -instance HashAlgorithm a => ToHttpApiData (Digest a) where - toUrlPiece = decodeUtf8 . convertToBase Base16 diff --git a/agent/src/Orphans/UUID.hs b/agent/src/Orphans/UUID.hs deleted file mode 100644 index f28a0b452..000000000 --- a/agent/src/Orphans/UUID.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Orphans.UUID where - -import Startlude - -import Data.UUID -import Database.Persist.Sql -import Yesod.Core - -instance PathPiece UUID where - toPathPiece = show - fromPathPiece = readMaybe -instance PersistField UUID where - toPersistValue = PersistText . show - fromPersistValue (PersistText t) = note "Invalid UUID" $ readMaybe t - fromPersistValue other = Left $ "Invalid UUID: " <> show other -instance PersistFieldSql UUID where - sqlType _ = SqlString diff --git a/agent/src/Settings.hs b/agent/src/Settings.hs deleted file mode 100644 index f67f82053..000000000 --- a/agent/src/Settings.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} --- | Settings are centralized, as much as possible, into this file. This --- includes database connection settings, static file locations, etc. --- In addition, you can configure a number of different aspects of Yesod --- by overriding methods in the Yesod typeclass. That instance is --- declared in the Foundation.hs file. -module Settings where - -import Startlude - -import qualified Control.Effect.Labelled as Fused -import qualified Control.Exception as Exception -import Data.Aeson -import Data.FileEmbed ( embedFile ) -import Data.Yaml ( decodeEither' ) -import Database.Persist.Sqlite ( SqliteConf(..) ) -import Network.Wai.Handler.Warp ( HostPreference ) -import Yesod.Default.Config2 ( applyEnvValue - , configSettingsYml - ) -import Lib.Types.Emver -import Lib.Types.Emver.Orphans ( ) - --- | Runtime settings to configure this application. These settings can be --- loaded from various sources: defaults, environment variables, config files, --- theoretically even a database. -data AppSettings = AppSettings - { appDatabaseConf :: SqliteConf - -- ^ Configuration settings for accessing the database. - , appHost :: HostPreference - -- ^ Host/interface the server should bind to. - , appPort :: Word16 - -- ^ Port to listen on - , appIpFromHeader :: Bool - -- ^ Get the IP address from the header when logging. Useful when sitting - -- behind a reverse proxy. - , appDetailedRequestLogging :: Bool - -- ^ Use detailed request logging system - , appShouldLogAll :: Bool - -- ^ Should all log messages be displayed? - , appMgrVersionSpec :: VersionRange - , appFilesystemBase :: Text - , appTorSocksPort :: Word16 - -- ^ Port on localhost where the tor client is listening, defaults to 9050 - , appTorRestartCooldown :: NominalDiffTime - } - deriving Show - -instance FromJSON AppSettings where - parseJSON = withObject "AppSettings" $ \o -> do - appDatabaseConf <- o .: "database" >>= withObject - "database conf" - (\db -> do - dbName <- db .: "database" - poolSize <- db .: "poolsize" - pure $ SqliteConf dbName poolSize - ) - - appHost <- fromString <$> o .: "host" - appPort <- o .: "port" - appIpFromHeader <- o .: "ip-from-header" - - appDetailedRequestLogging <- o .:? "detailed-logging" .!= False - appShouldLogAll <- o .:? "should-log-all" .!= False - - appMgrVersionSpec <- o .: "app-mgr-version-spec" - appFilesystemBase <- o .: "filesystem-base" - appTorSocksPort <- o .:? "tor-socks-port" .!= 9050 - appTorRestartCooldown <- o .:? "tor-restart-cooldown" .!= (secondsToNominalDiffTime 600) - return AppSettings { .. } - --- | Raw bytes at compile time of @config/settings.yml@ -configSettingsYmlBS :: ByteString -configSettingsYmlBS = $(embedFile configSettingsYml) - --- | @config/settings.yml@, parsed to a @Value@. -configSettingsYmlValue :: Value -configSettingsYmlValue = either Exception.throw id $ decodeEither' configSettingsYmlBS - --- | A version of @AppSettings@ parsed at compile time from @config/settings.yml@. -compileTimeAppSettings :: AppSettings -compileTimeAppSettings = case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of - Error e -> panic $ toS e - Success settings -> settings - -injectSettings :: Monad m => AppSettings -> Fused.Labelled "appSettings" (ReaderT AppSettings) m a -> m a -injectSettings s = flip runReaderT s . Fused.runLabelled @"appSettings" diff --git a/agent/src/Startlude.hs b/agent/src/Startlude.hs deleted file mode 100644 index 4da76e12d..000000000 --- a/agent/src/Startlude.hs +++ /dev/null @@ -1,135 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE UndecidableInstances #-} -module Startlude - ( module X - , module Startlude - ) -where - -import Control.Arrow as X - ( (&&&) ) -import Control.Comonad as X -import Control.Monad.Trans.Maybe as X -import Control.Error.Util as X - hiding ( (??) ) -import Data.Coerce as X -import Data.String as X - ( String - , fromString - ) -import Data.Time.Clock as X -import Protolude as X - hiding ( bool - , hush - , isLeft - , isRight - , note - , tryIO - , readMaybe - , (:+:) - , throwError - , toTitle - , toStrict - , toUpper - , Handler(..) - , yield - , type (==) - ) -import qualified Protolude as P - ( readMaybe ) - --- not reexported -import Control.Monad.Logger -import Control.Monad.Trans.Resource -import qualified Control.Carrier.Lift as FE -import qualified Control.Carrier.Reader as FE -import qualified Control.Carrier.Error.Church as FE -import qualified Control.Effect.Labelled as FE -import Data.Singletons.Prelude.Eq ( PEq ) -import Yesod.Core ( MonadHandler(..) ) -import Control.Monad.Trans.Control -import Control.Monad.Base - -id :: a -> a -id = identity - -ioLogFailure :: Exception e => String -> e -> IO () -ioLogFailure t e = putStrLn @Text (toS t <> show e) >> pure () - -readMaybe :: Read a => Text -> Maybe a -readMaybe = P.readMaybe . toS - --- orphans for stitching fused effects into the larger ecosystem -instance MonadResource (sub m) => MonadResource (FE.Labelled label sub m) where - liftResourceT = FE.Labelled . liftResourceT -instance MonadResource m => MonadResource (FE.LiftC m) where - liftResourceT = FE.LiftC . liftResourceT -instance MonadResource m => MonadResource (FE.ReaderC r m) where - liftResourceT = lift . liftResourceT -instance MonadResource m => MonadResource (FE.ErrorC e m) where - liftResourceT = lift . liftResourceT - -instance MonadThrow (sub m) => MonadThrow (FE.Labelled label sub m) where - throwM = FE.Labelled . throwM -instance MonadThrow m => MonadThrow (FE.LiftC m) where - throwM = FE.LiftC . throwM - -instance MonadLogger m => MonadLogger (FE.ErrorC e m) where -instance MonadLogger m => MonadLogger (FE.LiftC m) where -instance MonadLogger (sub m) => MonadLogger (FE.Labelled label sub m) where - monadLoggerLog a b c d = FE.Labelled $ monadLoggerLog a b c d - -instance MonadHandler m => MonadHandler (FE.LiftC m) where - type HandlerSite (FE.LiftC m) = HandlerSite m - type SubHandlerSite (FE.LiftC m) = SubHandlerSite m - liftHandler = FE.LiftC . liftHandler - liftSubHandler = FE.LiftC . liftSubHandler - -instance MonadHandler (sub m) => MonadHandler (FE.Labelled label sub m) where - type HandlerSite (FE.Labelled label sub m) = HandlerSite (sub m) - type SubHandlerSite (FE.Labelled label sub m) = SubHandlerSite (sub m) - liftHandler = FE.Labelled . liftHandler - liftSubHandler = FE.Labelled . liftSubHandler - - -instance MonadHandler m => MonadHandler (FE.ErrorC e m) where - type HandlerSite (FE.ErrorC e m) = HandlerSite m - type SubHandlerSite (FE.ErrorC e m) = SubHandlerSite m - liftHandler = lift . liftHandler - liftSubHandler = lift . liftSubHandler - -instance MonadTransControl t => MonadTransControl (FE.Labelled k t) where - type StT (FE.Labelled k t) a = StT t a - liftWith f = FE.Labelled $ liftWith $ \run -> f (run . FE.runLabelled) - restoreT = FE.Labelled . restoreT -instance MonadBase IO (t m) => MonadBase IO (FE.Labelled k t m) where - liftBase = FE.Labelled . liftBase -instance MonadBaseControl IO (t m) => MonadBaseControl IO (FE.Labelled k t m) where - type StM (FE.Labelled k t m) a = StM (t m) a - liftBaseWith f = FE.Labelled $ liftBaseWith $ \run -> f (run . FE.runLabelled) - restoreM = FE.Labelled . restoreM -instance MonadBase IO m => MonadBase IO (FE.LiftC m) where - liftBase = FE.LiftC . liftBase -instance MonadTransControl FE.LiftC where - type StT (FE.LiftC) a = a - liftWith f = FE.LiftC $ f $ FE.runM - restoreT = FE.LiftC -instance MonadBaseControl IO m => MonadBaseControl IO (FE.LiftC m) where - type StM (FE.LiftC m) a = StM m a - liftBaseWith = defaultLiftBaseWith - restoreM = defaultRestoreM -instance MonadBase IO m => MonadBase IO (FE.ErrorC e m) where - liftBase = liftBaseDefault -instance MonadTransControl (FE.ErrorC e) where - type StT (FE.ErrorC e) a = Either e a - liftWith f = FE.ErrorC $ \_ leaf -> f (FE.runError (pure . Left) (pure . Right)) >>= leaf - restoreT m = FE.ErrorC $ \fail leaf -> m >>= \case - Left e -> fail e - Right a -> leaf a -instance MonadBaseControl IO m => MonadBaseControl IO (FE.ErrorC e m) where - type StM (FE.ErrorC e m) a = StM m (Either e a) - liftBaseWith = defaultLiftBaseWith - restoreM = defaultRestoreM - - -instance PEq Type -- DRAGONS? I may rue the day I decided to do this diff --git a/agent/src/Startlude/ByteStream.hs b/agent/src/Startlude/ByteStream.hs deleted file mode 100644 index 3c45edd70..000000000 --- a/agent/src/Startlude/ByteStream.hs +++ /dev/null @@ -1,7 +0,0 @@ --- {-# OPTIONS_GHC -fno-warn-unused-imports #-} -module Startlude.ByteStream - ( module BS - ) where - -import Streaming.ByteString as BS - hiding ( ByteString ) diff --git a/agent/src/Startlude/ByteStream/Char8.hs b/agent/src/Startlude/ByteStream/Char8.hs deleted file mode 100644 index 0952cca54..000000000 --- a/agent/src/Startlude/ByteStream/Char8.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Startlude.ByteStream.Char8 - ( module X - ) where - -import Streaming.ByteString.Char8 as X diff --git a/agent/src/Util/Conduit.hs b/agent/src/Util/Conduit.hs deleted file mode 100644 index d3150abc7..000000000 --- a/agent/src/Util/Conduit.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Util.Conduit where - -import Startlude - -import Conduit -import Data.Text as T -import Data.Attoparsec.Text - -parseC :: MonadIO m => Parser b -> ConduitT Text b m () -parseC parser = fix $ \cont -> parseWith g parser "" >>= \case - Done rest result -> do - yield result - unless (T.null rest) $ leftover rest >> cont - Fail _ _ msg -> panic $ toS msg - Partial _ -> panic "INCOMPLETE PARSE" - where - g :: MonadIO m => ConduitT Text o m Text - g = await >>= \case - Nothing -> pure mempty - Just x -> print x >> pure x - -lineParser :: Parser Text -lineParser = takeTill isEndOfLine <* endOfLine diff --git a/agent/src/Util/File.hs b/agent/src/Util/File.hs deleted file mode 100644 index 751c9dc01..000000000 --- a/agent/src/Util/File.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Util.File where - -import Startlude - -import System.Directory -import System.IO.Error - -removeFileIfExists :: MonadIO m => FilePath -> m () -removeFileIfExists fileName = liftIO $ removeFile fileName `catch` handleExists - where - handleExists e | isDoesNotExistError e = return () - | otherwise = throwIO e diff --git a/agent/src/Util/Function.hs b/agent/src/Util/Function.hs deleted file mode 100644 index a04628b10..000000000 --- a/agent/src/Util/Function.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Util.Function where - -import Startlude - -infixr 9 .* -(.*) :: (b -> c) -> (a0 -> a1 -> b) -> a0 -> a1 -> c -(.*) = (.) . (.) -{-# INLINE (.*) #-} - -infixr 9 .** -(.**) :: (b -> c) -> (a0 -> a1 -> a2 -> b) -> a0 -> a1 -> a2 -> c -(.**) = (.) . (.*) -{-# INLINE (.**) #-} - -uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d -uncurry3 f (a, b, c) = f a b c diff --git a/agent/src/Util/Text.hs b/agent/src/Util/Text.hs deleted file mode 100644 index 7e5c23001..000000000 --- a/agent/src/Util/Text.hs +++ /dev/null @@ -1,24 +0,0 @@ -module Util.Text where - -import Data.Text ( strip ) -import Startlude -import Text.Regex ( matchRegexAll - , mkRegex - , subRegex - ) - - --- | Behaves like Ruby gsub implementation -gsub :: Text -> Text -> Text -> Text -gsub regex replaceWith str = toS $ subRegex (mkRegex $ toS regex) (toS str) (toS replaceWith) - -containsMatch :: Text -> Text -> Bool -containsMatch regex str = not . null $ getMatches regex str - -getMatches :: Text -> Text -> [Text] -getMatches regex str - | str == "" = [] - | otherwise = case matchRegexAll (mkRegex $ toS regex) (toS str) of - Nothing -> [] - Just (_, "" , after, _) -> getMatches regex (toS . strip . toS $ after) - Just (_, match, after, _) -> toS match : getMatches regex (toS after) diff --git a/agent/stack.yaml b/agent/stack.yaml deleted file mode 100644 index b6f0eb2ee..000000000 --- a/agent/stack.yaml +++ /dev/null @@ -1,26 +0,0 @@ -resolver: lts-17.10 - -packages: - - . - -extra-deps: - # - aeson-1.4.7.1 - - aeson-flatten-0.1.0.2 - - exinst-0.8 - - fused-effects-1.1.0.0 - - fused-effects-th-0.1.0.2 - - git-embed-0.1.0 - - json-stream-0.4.2.4 - - protolude-0.3.0 - - streaming-bytestring-0.1.7 - - streaming-conduit-0.1.2.2 - - streaming-utils-0.2.0.0 - # to avoid the ridiculous bug where stat64 is not found (only affects development) - # - git: https://github.com/ProofOfKeags/persistent.git - # commit: 3b52b13d9ce79cdef14bb1c37cc527657a529462 - # subdirs: - # - persistent-sqlite - -ghc-options: - "$locals": -fwrite-ide-info - "$everything": -haddock diff --git a/agent/test/ChecklistSpec.hs b/agent/test/ChecklistSpec.hs deleted file mode 100644 index e47956e13..000000000 --- a/agent/test/ChecklistSpec.hs +++ /dev/null @@ -1,20 +0,0 @@ -module ChecklistSpec where - -import Startlude - -import Data.List ( (!!) ) -import Data.Text -import System.Directory -import Test.Hspec - -import Constants -import Lib.Synchronizers - -spec :: Spec -spec = describe "Current Version" $ do - it "Requires System Synchronizer" $ do - agentVersion `shouldSatisfy` (synchronizerVersion synchronizer ==) - it "Requires Migration Target" $ do - names <- liftIO $ listDirectory "migrations" - let targets = names <&> (fromString . toS . (!! 1) . (splitOn "::") . toS) - agentVersion `shouldSatisfy` flip elem targets diff --git a/agent/test/Lib/External/AppManifestSpec.hs b/agent/test/Lib/External/AppManifestSpec.hs deleted file mode 100644 index c8d4a9fc0..000000000 --- a/agent/test/Lib/External/AppManifestSpec.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -module Lib.External.AppManifestSpec where - -import Startlude - -import Test.Hspec - -import Data.String.Interpolate.IsString -import Data.Yaml - -import Lib.External.AppManifest - -cups023Manifest :: ByteString -cups023Manifest = [i| ---- -compat: v0 -id: cups -version: 0.2.3 -title: Cups -description: - short: Peer-to-Peer Encrypted Messaging - long: A peer-to-peer encrypted messaging platform that operates over tor. -release-notes: fix autofill for password field -ports: - - internal: 59001 - tor: 59001 - - internal: 80 - tor: 80 -image: - type: tar -mount: /root -assets: - - src: httpd.conf - dst: "." - overwrite: true - - src: www - dst: "." - overwrite: true -hidden-service-version: v3 -|] - -cups023ManifestModNoUI :: ByteString -cups023ManifestModNoUI = [i| ---- -compat: v0 -id: cups -version: 0.2.3 -title: Cups -description: - short: Peer-to-Peer Encrypted Messaging - long: A peer-to-peer encrypted messaging platform that operates over tor. -release-notes: fix autofill for password field -ports: - - internal: 59001 - tor: 59001 -image: - type: tar -mount: /root -assets: - - src: httpd.conf - dst: "." - overwrite: true - - src: www - dst: "." - overwrite: true -hidden-service-version: v3 -|] - -mastodon330Manifest :: ByteString -mastodon330Manifest = [i| ---- -id: mastodon -version: 3.3.0.1 -title: Mastodon -description: - short: "A free, open-source social network server." - long: "Mastodon is a free, open-source social network server based on ActivityPub where users can follow friends and discover new ones. On Mastodon, users can publish anything they want: links, pictures, text, video. All Mastodon servers are interoperable as a federated network (users on one server can seamlessly communicate with users from another one, including non-Mastodon software that implements ActivityPub)!" -release-notes: Added an acation to reset the admin password -install-alert: "After starting mastodon for the first time, it can take a long time (several minutes) to be ready.\nPlease be patient. On future starts of the service, it will be faster, but still takes longer than other services.\nMake sure to sign up for a user before giving out your link. The first user to sign up is set as the admin user.\n" -uninstall-alert: ~ -restore-alert: ~ -start-alert: "It may take several minutes after startup for this service to be ready for use.\n" -has-instructions: true -os-version-required: ">=0.2.8" -os-version-recommended: ">=0.2.8" -ports: - - internal: 80 - tor: 80 - lan: standard - - internal: 443 - tor: 443 - lan: - custom: - port: 443 - - internal: 3000 - tor: 3000 - lan: ~ - - internal: 4000 - tor: 4000 - lan: ~ -image: - type: tar -shm-size-mb: ~ -mount: /root/persistence -public: ~ -shared: ~ -assets: [] -hidden-service-version: v3 -dependencies: {} -actions: - - id: reset-admin-password - name: Reset Admin Password - description: This action will reset your admin password to a random value - allowed-statuses: - - RUNNING - command: - - docker_entrypoint.sh - - reset_admin_password.sh -|] - - -spec :: Spec -spec = do - describe "parsing app manifest ports" $ do - it "should parse mastodon 3.3.0" $ do - res <- decodeThrow @IO @AppManifest mastodon330Manifest - print res - lanUiAvailable res `shouldBe` True - torUiAvailable res `shouldBe` True - diff --git a/agent/test/Lib/SoundSpec.hs b/agent/test/Lib/SoundSpec.hs deleted file mode 100644 index 129005a4a..000000000 --- a/agent/test/Lib/SoundSpec.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Lib.SoundSpec where - -import Startlude - -import Test.Hspec - -import Lib.Sound - -spec :: Spec -spec = describe "Sound Interface" $ do - it "Async sound actions should be FIFO" $ do - action <- async $ playSongTimed 400 marioDeath - action' <- async $ playSongTimed 400 marioDeath - marks0 <- wait action - marks1 <- wait action' - (marks0, marks1) `shouldSatisfy` \((s0, f0), (s1, f1)) -> s1 > s0 && s1 > f0 || s0 > s1 && s0 > f1 diff --git a/agent/test/Lib/Types/EmverProp.hs b/agent/test/Lib/Types/EmverProp.hs deleted file mode 100644 index f02c9312b..000000000 --- a/agent/test/Lib/Types/EmverProp.hs +++ /dev/null @@ -1,149 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Lib.Types.EmverProp where - -import Startlude hiding ( Any ) - -import Hedgehog as Test -import Lib.Types.Emver -import Hedgehog.Range -import Hedgehog.Gen as Gen -import qualified Data.Attoparsec.Text as Atto - -versionGen :: MonadGen m => m Version -versionGen = do - a <- word (linear 0 30) - b <- word (linear 0 30) - c <- word (linear 0 30) - d <- word (linear 0 30) - pure $ Version (a, b, c, d) - -rangeGen :: MonadGen m => m VersionRange -rangeGen = choice [pure None, pure Any, anchorGen, disjGen, conjGen] - -anchorGen :: MonadGen m => m VersionRange -anchorGen = do - c <- element [LT, EQ, GT] - f <- element [Left, Right] - Anchor (f c) <$> versionGen - -conjGen :: MonadGen m => m VersionRange -conjGen = liftA2 conj rangeGen rangeGen - -disjGen :: MonadGen m => m VersionRange -disjGen = liftA2 disj rangeGen rangeGen - -prop_conjAssoc :: Property -prop_conjAssoc = property $ do - a <- forAll rangeGen - b <- forAll rangeGen - c <- forAll rangeGen - obs <- forAll versionGen - (obs <|| conj a (conj b c)) === (obs <|| conj (conj a b) c) - -prop_conjCommut :: Property -prop_conjCommut = property $ do - a <- forAll rangeGen - b <- forAll rangeGen - obs <- forAll versionGen - (obs <|| conj a b) === (obs <|| conj b a) - -prop_disjAssoc :: Property -prop_disjAssoc = property $ do - a <- forAll rangeGen - b <- forAll rangeGen - c <- forAll rangeGen - obs <- forAll versionGen - (obs <|| disj a (disj b c)) === (obs <|| disj (disj a b) c) - -prop_disjCommut :: Property -prop_disjCommut = property $ do - a <- forAll rangeGen - b <- forAll rangeGen - obs <- forAll versionGen - (obs <|| disj a b) === (obs <|| disj b a) - -prop_anyIdentConj :: Property -prop_anyIdentConj = property $ do - a <- forAll rangeGen - obs <- forAll versionGen - obs <|| conj Any a === obs <|| a - -prop_noneIdentDisj :: Property -prop_noneIdentDisj = property $ do - a <- forAll rangeGen - obs <- forAll versionGen - obs <|| disj None a === obs <|| a - -prop_noneAnnihilatesConj :: Property -prop_noneAnnihilatesConj = property $ do - a <- forAll rangeGen - obs <- forAll versionGen - obs <|| conj None a === obs <|| None - -prop_anyAnnihilatesDisj :: Property -prop_anyAnnihilatesDisj = property $ do - a <- forAll rangeGen - obs <- forAll versionGen - obs <|| disj Any a === obs <|| Any - -prop_conjDistributesOverDisj :: Property -prop_conjDistributesOverDisj = property $ do - a <- forAll rangeGen - b <- forAll rangeGen - c <- forAll rangeGen - obs <- forAll versionGen - obs <|| conj a (disj b c) === obs <|| disj (conj a b) (conj a c) - -prop_disjDistributesOverConj :: Property -prop_disjDistributesOverConj = property $ do - a <- forAll rangeGen - b <- forAll rangeGen - c <- forAll rangeGen - obs <- forAll versionGen - obs <|| disj a (conj b c) === obs <|| conj (disj a b) (disj a c) - -prop_anyAcceptsAny :: Property -prop_anyAcceptsAny = property $ do - obs <- forAll versionGen - assert $ obs <|| Any - -prop_noneAcceptsNone :: Property -prop_noneAcceptsNone = property $ do - obs <- forAll versionGen - assert . not $ obs <|| None - -prop_conjBoth :: Property -prop_conjBoth = property $ do - a <- forAll rangeGen - b <- forAll rangeGen - obs <- forAll versionGen - (obs <|| conj a b) === (obs <|| a && obs <|| b) - -prop_disjEither :: Property -prop_disjEither = property $ do - a <- forAll rangeGen - b <- forAll rangeGen - obs <- forAll versionGen - (obs <|| disj a b) === (obs <|| a || obs <|| b) - -prop_rangeParseRoundTrip :: Property -prop_rangeParseRoundTrip = withShrinks 0 . property $ do - a <- forAll rangeGen - obs <- forAll versionGen - when (a == None) Test.discard - -- we do not use 'tripping' here since 'tripping' requires equality of representation - -- we only want to check equality up to OBSERVATION - (satisfies obs <$> Atto.parseOnly parseRange (show a)) === Right (satisfies obs a) - -prop_anchorLeftIsNegatedRight :: Property -prop_anchorLeftIsNegatedRight = property $ do - a <- forAll anchorGen - neg <- case a of - Anchor (Right o) v -> pure $ Anchor (Left o) v - Anchor (Left o) v -> pure $ Anchor (Right o) v - _ -> Test.discard - obs <- forAll versionGen - obs <|| a /== obs <|| neg - -tests :: IO Bool -tests = checkParallel $ $$discover diff --git a/agent/test/Live/Metrics.hs b/agent/test/Live/Metrics.hs deleted file mode 100644 index 14e22d552..000000000 --- a/agent/test/Live/Metrics.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Live.Metrics where - -import Lib.External.Metrics.Df -import Lib.External.Metrics.Iotop -import Lib.External.Metrics.ProcDev -import Lib.External.Metrics.Top -import Startlude - -parseIotopOutput :: IO IotopMetrics -parseIotopOutput = parseIotop <$> readFile "./test/Live/iotop.sample" - -parseTopOutput :: IO TopMetrics -parseTopOutput = parseTop <$> readFile "./test/Live/top.sample" - -parseDfOutput :: IO DfMetrics -parseDfOutput = parseDf <$> readFile "./test/Live/df.sample" - -parseProcDevOutput :: IO (UTCTime, ProcDevMomentStats) -parseProcDevOutput = do - res <- readFile "./test/Live/procDev.sample" - now <- getCurrentTime - pure $ parseProcDev now res diff --git a/agent/test/Live/Serialize.hs b/agent/test/Live/Serialize.hs deleted file mode 100644 index bf74279c9..000000000 --- a/agent/test/Live/Serialize.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -module Live.Serialize where - -import Startlude hiding ( runReader ) - -import Control.Carrier.Lift -import Data.String.Interpolate.IsString - -import Application -import Lib.Algebra.State.RegistryUrl -import Lib.External.Registry -import Lib.SystemPaths - -someYaml :: ByteString -someYaml = [i| -bitcoind: - title: "Bitcoin Core" - description: - short: "A Bitcoin Full Node" - long: "The bitcoin full node implementation by Bitcoin Core." - version-info: - - version: 0.18.1 - release-notes: "Some stuff" - icon-type: png -|] - -appRegistryTest :: IO (Either String AppManifestRes) -appRegistryTest = do - settings <- getAppSettings - runM . injectFilesystemBaseFromContext settings . runRegistryUrlIOC $ parseBsManifest someYaml diff --git a/agent/test/Live/df.sample b/agent/test/Live/df.sample deleted file mode 100644 index 09e838c6a..000000000 --- a/agent/test/Live/df.sample +++ /dev/null @@ -1,2 +0,0 @@ -Filesystem 1K-blocks Used Available Use% Mounted on -/dev/root 30391116 16800060 12320856 58% / \ No newline at end of file diff --git a/agent/test/Live/iotop.sample b/agent/test/Live/iotop.sample deleted file mode 100644 index 1186d0214..000000000 --- a/agent/test/Live/iotop.sample +++ /dev/null @@ -1,119 +0,0 @@ -Total DISK READ : 0.00 B/s | Total DISK WRITE : 0.00 B/s -Actual DISK READ: 0.00 B/s | Actual DISK WRITE: 0.00 B/s - TID PRIO USER DISK READ DISK WRITE SWAPIN IO COMMAND - 1 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % init - 2 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [kthreadd] - 4 be/0 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [kworker/0:0H] - 6 be/0 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [mm_percpu_wq] - 7 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [ksoftirqd/0] - 8 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [rcu_sched] - 9 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [rcu_bh] - 10 rt/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [migration/0] - 11 rt/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [watchdog/0] - 12 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [cpuhp/0] - 13 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [kdevtmpfs] - 14 be/0 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [netns] - 15 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [rcu_tasks_kthre] - 16 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [kauditd] - 17 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [khungtaskd] - 18 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [oom_reaper] - 19 be/0 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [writeback] - 20 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [kcompactd0] - 21 be/5 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [ksmd] - 22 be/7 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [khugepaged] - 23 be/0 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [crypto] - 24 be/0 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [kintegrityd] - 25 be/0 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [kblockd] - 26 be/0 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [ata_sff] - 27 be/0 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [md] - 28 be/0 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [edac-poller] - 29 be/0 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [devfreq_wq] - 30 be/0 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [watchdogd] - 34 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [kswapd0] - 35 be/0 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [kworker/u3:0] - 36 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [ecryptfs-kthrea] - 78 be/0 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [kthrotld] - 79 be/0 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [acpi_thermal_pm] - 80 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [scsi_eh_0] - 81 be/0 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [scsi_tmf_0] - 82 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [scsi_eh_1] - 83 be/0 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [scsi_tmf_1] - 89 be/0 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [ipv6_addrconf] - 98 be/0 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [kstrp] - 115 be/0 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [charger_manager] - 155 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [scsi_eh_2] - 156 be/0 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [scsi_tmf_2] - 157 be/0 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [kworker/0:1H] - 268 be/0 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [raid5wq] - 321 be/3 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [jbd2/vda1-8] - 322 be/0 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [ext4-rsv-conver] - 391 be/0 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [iscsi_eh] - 392 be/3 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % systemd-journald - 406 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % lvmetad -f - 408 be/0 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [ib-comp-wq] - 410 be/0 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [ib-comp-unb-wq] - 411 be/0 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [ib_mcast] - 415 be/0 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [ib_nl_sa_wq] - 418 be/0 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [rdma_cm] - 530 be/4 systemd- 0.00 B/s 0.00 B/s 0.00 % 0.00 % systemd-timesyncd - 577 be/4 systemd- 0.00 B/s 0.00 B/s 0.00 % 0.00 % systemd-timesyncd [sd-resolve] - 613 be/4 systemd- 0.00 B/s 0.00 B/s 0.00 % 0.00 % systemd-networkd - 633 be/4 systemd- 0.00 B/s 0.00 B/s 0.00 % 0.00 % systemd-resolved - 711 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % systemd-udevd - 797 be/4 syslog 0.00 B/s 0.00 B/s 0.00 % 0.00 % rsyslogd -n - 811 be/4 syslog 0.00 B/s 0.00 B/s 0.00 % 0.00 % rsyslogd -n [in:imuxsock] - 812 be/4 syslog 0.00 B/s 0.00 B/s 0.00 % 0.00 % rsyslogd -n [in:imklog] - 813 be/4 syslog 0.00 B/s 0.00 B/s 0.00 % 0.00 % rsyslogd -n [rs:main Q:Reg] - 799 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % cron -f - 802 be/4 daemon 0.00 B/s 0.00 B/s 0.00 % 0.00 % atd -f - 803 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % python3 /usr/bin/networkd-dispatcher --run-startup-triggers - 889 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % python3 /usr/bin/networkd-dispatcher --run-startup-triggers [gmain] - 805 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % systemd-logind - 807 be/4 messageb 0.00 B/s 0.00 B/s 0.00 % 0.00 % dbus-daemon --system --address=systemd: --nofork --nopidfile --systemd-activation --syslog-only - 817 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % lxcfs /var/lib/lxcfs/ - 9445 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % lxcfs /var/lib/lxcfs/ - 9446 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % lxcfs /var/lib/lxcfs/ -19695 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % lxcfs /var/lib/lxcfs/ -19699 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % lxcfs /var/lib/lxcfs/ -23977 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % lxcfs /var/lib/lxcfs/ -23982 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % lxcfs /var/lib/lxcfs/ -23983 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % lxcfs /var/lib/lxcfs/ -23984 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % lxcfs /var/lib/lxcfs/ -23986 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % lxcfs /var/lib/lxcfs/ -23987 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % lxcfs /var/lib/lxcfs/ - 819 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % accounts-daemon - 833 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % accounts-daemon [gmain] - 835 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % accounts-daemon [gdbus] - 825 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % agetty -o -p -- \u --keep-baud 115200,38400,9600 ttyS0 vt220 - 828 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % agetty -o -p -- \u --noclear tty1 linux - 829 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % python3 /usr/share/unattended-upgrades/unattended-upgrade-shutdown --wait-for-signal - 891 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % python3 /usr/share/unattended-upgrades/unattended-upgrade-shutdown --wait-for-signal [gmain] - 838 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % polkitd --no-debug - 840 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % polkitd --no-debug [gmain] - 844 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % polkitd --no-debug [gdbus] - 839 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % sshd -D -22492 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % systemd --user -22493 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % (sd-pam) -22585 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % tmux -22586 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % -bash -22597 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % ./start9-registry -22598 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % ./start9-registry [ghc_ticker] -22599 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % ./start9-registry [start9-regist:w] -22600 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % ./start9-registry [start9-regist:w] -22601 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % ./start9-registry [start9-regist:w] -22602 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % ./start9-registry [start9-regist:w] -22686 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % ./start9-registry [start9-regist:w] -22953 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % ./start9-registry [start9-regist:w] -23052 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [kworker/0:2] -23761 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [kworker/u2:1] -23861 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [kworker/u2:2] -23946 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [kworker/0:0] -24091 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % sshd: root@pts/0 -24198 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % -bash -24264 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [kworker/u2:0] -24265 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [kworker/u2:3] -24266 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [kworker/u2:4] -24336 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [kworker/0:1] -24407 be/4 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % python3 /usr/sbin/iotop -bn1 -29224 be/0 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [xfsalloc] -29227 be/0 root 0.00 B/s 0.00 B/s 0.00 % 0.00 % [xfs_mru_cache] diff --git a/agent/test/Live/lscpu.sample b/agent/test/Live/lscpu.sample deleted file mode 100644 index dd9ae19f6..000000000 --- a/agent/test/Live/lscpu.sample +++ /dev/null @@ -1,15 +0,0 @@ -Architecture: armv7l -Byte Order: Little Endian -CPU(s): 4 -On-line CPU(s) list: 0-3 -Thread(s) per core: 1 -Core(s) per socket: 4 -Socket(s): 1 -Vendor ID: ARM -Model: 3 -Model name: Cortex-A72 -Stepping: r0p3 -CPU max MHz: 1500.0000 -CPU min MHz: 600.0000 -BogoMIPS: 270.00 -Flags: half thumb fastmult vfp edsp neon vfpv3 tls vfpv4 idiva idivt vfpd32 lpae evtstrm crc32 \ No newline at end of file diff --git a/agent/test/Live/procDev.sample b/agent/test/Live/procDev.sample deleted file mode 100755 index eff9158c8..000000000 --- a/agent/test/Live/procDev.sample +++ /dev/null @@ -1,6 +0,0 @@ -Inter-| Receive | Transmit - face |bytes packets errs drop fifo frame compressed multicast|bytes packets errs drop fifo colls carrier compressed - eth0: 1490932684 1431621 0 0 0 0 0 0 1725610837 1054325 0 0 0 0 0 0 - eth1: 1000000000 1000000 0 0 0 0 0 0 1000000000 1000000 0 0 0 0 0 0 - eth2: fuck askksf oijefoijsf everythign is dicked maodsfijoijther shit bals. - lo: 51480 488 0 0 0 0 0 0 51480 488 0 0 0 0 0 0 diff --git a/agent/test/Live/test-configure-bitcoind b/agent/test/Live/test-configure-bitcoind deleted file mode 100644 index 558dd8e9c..000000000 --- a/agent/test/Live/test-configure-bitcoind +++ /dev/null @@ -1,2 +0,0 @@ -#!/bin/bash -curl -k --header "Content-Type: application/json" --request PATCH --data '{"rpcuser":"bitcoin","rpcpassword":"shitcoin"}' https://localhost:5959/v0/apps/installed/bitcoind/config \ No newline at end of file diff --git a/agent/test/Live/test-install-bitcoind b/agent/test/Live/test-install-bitcoind deleted file mode 100644 index 97b3b2cc8..000000000 --- a/agent/test/Live/test-install-bitcoind +++ /dev/null @@ -1,2 +0,0 @@ -#!/bin/bash -curl -k --header "Content-Type: application/json" --request POST --data '{"id":"bitcoind","version":"0.18.1"}' https://localhost:5959/v0/apps/install \ No newline at end of file diff --git a/agent/test/Live/test-register b/agent/test/Live/test-register deleted file mode 100755 index 1c5251668..000000000 --- a/agent/test/Live/test-register +++ /dev/null @@ -1,3 +0,0 @@ -#!/bin/bash - -curl -k --header "Content-Type: application/json" --request POST --data '{"productKey":"abcdefgh","pubKey":"03df51984d6b8b8b1cc693e239491f77a36c9e9dfe4a486e9972a18e03610a0d22"}' https://localhost:5959/v0/register \ No newline at end of file diff --git a/agent/test/Live/test-self-update b/agent/test/Live/test-self-update deleted file mode 100755 index 715424aec..000000000 --- a/agent/test/Live/test-self-update +++ /dev/null @@ -1,3 +0,0 @@ -#!/bin/bash -curl -k --header "Content-Type: application/json" --request POST --data '{"versionSpecification":">=0.0.0"}' https://localhost:5959/v0/update - diff --git a/agent/test/Live/top.sample b/agent/test/Live/top.sample deleted file mode 100644 index 150f1dcba..000000000 --- a/agent/test/Live/top.sample +++ /dev/null @@ -1,130 +0,0 @@ -top - 20:41:46 up 15:49, 1 user, load average: 3.28, 3.29, 3.01 -Tasks: 123 total, 1 running, 122 sleeping, 0 stopped, 0 zombie -%Cpu(s): 3.0 us, 4.5 sy, 0.0 ni, 50.7 id, 41.8 wa, 0.0 hi, 0.0 si, 0.0 st -MiB Mem : 3906.0 total, 568.4 free, 799.6 used, 2538.1 buff/cache -MiB Swap: 100.0 total, 31.5 free, 68.5 used. 2960.4 avail Mem - - PID USER PR NI VIRT RES SHR S %CPU %MEM TIME+ COMMAND - 983 root 20 0 777140 586900 2264 S 6.2 14.7 363:41.88 bitcoind - 1 root 20 0 33700 5376 4344 S 0.0 0.1 0:03.90 systemd - 2 root 20 0 0 0 0 S 0.0 0.0 0:00.07 kthreadd - 3 root 0 -20 0 0 0 I 0.0 0.0 0:00.00 rcu_gp - 4 root 0 -20 0 0 0 I 0.0 0.0 0:00.00 rcu_par_gp - 8 root 0 -20 0 0 0 I 0.0 0.0 0:00.00 mm_percpu_wq - 9 root 20 0 0 0 0 S 0.0 0.0 0:14.62 ksoftirqd/0 - 10 root 20 0 0 0 0 I 0.0 0.0 0:40.13 rcu_sched - 11 root 20 0 0 0 0 I 0.0 0.0 0:00.00 rcu_bh - 12 root rt 0 0 0 0 S 0.0 0.0 0:00.02 migration/0 - 13 root 20 0 0 0 0 S 0.0 0.0 0:00.00 cpuhp/0 - 14 root 20 0 0 0 0 S 0.0 0.0 0:00.00 cpuhp/1 - 15 root rt 0 0 0 0 S 0.0 0.0 0:00.01 migration/1 - 16 root 20 0 0 0 0 S 0.0 0.0 0:01.66 ksoftirqd/1 - 19 root 20 0 0 0 0 S 0.0 0.0 0:00.00 cpuhp/2 - 20 root rt 0 0 0 0 S 0.0 0.0 0:00.01 migration/2 - 21 root 20 0 0 0 0 S 0.0 0.0 0:03.19 ksoftirqd/2 - 24 root 20 0 0 0 0 S 0.0 0.0 0:00.00 cpuhp/3 - 25 root rt 0 0 0 0 S 0.0 0.0 0:00.01 migration/3 - 26 root 20 0 0 0 0 S 0.0 0.0 0:01.87 ksoftirqd/3 - 29 root 20 0 0 0 0 S 0.0 0.0 0:00.00 kdevtmpfs - 30 root 0 -20 0 0 0 I 0.0 0.0 0:00.00 netns - 34 root 20 0 0 0 0 S 0.0 0.0 0:00.03 khungtaskd - 35 root 20 0 0 0 0 S 0.0 0.0 0:00.00 oom_reaper - 36 root 0 -20 0 0 0 I 0.0 0.0 0:00.00 writeback - 37 root 20 0 0 0 0 S 0.0 0.0 0:01.78 kcompactd0 - 38 root 0 -20 0 0 0 I 0.0 0.0 0:00.00 crypto - 39 root 0 -20 0 0 0 I 0.0 0.0 0:00.00 kblockd - 41 root rt 0 0 0 0 S 0.0 0.0 0:00.00 watchdogd - 42 root 0 -20 0 0 0 I 0.0 0.0 0:00.00 rpciod - 43 root 0 -20 0 0 0 I 0.0 0.0 0:00.00 kworker/u9:0-hci0 - 44 root 0 -20 0 0 0 I 0.0 0.0 0:00.00 xprtiod - 47 root 20 0 0 0 0 S 0.0 0.0 0:50.55 kswapd0 - 48 root 0 -20 0 0 0 I 0.0 0.0 0:00.00 nfsiod - 59 root 0 -20 0 0 0 I 0.0 0.0 0:00.00 kthrotld - 60 root 0 -20 0 0 0 I 0.0 0.0 0:00.00 iscsi_eh - 62 root 0 -20 0 0 0 I 0.0 0.0 0:00.00 dwc_otg - 64 root 0 -20 0 0 0 I 0.0 0.0 0:00.00 DWC Notificatio - 65 root 1 -19 0 0 0 S 0.0 0.0 0:00.00 vchiq-slot/0 - 66 root 1 -19 0 0 0 S 0.0 0.0 0:00.00 vchiq-recy/0 - 67 root 0 -20 0 0 0 S 0.0 0.0 0:00.00 vchiq-sync/0 - 68 root 20 0 0 0 0 S 0.0 0.0 0:00.00 vchiq-keep/0 - 69 root 10 -10 0 0 0 S 0.0 0.0 0:00.00 SMIO - 71 root -51 0 0 0 0 S 0.0 0.0 0:00.00 irq/38-brcmstb_ - 72 root -51 0 0 0 0 S 0.0 0.0 0:00.65 irq/39-mmc1 - 74 root -51 0 0 0 0 S 0.0 0.0 0:00.00 irq/39-mmc0 - 75 root 0 -20 0 0 0 I 0.0 0.0 0:00.00 mmc_complete - 79 root 20 0 0 0 0 D 0.0 0.0 0:22.44 jbd2/mmcblk0p2- - 80 root 0 -20 0 0 0 I 0.0 0.0 0:00.00 ext4-rsv-conver - 84 root 0 -20 0 0 0 I 0.0 0.0 0:00.00 ipv6_addrconf - 123 root 20 0 21216 6296 5424 S 0.0 0.2 0:02.12 systemd-journal - 148 root 20 0 18016 2648 1872 S 0.0 0.1 0:00.66 systemd-udevd - 182 root 10 -10 0 0 0 S 0.0 0.0 0:00.00 SMIO - 199 root 0 -20 0 0 0 I 0.0 0.0 0:00.00 mmal-vchiq - 203 root 0 -20 0 0 0 I 0.0 0.0 0:00.00 mmal-vchiq - 208 root 0 -20 0 0 0 I 0.0 0.0 0:00.00 mmal-vchiq - 217 root -2 0 0 0 0 S 0.0 0.0 0:00.00 v3d_bin - 218 root -2 0 0 0 0 S 0.0 0.0 0:00.00 v3d_render - 220 root -2 0 0 0 0 S 0.0 0.0 0:00.00 v3d_tfu - 221 root -2 0 0 0 0 S 0.0 0.0 0:00.00 v3d_csd - 222 root -2 0 0 0 0 S 0.0 0.0 0:00.00 v3d_cache_clean - 238 root 0 -20 0 0 0 I 0.0 0.0 0:00.00 cfg80211 - 241 root 0 -20 0 0 0 I 0.0 0.0 0:00.00 brcmf_wq/mmc1:0 - 242 root 20 0 0 0 0 S 0.0 0.0 0:00.38 brcmf_wdog/mmc1 - 285 systemd+ 20 0 22380 3164 2676 S 0.0 0.1 0:00.46 systemd-timesyn - 328 nobody 20 0 4320 1516 1344 S 0.0 0.0 0:00.36 thd - 333 root 20 0 7944 1840 1656 S 0.0 0.0 0:00.13 cron - 335 root 39 19 3692 1768 1568 S 0.0 0.0 0:00.04 alsactl - 342 message+ 20 0 6556 2792 2324 S 0.0 0.1 0:00.25 dbus-daemon - 346 root 20 0 13092 4768 4152 S 0.0 0.1 0:00.30 systemd-logind - 349 root 20 0 27656 1068 928 S 0.0 0.0 0:06.77 rngd - 361 root 20 0 10708 2596 2188 S 0.0 0.1 0:00.28 wpa_supplicant - 362 root 20 0 25512 2764 2156 S 0.0 0.1 0:00.37 rsyslogd - 464 root 20 0 11088 3176 2716 S 0.0 0.1 0:00.50 wpa_supplicant - 487 root 0 -20 0 0 0 I 0.0 0.0 0:00.00 kworker/u9:1-hci0 - 488 root 20 0 2140 128 0 S 0.0 0.0 0:00.00 hciattach - 493 root 20 0 9536 1728 1448 S 0.0 0.0 0:00.03 bluetoothd - 548 root 20 0 3028 1600 1252 S 0.0 0.0 0:00.39 dhcpcd - 550 root 20 0 1007336 35764 11120 S 0.0 0.9 3:24.38 dockerd - 555 root 20 0 211952 27340 15432 S 0.0 0.7 40:34.92 agent - 592 root 20 0 4308 948 860 S 0.0 0.0 0:00.01 agetty - 618 root 20 0 10692 3804 3364 S 0.0 0.1 0:00.01 sshd - 619 debian-+ 20 0 34724 22244 5604 S 0.0 0.6 44:17.87 tor - 635 avahi 20 0 5904 2488 2144 S 0.0 0.1 0:03.10 avahi-daemon - 636 avahi 20 0 5772 244 0 S 0.0 0.0 0:00.00 avahi-daemon - 638 root 20 0 968328 9212 4604 S 0.0 0.2 2:38.54 docker-containe - 920 root 20 0 861496 976 556 S 0.0 0.0 0:00.06 docker-proxy - 934 root 20 0 861496 1032 620 S 0.0 0.0 0:00.05 docker-proxy - 948 root 20 0 852276 1032 620 S 0.0 0.0 0:00.04 docker-proxy - 961 root 20 0 852276 860 420 S 0.0 0.0 0:00.04 docker-proxy - 968 root 20 0 889864 2112 1148 S 0.0 0.1 0:07.54 docker-containe - 1332 Debian-+ 20 0 14096 2336 1888 S 0.0 0.1 0:00.04 exim4 - 2987 root 0 -20 0 0 0 I 0.0 0.0 0:51.45 kworker/2:1H-kblockd - 3261 root 0 -20 0 0 0 I 0.0 0.0 0:40.57 kworker/1:0H-kblockd - 3580 root 0 -20 0 0 0 D 0.0 0.0 0:21.37 kworker/3:0H+kblockd - 4084 root 20 0 0 0 0 I 0.0 0.0 0:03.75 kworker/u8:0-events_unbound - 4155 root 0 -20 0 0 0 I 0.0 0.0 0:08.39 kworker/0:2H-mmc_complete - 4176 root 20 0 0 0 0 I 0.0 0.0 0:00.04 kworker/1:0-mm_percpu_wq - 4185 root 20 0 0 0 0 I 0.0 0.0 0:00.14 kworker/3:0-mm_percpu_wq - 4187 root 20 0 0 0 0 D 0.0 0.0 0:00.48 kworker/2:3+events_freezable - 4191 root 20 0 0 0 0 I 0.0 0.0 0:00.13 kworker/1:2-mm_percpu_wq - 4218 root 20 0 12204 6288 5364 S 0.0 0.2 0:00.04 sshd - 4224 pi 20 0 14564 6632 5788 S 0.0 0.2 0:00.14 systemd - 4227 pi 20 0 35240 2964 1636 S 0.0 0.1 0:00.00 (sd-pam) - 4241 pi 20 0 12204 4084 3140 S 0.0 0.1 0:00.44 sshd - 4244 pi 20 0 8492 3624 2704 S 0.0 0.1 0:00.24 bash - 4255 root 20 0 0 0 0 I 0.0 0.0 0:00.31 kworker/u8:1-events_unbound - 4256 root 20 0 0 0 0 I 0.0 0.0 0:00.06 kworker/2:2-events_power_efficient - 4270 root 20 0 0 0 0 I 0.0 0.0 0:00.11 kworker/0:1-events_power_efficient - 4307 root 20 0 0 0 0 I 0.0 0.0 0:00.00 kworker/3:2 - 4326 root 0 -20 0 0 0 I 0.0 0.0 0:00.01 kworker/3:1H-kblockd - 4327 root 0 -20 0 0 0 I 0.0 0.0 0:00.01 kworker/2:2H-kblockd - 4337 root 0 -20 0 0 0 I 0.0 0.0 0:00.01 kworker/1:1H-kblockd - 4338 root 20 0 0 0 0 I 0.0 0.0 0:00.03 kworker/0:2-events - 4343 root 0 -20 0 0 0 I 0.0 0.0 0:00.01 kworker/0:0H-kblockd - 4382 root 20 0 0 0 0 I 0.0 0.0 0:00.02 kworker/2:0-mm_percpu_wq - 4389 root 0 -20 0 0 0 I 0.0 0.0 0:00.00 kworker/2:0H-kblockd - 4390 root 0 -20 0 0 0 I 0.0 0.0 0:00.00 kworker/3:2H - 4396 root 0 -20 0 0 0 I 0.0 0.0 0:00.00 kworker/1:2H-kblockd - 4397 root 20 0 0 0 0 I 0.0 0.0 0:00.02 kworker/0:0-mm_percpu_wq - 4398 root 20 0 0 0 0 I 0.0 0.0 0:00.00 kworker/2:1-mm_percpu_wq - 4399 root 0 -20 0 0 0 I 0.0 0.0 0:00.00 kworker/0:1H-kblockd - 4400 pi 20 0 10184 2828 2448 R 0.0 0.1 0:00.01 top diff --git a/agent/test/Main.hs b/agent/test/Main.hs deleted file mode 100644 index cd7dadb3d..000000000 --- a/agent/test/Main.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Main where - -import Startlude - -import Test.Hspec.Runner -import Test.Hspec.Formatters -import qualified Spec -import qualified Lib.Types.EmverProp as EmverProp - -main :: IO () -main = do - EmverProp.tests - hspecWith defaultConfig { configFormatter = Just progress } Spec.spec diff --git a/agent/test/Spec.hs b/agent/test/Spec.hs deleted file mode 100644 index 5416ef6a8..000000000 --- a/agent/test/Spec.hs +++ /dev/null @@ -1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} diff --git a/agent/weeder.dhall b/agent/weeder.dhall deleted file mode 100644 index c93f586eb..000000000 --- a/agent/weeder.dhall +++ /dev/null @@ -1 +0,0 @@ -{ roots = [ "^main.main$", "^Paths_.*" ], type-class-roots = True }