initial commit

.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

.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'.
+      #
+      # - <integer>: constant value
+      #
+      # - module_name: align under start of module name.
+      #   Useful for 'file' and 'group' align settings.
+      #
+      # Default: 4
+      list_padding: 4
+
+      # Separate lists option affects formatting of import list for type
+      # or class. The only difference is single space between type and list
+      # of constructors, selectors and class functions.
+      #
+      # - true: There is single space between Foldable type and list of it's
+      #   functions.
+      #
+      #   > import Data.Foldable (Foldable (fold, foldl, foldMap))
+      #
+      # - false: There is no space between Foldable type and list of it's
+      #   functions.
+      #
+      #   > import Data.Foldable (Foldable(fold, foldl, foldMap))
+      #
+      # Default: true
+      separate_lists: true
+
+      # Space surround option affects formatting of import lists on a single
+      # line. The only difference is single space after the initial
+      # parenthesis and a single space before the terminal parenthesis.
+      #
+      # - true: There is single space associated with the enclosing
+      #   parenthesis.
+      #
+      #   > import Data.Foo ( foo )
+      #
+      # - false: There is no space associated with the enclosing parenthesis
+      #
+      #   > import Data.Foo (foo)
+      #
+      # Default: false
+      space_surround: false
+
+  # Language pragmas
+  - language_pragmas:
+
+      # We can generate different styles of language pragma lists.
+      #
+      # - vertical: Vertical-spaced language pragmas, one per line.
+      #
+      # - compact: A more compact style.
+      #
+      # - compact_line: Similar to compact, but wrap each line with
+      #   `{-#LANGUAGE #-}'.
+      #
+      # Default: vertical.
+      style: vertical
+
+      # Align affects alignment of closing pragma brackets.
+      #
+      # - true: Brackets are aligned in same column.
+      #
+      # - false: Brackets are not aligned together. There is only one space
+      #   between actual import and closing bracket.
+      #
+      # Default: true
+      align: true
+
+      # stylish-haskell can detect redundancy of some language pragmas. If this
+      # is set to true, it will remove those redundant pragmas. Default: true.
+      remove_redundant: false
+
+  # Replace tabs by spaces. This is disabled by default.
+  - tabs:
+      # Number of spaces to use for each tab. Default: 8, as specified by the
+      # Haskell report.
+      spaces: 4
+
+  # Remove trailing whitespace
+  - trailing_whitespace: {}
+
+  # Squash multiple spaces between the left and right hand sides of some
+  # elements into single spaces. Basically, this undoes the effect of
+  # simple_align but is a bit less conservative.
+  # - squash: {}
+
+# A common setting is the number of columns (parts of) code will be wrapped
+# to. Different steps take this into account. Default: 80.
+columns: 120
+
+# By default, line endings are converted according to the OS. You can override
+# preferred format here.
+#
+# - native: Native newline format. CRLF on Windows, LF on other OSes.
+#
+# - lf: Convert to LF ("\n").
+#
+# - crlf: Convert to CRLF ("\r\n").
+#
+# Default: native.
+newline: native
+
+# Sometimes, language extensions are specified in a cabal file or from the
+# command line instead of using language pragmas in the file. stylish-haskell
+# needs to be aware of these, so it can parse the file correctly.
+#
+# No language extensions are enabled by default.
+language_extensions:
+  - TemplateHaskell
+  - QuasiQuotes
+  - OverloadedStrings
+  - LambdaCase
+  - NoImplicitPrelude

.weeder.yaml

@@ -0,0 +1,2 @@
+- package:
+  - name: s9-agent

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 <function, module or type signature>` 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.

config/routes

@@ -0,0 +1,4 @@
+--authed
+/version                         VersionR           GET
+
+-- /v0/authorizedKeys AuthorizeKeyR  POST

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

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)

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

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"

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

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)

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

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

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

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

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

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

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]

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

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)

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

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

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

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

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
+(.**) = (.) . (.*)

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

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

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

test/Spec.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}