From 22e1170e796eab8459b5b120cfbff1ca118c89b7 Mon Sep 17 00:00:00 2001 From: Aaron Greenspan Date: Sat, 21 Dec 2019 13:13:19 -0700 Subject: [PATCH] initial commit --- .gitignore | 29 ++++ .stylish-haskell.yaml | 247 ++++++++++++++++++++++++++++++++++ .weeder.yaml | 2 + README.md | 54 ++++++++ config/routes | 4 + config/settings.yml | 43 ++++++ package.yaml | 116 ++++++++++++++++ src/Application.hs | 230 +++++++++++++++++++++++++++++++ src/Constants.hs | 18 +++ src/Foundation.hs | 108 +++++++++++++++ src/Handler/Apps.hs | 20 +++ src/Handler/Status.hs | 10 ++ src/Handler/Types/Apps.hs | 81 +++++++++++ src/Handler/Types/Register.hs | 23 ++++ src/Handler/Types/Status.hs | 36 +++++ src/Lib/Error.hs | 57 ++++++++ src/Lib/Ssl.hs | 61 +++++++++ src/Lib/SystemCtl.hs | 21 +++ src/Lib/Types/Api.hs | 28 ++++ src/Lib/Types/ServerApp.hs | 137 +++++++++++++++++++ src/Model.hs | 23 ++++ src/Orphans/Yesod.hs | 12 ++ src/Settings.hs | 76 +++++++++++ src/Startlude.hs | 17 +++ src/Util/Function.hs | 9 ++ stack.yaml | 69 ++++++++++ test/Live/Serialize.hs | 25 ++++ test/Live/UpdateAgent.hs | 24 ++++ test/Spec.hs | 1 + 29 files changed, 1581 insertions(+) create mode 100644 .gitignore create mode 100644 .stylish-haskell.yaml create mode 100644 .weeder.yaml create mode 100644 README.md create mode 100644 config/routes create mode 100644 config/settings.yml create mode 100644 package.yaml create mode 100644 src/Application.hs create mode 100644 src/Constants.hs create mode 100644 src/Foundation.hs create mode 100644 src/Handler/Apps.hs create mode 100644 src/Handler/Status.hs create mode 100644 src/Handler/Types/Apps.hs create mode 100644 src/Handler/Types/Register.hs create mode 100644 src/Handler/Types/Status.hs create mode 100644 src/Lib/Error.hs create mode 100644 src/Lib/Ssl.hs create mode 100644 src/Lib/SystemCtl.hs create mode 100644 src/Lib/Types/Api.hs create mode 100644 src/Lib/Types/ServerApp.hs create mode 100644 src/Model.hs create mode 100644 src/Orphans/Yesod.hs create mode 100644 src/Settings.hs create mode 100644 src/Startlude.hs create mode 100644 src/Util/Function.hs create mode 100644 stack.yaml create mode 100644 test/Live/Serialize.hs create mode 100644 test/Live/UpdateAgent.hs create mode 100644 test/Spec.hs diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..c80ceb3 --- /dev/null +++ b/.gitignore @@ -0,0 +1,29 @@ +dist* +static/tmp/ +static/combined/ +config/client_session_key.aes +*.hi +*.o +*.sqlite3 +*.sqlite3-shm +*.sqlite3-wal +.hsenv* +cabal-dev/ +.stack-work/ +.stack-work-devel/ +yesod-devel/ +.cabal-sandbox +cabal.sandbox.config +.DS_Store +*.swp +*.keter +*~ +.vscode +*.cabal +\#* +start9-companion-server.cabal +stack.yaml.lock +*.env +agent_* +agent.* +version diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml new file mode 100644 index 0000000..8f9c9bf --- /dev/null +++ b/.stylish-haskell.yaml @@ -0,0 +1,247 @@ +# 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: + - TemplateHaskell + - QuasiQuotes + - OverloadedStrings + - LambdaCase + - NoImplicitPrelude diff --git a/.weeder.yaml b/.weeder.yaml new file mode 100644 index 0000000..d759266 --- /dev/null +++ b/.weeder.yaml @@ -0,0 +1,2 @@ +- package: + - name: s9-agent diff --git a/README.md b/README.md new file mode 100644 index 0000000..0d53c41 --- /dev/null +++ b/README.md @@ -0,0 +1,54 @@ +## Database Setup + +After installing Postgres, run: + +``` +createuser start9-companion-server --pwprompt --superuser +# Enter password start9-companion-server when prompted +createdb start9-companion-server +createdb start9-companion-server_test +``` + +## Haskell Setup + +1. If you haven't already, [install Stack](https://haskell-lang.org/get-started) + * On POSIX systems, this is usually `curl -sSL https://get.haskellstack.org/ | sh` +2. Install the `yesod` command line tool: `stack install yesod-bin --install-ghc` +3. Build libraries: `stack build` + +If you have trouble, refer to the [Yesod Quickstart guide](https://www.yesodweb.com/page/quickstart) for additional detail. + +## Development + +Start a development server with: + +``` +stack exec -- yesod devel +``` + +As your code changes, your site will be automatically recompiled and redeployed to localhost. + +## Tests + +``` +stack test --flag start9-companion-server:library-only --flag start9-companion-server:dev +``` + +(Because `yesod devel` passes the `library-only` and `dev` flags, matching those flags means you don't need to recompile between tests and development, and it disables optimization to speed up your test compile times). + +## Documentation + +* Read the [Yesod Book](https://www.yesodweb.com/book) online for free +* Check [Stackage](http://stackage.org/) for documentation on the packages in your LTS Haskell version, or [search it using Hoogle](https://www.stackage.org/lts/hoogle?q=). Tip: Your LTS version is in your `stack.yaml` file. +* For local documentation, use: + * `stack haddock --open` to generate Haddock documentation for your dependencies, and open that documentation in a browser + * `stack hoogle ` to generate a Hoogle database and search for your query +* The [Yesod cookbook](https://github.com/yesodweb/yesod-cookbook) has sample code for various needs + +## Getting Help + +* Ask questions on [Stack Overflow, using the Yesod or Haskell tags](https://stackoverflow.com/questions/tagged/yesod+haskell) +* Ask the [Yesod Google Group](https://groups.google.com/forum/#!forum/yesodweb) +* There are several chatrooms you can ask for help: + * For IRC, try Freenode#yesod and Freenode#haskell + * [Functional Programming Slack](https://fpchat-invite.herokuapp.com/), in the #haskell, #haskell-beginners, or #yesod channels. diff --git a/config/routes b/config/routes new file mode 100644 index 0000000..f231800 --- /dev/null +++ b/config/routes @@ -0,0 +1,4 @@ +--authed +/version VersionR GET + +-- /v0/authorizedKeys AuthorizeKeyR POST diff --git a/config/settings.yml b/config/settings.yml new file mode 100644 index 0000000..d838b8d --- /dev/null +++ b/config/settings.yml @@ -0,0 +1,43 @@ +# 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: "_env:YESOD_PORT:3000" # 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" + +# 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 + +database: + database: "_env:YESOD_SQLITE_DATABASE:start9_agent.sqlite3" + poolsize: "_env:YESOD_SQLITE_POOLSIZE:10" + +ap-password: "_env:AP_PASSWORD:at_first_I_was_afraid" +copyright: Insert copyright statement here + +registry-host: "_env:REGISTRY_HOST:registry.start9labs.com" +registry-port: "_env:REGISTRY_PORT:443" +agent-dir: "_env:AGENT_DIR:/root/agent" +app-mgr-version-spec: "_env:APP_MGR_VERSION_SPEC:=0.0.0" + +#analytics: UA-YOURCODE diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..ec125c5 --- /dev/null +++ b/package.yaml @@ -0,0 +1,116 @@ +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. +library: + source-dirs: src + when: + - then: + cpp-options: -DDEVELOPMENT + ghc-options: + - -Wall + - -fwarn-tabs + - -O0 + - -fdefer-typed-holes + else: + ghc-options: + - -Wall + - -fwarn-tabs + - -O2 + - -fdefer-typed-holes + condition: (flag(dev)) || (flag(library-only)) +tests: + start9-registry-test: + source-dirs: test + main: Spec.hs + ghc-options: + - -Wall + - -fdefer-typed-holes + dependencies: + - start9-registry + - hspec >=2.0.0 + - yesod-test + +dependencies: +- base >=4.9.1.0 && <5 +- aeson >=1.4 && <1.5 +- bytestring +- casing +- comonad +- conduit +- conduit-extra +- cryptonite +- data-default +- directory +- dns +- either +- errors +- fast-logger >=2.2 && <2.5 +- file-embed +- filepath +- http-client +- http-conduit +- http-types +- interpolate +- iso8601-time +- jose-jwt +- lens +- lens-aeson +- memory +- monad-logger >=0.3 && <0.4 +- monad-loops +- persistent +- persistent-sqlite +- persistent-template +- process +- protolude +- safe +- secp256k1-haskell +- template-haskell +- text >=0.11 && <2.0 +- time +- transformers +- unix +- unordered-containers +- vault +- vector +- wai +- wai-cors +- wai-extra >=3.0 && <3.1 +- wai-logger >=2.2 && <2.4 +- warp >=3.0 && <3.3 +- warp-tls +- yaml >=0.11 && <0.12 +- yesod >=1.6 && <1.7 +- yesod-core >=1.6 && <1.7 +- yesod-persistent >= 1.6 && < 1.7 + +default-extensions: +- NoImplicitPrelude +- GeneralizedNewtypeDeriving +- LambdaCase +- MultiWayIf +- NamedFieldPuns +- NumericUnderscores +- OverloadedStrings +name: start9-registry +version: 0.0.0 +executables: + start9-registry: + source-dirs: src + main: Main.hs + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + - -fdefer-typed-holes + dependencies: + - start9-registry + when: + - buildable: false + condition: flag(library-only) diff --git a/src/Application.hs b/src/Application.hs new file mode 100644 index 0000000..0b58091 --- /dev/null +++ b/src/Application.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Application + ( appMain + , makeFoundation + , makeLogWare + , shutdownApp + , shutdownAll + , shutdownWeb + , startApp + , startWeb + -- * for DevelMain + , getApplicationRepl + , getAppSettings + -- * for GHCI + , handler + , db + ) where + +import Startlude + +import Control.Monad.Logger (liftLoc, runLoggingT) +import Data.Default +import Data.IORef +import Database.Persist.Sql +import Database.Persist.Sqlite (createSqlitePool, runSqlPool, sqlDatabase, sqlPoolSize) +import Language.Haskell.TH.Syntax (qLocation) +import Network.Wai +import Network.Wai.Handler.Warp (Settings, defaultSettings, defaultShouldDisplayException, + getPort, setHost, setOnException, setPort) +import Network.Wai.Handler.WarpTLS +import Network.Wai.Middleware.Cors (CorsResourcePolicy (..), cors, simpleCorsResourcePolicy) +import Network.Wai.Middleware.RequestLogger (Destination (Logger), IPAddrSource (..), OutputFormat (..), + destination, mkRequestLogger, outputFormat) +import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, toLogStr) +import Yesod.Core +import Yesod.Core.Types hiding (Logger) +import Yesod.Default.Config2 +import Yesod.Persist.Core + +-- Import all relevant handler modules here. +-- Don't forget to add new modules to your cabal file! +import Foundation +import Handler.Status +import Lib.Ssl +import Model +import Settings +import System.Posix.Process + + +-- 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 + +-- | 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 + -- Some basic initializations: HTTP connection manager, logger, and static + -- subsite. + appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger + + appWebServerThreadId <- newIORef Nothing + + -- 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 = 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" + logFunc = messageLoggerSource tempFoundation appLogger + + -- Create the database connection pool + pool <- flip runLoggingT logFunc $ createSqlitePool + (sqlDatabase $ appDatabaseConf appSettings) + (sqlPoolSize $ appDatabaseConf appSettings) + -- Perform database migration using our application's logging settings. + runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc + + -- TODO :: compute and seed the Tor address into the db, possibly grabbing it from settings + -- seedTorAddress appSettings + + -- Return the foundation + return $ mkFoundation pool + +-- | 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 + let authWare = makeAuthWare foundation + -- Create the WAI application and apply middlewares + appPlain <- toWaiAppPlain foundation + pure . logWare . cors (const . Just $ policy) . authWare . defaultMiddlewaresNoLogging $ appPlain + where + policy = simpleCorsResourcePolicy { corsMethods = ["GET", "HEAD", "OPTIONS", "POST", "PATCH", "PUT", "DELETE"], corsRequestHeaders = ["app-version", "Content-Type", "Authorization"] } + +-- TODO: create a middle ware which will attempt to verify an ecdsa signed transaction against one of the public keys +-- in the validDevices table. +-- makeCheckSigWare :: AgentCtx -> IO Middleware +-- makeCheckSigWare = _ + +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 + } + +-- TODO : what kind of auth is needed here +makeAuthWare :: AgentCtx -> Middleware +makeAuthWare _ app req res = next + where + next :: IO ResponseReceived + next = app req res + +-- | 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 + +getAppSettings :: IO AppSettings +getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv + +-- | The @main@ function for an executable running this site. +appMain :: IO () +appMain = do + -- Get the settings from all relevant sources + settings <- loadYamlSettingsArgs + -- fall back to compile-time values, set to [] to require values at runtime + [configSettingsYmlValue] + + -- allow environment variables to override + useEnv + + -- Generate the foundation from the settings + makeFoundation settings >>= startApp + +startApp :: AgentCtx -> IO () +startApp foundation = do + -- set up ssl certificates + putStrLn @Text "Setting up SSL" + setupSsl + putStrLn @Text "SSL Setup Complete" + + startWeb foundation + +startWeb :: AgentCtx -> IO () +startWeb foundation = do + app <- makeApplication foundation + + putStrLn @Text $ "Launching Web Server on port " <> show (appPort $ appSettings foundation) + action <- async $ runTLS + (tlsSettings sslCertLocation sslKeyLocation) + (warpSettings foundation) + app + + setWebProcessThreadId (asyncThreadId action) foundation + wait action + +shutdownAll :: [ThreadId] -> IO () +shutdownAll threadIds = do + for_ threadIds killThread + exitImmediately ExitSuccess + +-- Careful, you should always spawn this within forkIO so as to avoid accidentally killing the running process +shutdownWeb :: AgentCtx -> IO () +shutdownWeb AgentCtx{..} = do + mThreadId <- readIORef appWebServerThreadId + for_ mThreadId $ \tid -> do + killThread tid + writeIORef appWebServerThreadId Nothing + +-------------------------------------------------------------- +-- 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) + +shutdownApp :: AgentCtx -> IO () +shutdownApp _ = return () + +--------------------------------------------- +-- 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 +db :: ReaderT SqlBackend Handler a -> IO a +db = handler . runDB diff --git a/src/Constants.hs b/src/Constants.hs new file mode 100644 index 0000000..8d5ae4f --- /dev/null +++ b/src/Constants.hs @@ -0,0 +1,18 @@ +module Constants where + +import Data.Aeson +import Data.Aeson.Types +import Data.Maybe +import Data.Version (showVersion) +import Lib.Types.ServerApp +import Paths_start9_registry (version) +import Startlude + +configBasePath :: FilePath +configBasePath = "/root/registry" + +registryVersion :: AppVersion +registryVersion = fromJust . parseMaybe parseJSON . String . toS . showVersion $ version + +getRegistryHostname :: IsString a => a +getRegistryHostname = "registry" diff --git a/src/Foundation.hs b/src/Foundation.hs new file mode 100644 index 0000000..6d93b9d --- /dev/null +++ b/src/Foundation.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +module Foundation where + +import Startlude + +import Control.Monad.Logger (LogSource) +import Data.IORef +import Database.Persist.Sql +import Yesod.Core +import Yesod.Core.Types (Logger) +import qualified Yesod.Core.Unsafe as Unsafe +import Yesod.Persist.Core + +import Settings + +-- | The foundation datatype for your application. This can be a good place to +-- keep settings and values requiring initialization before your application +-- starts running, such as database connections. Every handler will have +-- access to the data present here. + +data AgentCtx = AgentCtx + { appSettings :: AppSettings + , appConnPool :: ConnectionPool -- ^ Database connection pool. + , appLogger :: Logger + , appWebServerThreadId :: IORef (Maybe 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") + +-- 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 + +-- Store session data on the client in encrypted cookies, +-- default session idle timeout is 120 minutes + makeSessionBackend :: AgentCtx -> IO (Maybe SessionBackend) + makeSessionBackend _ = Just <$> defaultClientSessionBackend + 120 -- timeout in minutes + "config/client_session_key.aes" + +-- 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 + +-- 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 + +-- 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 + +-- Note: Some functionality previously present in the scaffolding has been +-- moved to documentation in the Wiki. Following are some hopefully helpful +-- links: +-- +-- https://github.com/yesodweb/yesod/wiki/Sending-email +-- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain +-- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding + +appLogFunc :: AgentCtx -> LogFunc +appLogFunc = appLogger >>= flip messageLoggerSource diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs new file mode 100644 index 0000000..460a7fe --- /dev/null +++ b/src/Handler/Apps.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +module Handler.Apps where + +import Startlude + +import Control.Monad.Logger +import Data.Aeson +import qualified Data.ByteString.Lazy as BS + +import Foundation + + +pureLog :: Show a => a -> Handler a +pureLog = liftA2 (*>) ($logInfo . show) pure + +logRet :: ToJSON a => Handler a -> Handler a +logRet = (>>= liftA2 (*>) ($logInfo . decodeUtf8 . BS.toStrict . encode) pure) diff --git a/src/Handler/Status.hs b/src/Handler/Status.hs new file mode 100644 index 0000000..7fb5066 --- /dev/null +++ b/src/Handler/Status.hs @@ -0,0 +1,10 @@ +module Handler.Status where + +import Startlude + +import Constants +import Foundation +import Handler.Types.Status + +getVersionR :: Handler AppVersionRes +getVersionR = pure . AppVersionRes $ registryVersion diff --git a/src/Handler/Types/Apps.hs b/src/Handler/Types/Apps.hs new file mode 100644 index 0000000..ac16fc2 --- /dev/null +++ b/src/Handler/Types/Apps.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE RecordWildCards #-} +module Handler.Types.Apps where + +import Startlude + +import Data.Aeson +import Data.Time.ISO8601 +import Yesod.Core.Content + +import Lib.Types.ServerApp + +newtype AvailableAppsRes = AvailableAppsRes + { availableApps :: [(StoreApp, Maybe AppVersion)] + } deriving (Eq, Show) +instance ToJSON AvailableAppsRes where + toJSON = toJSON . fmap toJSON' . availableApps + where + toJSON' (StoreApp{..}, version) = object + [ "id" .= storeAppId + , "title" .= storeAppTitle + , "versionInstalled" .= version + , "versionLatest" .= (storeAppVersionInfoVersion . extract) storeAppVersions + , "iconURL" .= storeAppIconUrl + , "descriptionShort" .= storeAppDescriptionShort + ] +instance ToTypedContent AvailableAppsRes where + toTypedContent = toTypedContent . toJSON +instance ToContent AvailableAppsRes where + toContent = toContent . toJSON + +newtype AvailableAppFullRes = AvailableAppFullRes + { availableAppFull :: (StoreApp, Maybe AppVersion) + } deriving (Eq, Show) +instance ToJSON AvailableAppFullRes where + toJSON = toJSON' . availableAppFull + where + toJSON' (StoreApp{..}, version) = object + [ "id" .= storeAppId + , "title" .= storeAppTitle + , "versionInstalled" .= version + , "versionLatest" .= (storeAppVersionInfoVersion . extract) storeAppVersions + , "iconURL" .= storeAppIconUrl + , "descriptionShort" .= storeAppDescriptionShort + , "descriptionLong" .= storeAppDescriptionLong + , "versions" .= storeAppVersions + ] +instance ToContent AvailableAppFullRes where + toContent = toContent . toJSON +instance ToTypedContent AvailableAppFullRes where + toTypedContent = toTypedContent . toJSON + +newtype InstalledAppRes = InstalledAppRes + { installedApp :: (StoreApp, ServerApp, AppStatus, UTCTime) + } deriving (Eq, Show) +instance ToJSON InstalledAppRes where + toJSON = toJSON' . installedApp + where + toJSON' (store, server, status, time) = object + [ "id" .= storeAppId store + , "title" .= storeAppTitle store + , "versionLatest" .= (storeAppVersionInfoVersion . extract) (storeAppVersions store) + , "versionInstalled" .= serverAppVersionInstalled server + , "iconURL" .= storeAppIconUrl store + , "torAddress" .= serverAppTorService server + , "status" .= status + , "statusAt" .= formatISO8601Javascript time + ] +instance ToTypedContent InstalledAppRes where + toTypedContent = toTypedContent . toJSON +instance ToContent InstalledAppRes where + toContent = toContent . toJSON + +data InstallNewAppReq = InstallNewAppReq + { installNewAppId :: Text + , installNewAppVersion :: Text + } deriving (Eq, Show) +instance FromJSON InstallNewAppReq where + parseJSON = withObject "Install New App Request" $ \o -> do + installNewAppId <- o .: "id" + installNewAppVersion <- o .: "version" + pure InstallNewAppReq{..} diff --git a/src/Handler/Types/Register.hs b/src/Handler/Types/Register.hs new file mode 100644 index 0000000..093a814 --- /dev/null +++ b/src/Handler/Types/Register.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} +module Handler.Types.Register where + +import Startlude + +import Control.Monad.Fail +import Data.Aeson +import Data.ByteArray.Encoding +import Data.ByteArray.Sized + +data RegisterReq = RegisterReq + { registerProductKey :: Text + , registerPubKey :: SizedByteArray 33 ByteString + } deriving (Eq, Show) +instance FromJSON RegisterReq where + parseJSON = withObject "Register Request" $ \o -> do + registerProductKey <- o .: "productKey" + registerPubKey <- o .: "pubKey" >>= \t -> + case sizedByteArray <=< hush . convertFromBase Base16 $ encodeUtf8 t of + Nothing -> fail "Invalid Hex Encoded Public Key" + Just x -> pure x + pure RegisterReq{..} diff --git a/src/Handler/Types/Status.hs b/src/Handler/Types/Status.hs new file mode 100644 index 0000000..dbc060f --- /dev/null +++ b/src/Handler/Types/Status.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE RecordWildCards #-} +module Handler.Types.Status where + +import Startlude + +import Data.Aeson +import Data.Text +import Yesod.Core.Content + +import Lib.Types.ServerApp + +data ServerRes = ServerRes + { serverStatus :: AppStatus + , serverVersion :: AppVersion + , serverSpecs :: Value + } deriving (Eq, Show) +instance ToJSON ServerRes where + toJSON ServerRes{..} = object + [ "status" .= toUpper (show serverStatus) + , "versionInstalled" .= serverVersion + , "specs" .= serverSpecs + , "versionLatest" .= serverVersion -- TODO: change this. + ] +instance ToTypedContent ServerRes where + toTypedContent = toTypedContent . toJSON +instance ToContent ServerRes where + toContent = toContent . toJSON + +newtype AppVersionRes = AppVersionRes + { unAppVersionRes :: AppVersion } deriving (Eq, Show) +instance ToJSON AppVersionRes where + toJSON AppVersionRes{unAppVersionRes} = object ["version" .= unAppVersionRes] +instance ToContent AppVersionRes where + toContent = toContent . toJSON +instance ToTypedContent AppVersionRes where + toTypedContent = toTypedContent . toJSON diff --git a/src/Lib/Error.hs b/src/Lib/Error.hs new file mode 100644 index 0000000..152d14c --- /dev/null +++ b/src/Lib/Error.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE RecordWildCards #-} +module Lib.Error where + +import Startlude + +import Network.HTTP.Types +import Yesod.Core + +type S9ErrT m = ExceptT S9Error m + +data S9Error = PersistentE Text deriving (Show, Eq) + +instance Exception S9Error + +-- | Redact any sensitive data in this function +toError :: S9Error -> Error +toError = \case + PersistentE t -> Error DATABASE_ERROR t + +data ErrorCode = + DATABASE_ERROR + deriving (Eq, Show) +instance ToJSON ErrorCode where + toJSON = String . show + +data Error = Error + { errorCode :: ErrorCode + , errorMessage :: Text + } deriving (Eq, Show) +instance ToJSON Error where + toJSON Error{..} = object + [ "code" .= errorCode + , "message" .= errorMessage + ] +instance ToContent Error where + toContent = toContent . toJSON +instance ToTypedContent Error 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 + PersistentE _ -> status500 + +respondStatusException :: MonadHandler m => S9ErrT m a -> m a +respondStatusException action = runExceptT action >>= \case + Left e -> toStatus >>= sendResponseStatus $ e + Right a -> pure a + +handleS9ErrNuclear :: MonadIO m => S9ErrT m a -> m a +handleS9ErrNuclear action = runExceptT action >>= \case + Left e -> throwIO e + Right a -> pure a diff --git a/src/Lib/Ssl.hs b/src/Lib/Ssl.hs new file mode 100644 index 0000000..cc5c516 --- /dev/null +++ b/src/Lib/Ssl.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE QuasiQuotes #-} +module Lib.Ssl where + +import Startlude + +import Data.String.Interpolate.IsString +import System.Directory +import System.FilePath +import System.Process + +import Constants + +-- openssl genrsa -out key.pem 2048 +-- openssl req -new -key key.pem -out certificate.csr +-- openssl x509 -req -in certificate.csr -signkey key.pem -out certificate.pem + +sslBaseLocation :: FilePath +sslBaseLocation = configBasePath "ssl" + +sslKeyLocation :: FilePath +sslKeyLocation = sslBaseLocation "key.pem" + +sslCsrLocation :: FilePath +sslCsrLocation = sslBaseLocation "certificate.csr" + +sslCertLocation :: FilePath +sslCertLocation = sslBaseLocation "certificate.pem" + +checkForSslCert :: IO Bool +checkForSslCert = + doesPathExist sslKeyLocation <&&> doesPathExist sslCertLocation + +generateSslKey :: IO ExitCode +generateSslKey = rawSystem "openssl" ["genrsa", "-out", sslKeyLocation, "2048"] + +generateSslCert :: Text -> IO ExitCode +generateSslCert name = rawSystem + "openssl" + ["req", "-new", "-key", sslKeyLocation, "-out", sslCsrLocation, "-subj", [i|/CN=#{name}.local|]] + +selfSignSslCert :: IO ExitCode +selfSignSslCert = rawSystem + "openssl" + [ "x509" + , "-req" + , "-in" + , sslCsrLocation + , "-signkey" + , sslKeyLocation + , "-out" + , sslCertLocation + ] + +setupSsl :: IO () +setupSsl = do + exists <- checkForSslCert + unless exists $ do + void $ system $ "mkdir -p " <> sslBaseLocation + void generateSslKey + void $ generateSslCert getRegistryHostname + void selfSignSslCert diff --git a/src/Lib/SystemCtl.hs b/src/Lib/SystemCtl.hs new file mode 100644 index 0000000..f79e02e --- /dev/null +++ b/src/Lib/SystemCtl.hs @@ -0,0 +1,21 @@ +module Lib.SystemCtl where + +import Startlude hiding (words) +import Unsafe + +import Data.Char +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] diff --git a/src/Lib/Types/Api.hs b/src/Lib/Types/Api.hs new file mode 100644 index 0000000..18cad2e --- /dev/null +++ b/src/Lib/Types/Api.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} +module Lib.Types.Api where + +import Startlude + +import Data.Aeson + +import Orphans.Yesod () + +-- data PostWifiRes; TODO: do we need the PostWifiRes or equivalent?? +data AddWifiReq = AddWifiReq + { addWifiSsid :: Text + , addWifiPass :: Text + } deriving (Eq, Show) +instance FromJSON AddWifiReq where + parseJSON = withObject "add wifi req" $ \o -> do + addWifiSsid <- o .: "ssid" + addWifiPass <- o .: "password" + pure AddWifiReq{..} + +newtype EnableWifiReq = EnableWifiReq + { enableWifiSsid :: Text + } deriving (Eq, Show) +instance FromJSON EnableWifiReq where + parseJSON = withObject "enable wifi req" $ \o -> do + enableWifiSsid <- o .: "ssid" + pure $ EnableWifiReq {..} diff --git a/src/Lib/Types/ServerApp.hs b/src/Lib/Types/ServerApp.hs new file mode 100644 index 0000000..461b774 --- /dev/null +++ b/src/Lib/Types/ServerApp.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +module Lib.Types.ServerApp where + +import Startlude hiding (break) + +import qualified GHC.Show (Show (..)) + +import Control.Monad.Fail +import Data.Aeson +import Data.Char (isDigit) +import Data.String.Interpolate +import Data.Text +import Yesod.Core + +data StoreApp = StoreApp + { storeAppId :: Text + , storeAppTitle :: Text + , storeAppDescriptionShort :: Text + , storeAppDescriptionLong :: Text + , storeAppIconUrl :: Text + , storeAppVersions :: NonEmpty StoreAppVersionInfo + } deriving (Eq, Show) + +data StoreAppVersionInfo = StoreAppVersionInfo + { storeAppVersionInfoVersion :: AppVersion + , storeAppVersionInfoReleaseNotes :: Text + } deriving (Eq, Ord, Show) +instance FromJSON StoreAppVersionInfo where + parseJSON = withObject "Store App Version Info" $ \o -> do + storeAppVersionInfoVersion <- o .: "version" + storeAppVersionInfoReleaseNotes <- o .: "release-notes" + pure StoreAppVersionInfo{..} +instance ToJSON StoreAppVersionInfo where + toJSON StoreAppVersionInfo{..} = object + [ "version" .= storeAppVersionInfoVersion + , "releaseNotes" .= storeAppVersionInfoReleaseNotes + ] + +data ServerApp = ServerApp + { serverAppId :: Text + , serverAppVersionInstalled :: AppVersion + , serverAppTorService :: Text + , serverAppIsConfigured :: Bool + } deriving (Eq, Show) + +data SemverRequestModifier = SVEquals | SVLessThan | SVGreaterThan | SVMinMinor | SVMinPatch | SVLessThanEq | SVGreaterThanEq deriving (Eq, Bounded, Enum) +instance Show SemverRequestModifier where + show SVEquals = "=" + show SVLessThan = "<" + show SVGreaterThan = ">" + show SVMinMinor = "~" + show SVMinPatch = "^" + show SVLessThanEq = "<=" + show SVGreaterThanEq = ">=" + +instance FromJSON SemverRequestModifier where + parseJSON = withText "semver request modifier" $ \case + "" -> pure SVMinPatch + "=" -> pure SVEquals + "<" -> pure SVLessThan + ">" -> pure SVGreaterThan + "~" -> pure SVMinMinor + "^" -> pure SVMinPatch + "<=" -> pure SVLessThanEq + ">=" -> pure SVGreaterThanEq + _ -> fail "invalid semver request modifier" + +data AppVersionSpecification = AppVersionSpecification + { requestModifier :: SemverRequestModifier + , baseVersion :: AppVersion + } + +instance Show AppVersionSpecification where + show (AppVersionSpecification r b) = show r <> show b +instance ToJSON AppVersionSpecification where + toJSON = String . show +instance FromJSON AppVersionSpecification where + parseJSON = withText "app version spec" $ \t -> do + let (svMod, version) = break isDigit t + baseVersion <- parseJSON . String $ version + requestModifier <- parseJSON . String $ svMod + pure $ AppVersionSpecification {..} + +(<||) :: AppVersion -> AppVersionSpecification -> Bool +(<||) av (AppVersionSpecification SVEquals av1) = av == av1 +(<||) av (AppVersionSpecification SVLessThan av1) = av < av1 +(<||) av (AppVersionSpecification SVGreaterThan av1) = av > av1 +(<||) av (AppVersionSpecification SVLessThanEq av1) = av <= av1 +(<||) av (AppVersionSpecification SVGreaterThanEq av1) = av >= av1 +(<||) (AppVersion (a,b,_)) (AppVersionSpecification SVMinMinor (AppVersion (a1, b1, _))) + = a == a1 && b >= b1 +(<||) (AppVersion (a,b,c)) (AppVersionSpecification SVMinPatch (AppVersion (a1, b1, c1))) + = a == a1 && b == b1 && c >= c1 + + +newtype AppVersion = AppVersion + { unAppVersion :: (Word16, Word16, Word16) } deriving (Eq, Ord) +instance Show AppVersion where + show (AppVersion (a, b, c)) = [i|#{a}.#{b}.#{c}|] +instance IsString AppVersion where + fromString s = case traverse (readMaybe . toS) $ split (=='.') (toS s) of + Just [major, minor, patch] -> AppVersion (major, minor, patch) + _ -> panic . toS $ "Invalid App Version: " <> s +instance ToJSON AppVersion where + toJSON av = String . toS $ let (a,b,c) = unAppVersion av in [i|#{a}.#{b}.#{c}|] +instance FromJSON AppVersion where + parseJSON = withText "app version" $ \t -> + case splitOn "." t of + [a, b, c] -> + case traverse (decode . toS) [a, b, c] of + Just [a', b', c'] -> pure $ AppVersion (a', b', c') + _ -> fail "non word16 versioning" + _ -> fail "unknown versioning" +instance ToTypedContent AppVersion where + toTypedContent = toTypedContent . toJSON +instance ToContent AppVersion where + toContent = toContent . toJSON + +(\\) :: AppVersion -> AppVersion -> (Word16, Word16, Word16) +(\\) (AppVersion (a, b, c)) (AppVersion (a1, b1, c1)) = (a `diffy` a1, b `diffy` b1, c `diffy` c1) + where + d `diffy` d1 = fromIntegral . abs $ (fromIntegral d :: Integer) - (fromIntegral d1 :: Integer) + +data AppStatus = Running | Stopped | Restarting | Removing | Dead deriving (Eq, Show) +instance ToJSON AppStatus where + toJSON = String . toUpper . show +instance FromJSON AppStatus where + parseJSON = withText "health status" $ \case + "RUNNING" -> pure Running + "STOPPED" -> pure Stopped + "RESTARTING" -> pure Restarting + "REMOVING" -> pure Removing + "DEAD" -> pure Dead + _ -> fail "unknown status" + +data AppAction = Start | Stop deriving (Eq, Show) diff --git a/src/Model.hs b/src/Model.hs new file mode 100644 index 0000000..c624306 --- /dev/null +++ b/src/Model.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +module Model where + +import Database.Persist.TH + +share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| +-- AuthorizedKey +-- createdAt UTCTime +-- updatedAt UTCTime +-- name Text +-- pubKey CompressedKey +-- root Bool +-- UniquePubKey pubKey +-- deriving Eq +-- deriving Show +|] diff --git a/src/Orphans/Yesod.hs b/src/Orphans/Yesod.hs new file mode 100644 index 0000000..778c7b2 --- /dev/null +++ b/src/Orphans/Yesod.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Orphans.Yesod where + +import Startlude + +import Yesod.Core + +-- | Forgive me for I have sinned +instance ToJSON a => ToContent [a] where + toContent = toContent . toJSON . fmap toJSON +instance ToJSON a => ToTypedContent [a] where + toTypedContent = toTypedContent . toJSON . fmap toJSON diff --git a/src/Settings.hs b/src/Settings.hs new file mode 100644 index 0000000..755248c --- /dev/null +++ b/src/Settings.hs @@ -0,0 +1,76 @@ +{-# 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 Crypto.Hash +import Startlude hiding (hash) + +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) + +-- | 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? + } + +instance FromJSON AppSettings where + parseJSON = withObject "AppSettings" $ \o -> do + appDatabaseConf <- o .: "database" + appHost <- fromString <$> o .: "host" + appPort <- o .: "port" + appIpFromHeader <- o .: "ip-from-header" + + appDetailedRequestLogging <- o .:? "detailed-logging" .!= True + appShouldLogAll <- o .:? "should-log-all" .!= False + + return AppSettings { .. } + +apNameFromPass :: Text -> Text +apNameFromPass password = prefix <> toS (take 4 hashStr) + where + bs = encodeUtf8 password + hashed = hash bs :: Digest SHA256 + hashStr = show hashed :: String + prefix = "start9-" + +-- | 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 diff --git a/src/Startlude.hs b/src/Startlude.hs new file mode 100644 index 0000000..9ef788c --- /dev/null +++ b/src/Startlude.hs @@ -0,0 +1,17 @@ +module Startlude + ( module X + , module Startlude + ) +where + +import Control.Arrow as X ((&&&)) +import Control.Comonad as X +import Control.Error.Util as X +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) + +id :: a -> a +id = identity diff --git a/src/Util/Function.hs b/src/Util/Function.hs new file mode 100644 index 0000000..0974318 --- /dev/null +++ b/src/Util/Function.hs @@ -0,0 +1,9 @@ +module Util.Function where + +import Startlude + +(.*) :: (b -> c) -> (a0 -> a1 -> b) -> a0 -> a1 -> c +(.*) = (.) . (.) + +(.**) :: (b -> c) -> (a0 -> a1 -> a2 -> b) -> a0 -> a1 -> a2 -> c +(.**) = (.) . (.*) \ No newline at end of file diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..a3e9de4 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,69 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# resolver: ./custom-snapshot.yaml +# resolver: https://example.com/snapshots/2018-01-01.yaml +resolver: lts-13.11 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# subdirs: +# - auto-update +# - wai +packages: +- . +# Dependency packages to be pulled from upstream that are not in the resolver. +# These entries can reference officially published versions as well as +# forks / in-progress versions pinned to a git hash. For example: +# +# extra-deps: +# - acme-missiles-0.3 +# - git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# +extra-deps: + - protolude-0.2.4 + - git: https://github.com/CaptJakk/jose-jwt.git + commit: 63210e8d05543dac932ddfe5c212450beb88374c + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=2.1" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/test/Live/Serialize.hs b/test/Live/Serialize.hs new file mode 100644 index 0000000..9f916f1 --- /dev/null +++ b/test/Live/Serialize.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Live.Serialize where + +import Data.String.Interpolate.IsString + +import Application +import Lib.External.Registry +import Startlude + +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 RegistryRes) +appRegistryTest = flip parseBsManifest someYaml <$> getAppSettings diff --git a/test/Live/UpdateAgent.hs b/test/Live/UpdateAgent.hs new file mode 100644 index 0000000..89457fc --- /dev/null +++ b/test/Live/UpdateAgent.hs @@ -0,0 +1,24 @@ +module Live.UpdateAgent where + +import Application +import Lib.Types.ServerApp +import Lib.UpdateAgent +import Startlude + +av :: AppVersion +av = AppVersion (0,0,0) + +avs :: AppVersionSpecification +avs = AppVersionSpecification SVEquals av + +-- Need a few things to run this... +-- 1) a running "registry" server, pointed to by the settings.yml this file is run against. +-- 2) that server needs to serve up an executable file at /agent.0.0.0 (the version of av above) +-- 3) the executable file must itself spin up a server on the same port as this application, defined again in settings.yml +-- 4) that server must also respond to /version with a semver version in the format "0.0.0" +-- 5) If all goes well, the stack ghci session which calls updateAgentLive should have been killed, and the executable should still be running + +updateAgentLive :: IO () +updateAgentLive = do + (_, agentCtx, _) <- getApplicationRepl + updateAgent' avs agentCtx diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..a824f8c --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}