initial commit

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