0.2.5 initial commit

Makefile incomplete

agent/src/Application.hs

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

agent/src/Auth.hs

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

agent/src/Constants.hs

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

agent/src/Daemon/AppNotifications.hs

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

agent/src/Daemon/RefreshProcDev.hs

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

agent/src/Daemon/ZeroConf.hs

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

agent/src/Foundation.hs

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

agent/src/Handler/Apps.hs

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

agent/src/Handler/Authenticate.hs

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

agent/src/Handler/Backups.hs

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

agent/src/Handler/Hosts.hs

@@ -0,0 +1,85 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+module Handler.Hosts where
+
+import           Startlude               hiding ( ask )
+
+import           Control.Carrier.Lift           ( runM )
+import           Control.Carrier.Error.Church
+import           Data.Conduit
+import qualified Data.Conduit.Binary           as CB
+import           Data.Time.ISO8601
+import           Yesod.Core              hiding ( expiresAt )
+
+import           Foundation
+import           Daemon.ZeroConf
+import           Handler.Register               ( produceProofOfKey
+                                                , checkExistingPasswordRegistration
+                                                )
+import           Handler.Types.Hosts
+import           Handler.Types.Register
+import           Lib.Crypto
+import           Lib.Error
+import           Lib.Password                   ( rootAccountName )
+import           Lib.ProductKey
+import           Lib.Ssl
+import           Lib.SystemPaths
+import           Lib.Tor
+import           Settings
+
+getHostsR :: Handler HostsRes
+getHostsR = handleS9ErrT $ do
+    settings   <- getsYesod appSettings
+    productKey <- liftIO . getProductKey . appFilesystemBase $ settings
+    hostParams <- extractHostsQueryParams
+
+    verifyHmac productKey hostParams
+    verifyTimestampNotExpired $ hostsParamsExpiration hostParams
+
+    mClaimedAt <- checkExistingPasswordRegistration rootAccountName
+    case mClaimedAt of
+        Nothing        -> pure $ NullReply
+        Just claimedAt -> do
+            fmap HostsRes . mapExceptT (liftIO . runM . injectFilesystemBaseFromContext settings) $ getRegistration
+                productKey
+                claimedAt
+
+verifyHmac :: MonadIO m => Text -> HostsParams -> S9ErrT m ()
+verifyHmac productKey params = do
+    let computedHmacDigest = computeHmac productKey hostsParamsExpiration hostsParamsSalt
+    unless (hostsParamsHmac == computedHmacDigest) $ throwE unauthorizedHmac
+    where
+        HostsParams { hostsParamsHmac, hostsParamsExpiration, hostsParamsSalt } = params
+        unauthorizedHmac = ClientCryptographyE "Unauthorized hmac"
+
+verifyTimestampNotExpired :: MonadIO m => Text -> S9ErrT m ()
+verifyTimestampNotExpired expirationTimestamp = do
+    now <- liftIO getCurrentTime
+    case parseISO8601 . toS $ expirationTimestamp of
+        Nothing         -> throwE $ TTLExpirationE "invalid timestamp"
+        Just expiration -> when (expiration < now) (throwE $ TTLExpirationE "expired")
+
+getRegistration :: (MonadIO m, HasFilesystemBase sig m, Has (Error S9Error) sig m) => Text -> UTCTime -> m RegisterRes
+getRegistration productKey registerResClaimedAt = do
+    torAddress <- getAgentHiddenServiceUrlMaybe >>= \case
+        Nothing -> throwError $ NotFoundE "prior registration" "torAddress"
+        Just t  -> pure $ t
+    caCert <- readSystemPath rootCaCertPath >>= \case
+        Nothing -> throwError $ NotFoundE "prior registration" "cert"
+        Just t  -> pure t
+
+    -- create an hmac of the torAddress + caCert for front end
+    registerResTorAddressSig <- produceProofOfKey productKey torAddress
+    registerResCertSig       <- produceProofOfKey productKey caCert
+
+    let registerResCertName = root_CA_CERT_NAME
+    registerResLanAddress <- getStart9AgentHostnameLocal
+
+    pure RegisterRes { .. }
+
+getCertificateR :: Handler TypedContent
+getCertificateR = do
+    base <- getsYesod $ appFilesystemBase . appSettings
+    respondSource "application/x-x509-ca-cert"
+        $  CB.sourceFile (toS $ rootCaCertPath `relativeTo` base)
+        .| awaitForever sendChunkBS

agent/src/Handler/Icons.hs

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

agent/src/Handler/Login.hs

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

agent/src/Handler/Notifications.hs

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

agent/src/Handler/PasswordUpdate.hs

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

agent/src/Handler/PowerOff.hs

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

agent/src/Handler/Register.hs

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

agent/src/Handler/Register/Nginx.hs

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

agent/src/Handler/Register/Tor.hs

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

agent/src/Handler/SelfUpdate.hs

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

agent/src/Handler/SshKeys.hs

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

agent/src/Handler/Status.hs

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

agent/src/Handler/Tor.hs

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

agent/src/Handler/Types/Apps.hs

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

agent/src/Handler/Types/HmacSig.hs

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

agent/src/Handler/Types/Hosts.hs

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

agent/src/Handler/Types/Metrics.hs

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

agent/src/Handler/Types/Parse.hs

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

agent/src/Handler/Types/Register.hs

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

agent/src/Handler/Types/V0/Base.hs

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

agent/src/Handler/Types/V0/Specs.hs

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

agent/src/Handler/Types/V0/Ssh.hs

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

agent/src/Handler/Types/V0/Wifi.hs

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

agent/src/Handler/Util.hs

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

agent/src/Handler/V0.hs

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

agent/src/Handler/Wifi.hs

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

agent/src/Lib/Algebra/Domain/AppMgr.hs

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

agent/src/Lib/Algebra/Domain/AppMgr/TH.hs

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

agent/src/Lib/Algebra/Domain/AppMgr/Types.hs

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

agent/src/Lib/Algebra/State/RegistryUrl.hs

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

agent/src/Lib/Avahi.hs

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

agent/src/Lib/Background.hs

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

agent/src/Lib/ClientManifest.hs

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

agent/src/Lib/Crypto.hs

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

agent/src/Lib/Database.hs

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

agent/src/Lib/Error.hs

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

agent/src/Lib/External/AppManifest.hs

@@ -0,0 +1,100 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Lib.External.AppManifest where
+
+import           Startlude               hiding ( ask )
+
+import           Control.Effect.Reader.Labelled
+import           Data.Aeson
+import           Data.Singletons.TypeLits
+import qualified Data.HashMap.Strict           as HM
+import qualified Data.Yaml                     as Yaml
+import           Exinst
+
+import           Lib.Error
+import           Lib.SystemPaths
+import           Lib.Types.Core
+import           Lib.Types.Emver
+import           Lib.Types.Emver.Orphans        ( )
+import           Control.Monad.Fail             ( MonadFail(fail) )
+
+data ImageType = ImageTypeTar
+    deriving (Eq, Show)
+
+instance FromJSON ImageType where
+    parseJSON = withText "Image Type" $ \case
+        "tar" -> pure ImageTypeTar
+        wat   -> fail $ "Unknown Image Type: " <> toS wat
+
+data OnionVersion = OnionV2 | OnionV3
+    deriving (Eq, Ord, Show)
+
+instance FromJSON OnionVersion where
+    parseJSON = withText "Onion Version" $ \case
+        "v2" -> pure OnionV2
+        "v3" -> pure OnionV3
+        wat  -> fail $ "Unknown Onion Version: " <> toS wat
+
+data AssetMapping = AssetMapping
+    { assetMappingSource    :: FilePath
+    , assetMappingDest      :: FilePath
+    , assetMappingOverwrite :: Bool
+    }
+    deriving (Eq, Show)
+
+instance FromJSON AssetMapping where
+    parseJSON = withObject "Asset Mapping" $ \o -> do
+        assetMappingSource    <- o .: "src"
+        assetMappingDest      <- o .: "dst"
+        assetMappingOverwrite <- o .: "overwrite"
+        pure $ AssetMapping { .. }
+
+data AppManifest (n :: Nat) where
+    AppManifestV0 ::{ appManifestV0Id :: AppId
+                    , appManifestV0Version :: Version
+                    , appManifestV0Title :: Text
+                    , appManifestV0DescShort :: Text
+                    , appManifestV0DescLong :: Text
+                    , appManifestV0ReleaseNotes :: Text
+                    , appManifestV0PortMapping :: HM.HashMap Word16 Word16
+                    , appManifestV0ImageType :: ImageType
+                    , appManifestV0Mount :: FilePath
+                    , appManifestV0Assets :: [AssetMapping]
+                    , appManifestV0OnionVersion :: OnionVersion
+                    , appManifestV0Dependencies :: HM.HashMap AppId VersionRange
+                    } -> AppManifest 0
+
+instance FromJSON (Some1 AppManifest) where
+    parseJSON = withObject "App Manifest" $ \o -> do
+        o .: "compat" >>= \case
+            ("v0" :: Text) -> Some1 (SNat @0) <$> parseJSON (Object o)
+            compat         -> fail $ "Unknown Manifest Version: " <> toS compat
+
+instance FromJSON (AppManifest 0) where
+    parseJSON = withObject "App Manifest V0" $ \o -> do
+        appManifestV0Id           <- o .: "id"
+        appManifestV0Version      <- o .: "version"
+        appManifestV0Title        <- o .: "title"
+        appManifestV0DescShort    <- o .: "description" >>= (.: "short")
+        appManifestV0DescLong     <- o .: "description" >>= (.: "long")
+        appManifestV0ReleaseNotes <- o .: "release-notes"
+        appManifestV0PortMapping  <- o .: "ports" >>= fmap HM.fromList . traverse parsePortMapping
+        appManifestV0ImageType    <- o .: "image" >>= (.: "type")
+        appManifestV0Mount        <- o .: "mount"
+        appManifestV0Assets       <- o .: "assets" >>= traverse parseJSON
+        appManifestV0OnionVersion <- o .: "hidden-service-version"
+        appManifestV0Dependencies <- o .:? "dependencies" .!= HM.empty >>= traverse parseDepInfo
+        pure $ AppManifestV0 { .. }
+        where
+            parsePortMapping = withObject "Port Mapping" $ \o -> liftA2 (,) (o .: "tor") (o .: "internal")
+            parseDepInfo     = withObject "Dep Info" $ (.: "version")
+
+getAppManifest :: (MonadIO m, HasFilesystemBase sig m) => AppId -> S9ErrT m (Maybe (Some1 AppManifest))
+getAppManifest appId = do
+    base <- ask @"filesystemBase"
+    ExceptT $ first (ManifestParseE appId) <$> liftIO
+        (Yaml.decodeFileEither . toS $ (appMgrAppPath appId <> "manifest.yaml") `relativeTo` base)
+
+uiAvailable :: AppManifest n -> Bool
+uiAvailable = \case
+    AppManifestV0 { appManifestV0PortMapping } -> elem 80 (HM.keys appManifestV0PortMapping)

agent/src/Lib/External/AppMgr.hs

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

agent/src/Lib/External/Metrics/Df.hs

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

agent/src/Lib/External/Metrics/Iotop.hs

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

agent/src/Lib/External/Metrics/ProcDev.hs

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

agent/src/Lib/External/Metrics/Temperature.hs

@@ -0,0 +1,22 @@
+module Lib.External.Metrics.Temperature where
+
+import           Startlude
+
+import qualified Data.Attoparsec.Text          as A
+import qualified Data.Text                     as T
+import           Lib.External.Metrics.Types
+import           System.Process.Text
+
+-- Pi4 Specific
+getTemperature :: MonadIO m => m (Maybe Celsius)
+getTemperature = liftIO $ do
+    (ec, tempString, errlog) <- readProcessWithExitCode "/opt/vc/bin/vcgencmd" ["measure_temp"] ""
+    unless (T.null errlog) $ putStrLn errlog
+    case ec of
+        ExitFailure _ -> pure Nothing
+        ExitSuccess   -> case A.parse tempParser tempString of
+            A.Done _ c -> pure $ Just c
+            _          -> pure Nothing
+
+tempParser :: A.Parser Celsius
+tempParser = A.asciiCI "temp=" *> fmap Celsius A.double <* "'C" <* A.endOfLine

agent/src/Lib/External/Metrics/Top.hs

@@ -0,0 +1,114 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE QuasiQuotes      #-}
+{-# LANGUAGE RecordWildCards  #-}
+
+module Lib.External.Metrics.Top where
+
+import           Startlude
+
+import qualified Data.HashMap.Strict           as HM
+import           System.Process
+
+import           Lib.Error
+import           Lib.External.Metrics.Types
+import           Lib.External.Util
+import           Util.Text
+
+data TopMetrics = TopMetrics
+    { metricMemPercentageUsed :: Maybe Percentage
+    , metricMemFree           :: Maybe MebiBytes
+    , metricMemUsed           :: Maybe MebiBytes
+
+    , metricSwapTotal         :: Maybe MebiBytes
+    , metricSwapUsed          :: Maybe MebiBytes
+
+    , metricCpuIdle           :: Maybe Percentage
+    , metricCpuUserSpace      :: Maybe Percentage
+    , metricWait              :: Maybe Percentage
+    , metricCpuPercentageUsed :: Maybe Percentage
+    } deriving (Eq, Show)
+
+getTopMetrics :: MonadIO m => S9ErrT m TopMetrics
+getTopMetrics = fmap parseTop runTop
+
+runTop :: MonadIO m => S9ErrT m Text
+runTop = do
+    (_, output, err') <- liftIO $ readProcessWithExitCode "top" ["-bn1"] ""
+    unless (null err') $ throwE . MetricE $ "top command failed with " <> toS err'
+    pure $ toS output
+
+parseTop :: Text -> TopMetrics
+parseTop t = TopMetrics { metricMemPercentageUsed = getMemPercentageUsed <$> mem
+                        , metricMemFree           = MebiBytes . memFree <$> mem
+                        , metricMemUsed           = MebiBytes . memUsed <$> mem
+                        , metricSwapTotal         = MebiBytes . memTotal <$> swapS
+                        , metricSwapUsed          = MebiBytes . memUsed <$> swapS
+                        , metricCpuIdle           = cpuId <$> cpu
+                        , metricCpuUserSpace      = cpuUs <$> cpu
+                        , metricWait              = cpuWa <$> cpu
+                        , metricCpuPercentageUsed = getCpuPercentageUsed <$> cpu
+                        }
+    where
+        topLines = lines t
+        cpu      = getCpuAggregates topLines
+        mem      = getMemAggregates memHeader topLines
+        swapS    = getMemAggregates swapHeader topLines
+
+memHeader :: Text
+memHeader = "MiB Mem"
+
+swapHeader :: Text
+swapHeader = "MiB Swap"
+
+data TopMemAggregates = TopMemAggregates
+    { memTotal :: Double
+    , memFree  :: Double
+    , memUsed  :: Double
+    } deriving (Eq, Show)
+
+cpuHeader :: Text
+cpuHeader = "%Cpu(s)"
+
+data TopCpuAggregates = TopCpuAggregates
+    { cpuUs :: Percentage
+    , cpuSy :: Percentage
+    , cpuNi :: Percentage
+    , cpuId :: Percentage
+    , cpuWa :: Percentage
+    , cpuHi :: Percentage
+    , cpuSi :: Percentage
+    , cpuSt :: Percentage
+    } deriving (Eq, Show)
+
+getMemAggregates :: Text -> [Text] -> Maybe TopMemAggregates
+getMemAggregates header topRes = do
+    memLine <- getLineByHeader header topRes
+    let stats = HM.fromList $ getStats readMaybe memLine
+    memTotal <- HM.lookup "total" stats
+    memFree  <- HM.lookup "free" stats
+    memUsed  <- HM.lookup "used" stats
+    pure TopMemAggregates { .. }
+
+getCpuAggregates :: [Text] -> Maybe TopCpuAggregates
+getCpuAggregates topRes = do
+    memLine <- getLineByHeader cpuHeader topRes
+    let stats = HM.fromList $ getStats (mkPercentage <=< readMaybe) memLine
+    cpuUs <- HM.lookup "us" stats
+    cpuSy <- HM.lookup "sy" stats
+    cpuNi <- HM.lookup "ni" stats
+    cpuId <- HM.lookup "id" stats
+    cpuWa <- HM.lookup "wa" stats
+    cpuHi <- HM.lookup "hi" stats
+    cpuSi <- HM.lookup "si" stats
+    cpuSt <- HM.lookup "st" stats
+    pure TopCpuAggregates { .. }
+
+getCpuPercentageUsed :: TopCpuAggregates -> Percentage
+getCpuPercentageUsed TopCpuAggregates {..} = Percentage (100 - unPercent cpuId)
+
+getMemPercentageUsed :: TopMemAggregates -> Percentage
+getMemPercentageUsed TopMemAggregates {..} = Percentage . truncateTo @Double 10 . (* 100) $ memUsed / memTotal
+
+getStats :: (Text -> Maybe a) -> Text -> [(Text, a)]
+getStats parseData = mapMaybe (parseToPair parseData) . fmap (words . toS) . getMatches statRegex . toS
+    where statRegex = "[0-9]+(.[0-9][0-9]?)? ([\x21-\x7E][^(,|.)]+)"

agent/src/Lib/External/Metrics/Types.hs

@@ -0,0 +1,89 @@
+module Lib.External.Metrics.Types where
+
+import           Startlude
+
+import           Data.Aeson
+import qualified GHC.Read                       ( Read(..)
+                                                , readsPrec
+                                                )
+import qualified GHC.Show                       ( Show(..) )
+
+import           Lib.External.Util
+
+class Metric a where
+    mUnit :: a -> Text
+    mValue :: a -> Double
+
+toMetricJson :: Metric a => a -> Value
+toMetricJson x = object ["value" .= truncateToS 2 (mValue x), "unit" .= mUnit x]
+toMetricShow :: Metric a => a -> String
+toMetricShow a = show (mValue a) <> " " <> toS (mUnit a)
+
+newtype Percentage = Percentage { unPercent :: Double } deriving (Eq)
+instance Metric Percentage where
+    mValue (Percentage p) = p
+    mUnit _ = "%"
+instance ToJSON Percentage where
+    toJSON = toMetricJson
+instance Show Percentage where
+    show = toMetricShow
+instance Read Percentage where
+    readsPrec _ s = case reverse s of
+        '%' : rest -> case GHC.Read.readsPrec 0 (reverse rest) of
+            [(result, "")] -> case mkPercentage result of
+                Just p -> [(p, "")]
+                _      -> []
+            _ -> []
+        _ -> []
+
+mkPercentage :: Double -> Maybe Percentage
+mkPercentage s | 0 <= s && s <= 100 = Just $ Percentage s
+               | otherwise          = Nothing
+
+newtype MebiBytes = MebiBytes Double
+    deriving stock Eq
+    deriving newtype Num
+
+instance Metric MebiBytes where
+    mValue (MebiBytes p) = p
+    mUnit _ = "MiB"
+instance ToJSON MebiBytes where
+    toJSON = toMetricJson
+instance Show MebiBytes where
+    show = toMetricShow
+
+newtype BytesPerSecond = BytesPerSecond Double
+    deriving stock Eq
+    deriving newtype Num
+
+instance Metric BytesPerSecond where
+    mValue (BytesPerSecond p) = p
+    mUnit _ = "B/s"
+instance ToJSON BytesPerSecond where
+    toJSON = toMetricJson
+instance Show BytesPerSecond where
+    show = toMetricShow
+
+newtype Gigabytes = Gigabytes Double
+    deriving stock Eq
+    deriving newtype Num
+
+instance Metric Gigabytes where
+    mValue (Gigabytes p) = p
+    mUnit _ = "Gb"
+instance ToJSON Gigabytes where
+    toJSON = toMetricJson
+instance Show Gigabytes where
+    show = toMetricShow
+
+newtype Celsius = Celsius { unCelsius :: Double }
+    deriving stock Eq
+    deriving newtype Num
+
+instance Metric Celsius where
+    mValue (Celsius c) = c
+    mUnit _ = "°C"
+instance ToJSON Celsius where
+    toJSON = toMetricJson
+instance Show Celsius where
+    show = toMetricShow

agent/src/Lib/External/Registry.hs

@@ -0,0 +1,196 @@
+{-# LANGUAGE QuasiQuotes     #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Lib.External.Registry where
+
+import           Startlude               hiding ( (<.>)
+                                                , Reader
+                                                , ask
+                                                , runReader
+                                                )
+import           Startlude.ByteStream    hiding ( count )
+
+import           Conduit
+import           Control.Algebra
+import           Control.Effect.Lift
+import           Control.Effect.Error
+import           Control.Effect.Reader.Labelled
+import           Control.Monad.Fail             ( fail )
+import           Control.Monad.Trans.Resource
+import qualified Data.ByteString.Streaming.HTTP
+                                               as S
+import qualified Data.HashMap.Strict           as HM
+import           Data.Maybe                     ( fromJust )
+import           Data.String.Interpolate.IsString
+import           Data.Yaml
+import           Network.HTTP.Client.Conduit    ( Manager )
+import           Network.HTTP.Simple
+import           System.Directory
+import           System.Process
+
+import           Constants
+import           Lib.Algebra.State.RegistryUrl
+import           Lib.Error
+import           Lib.SystemPaths
+import           Lib.Types.Core
+import           Lib.Types.Emver
+import           Lib.Types.ServerApp
+
+newtype AppManifestRes = AppManifestRes
+    { storeApps :: [StoreApp] } deriving (Eq, Show)
+
+newtype RegistryVersionForSpecRes = RegistryVersionForSpecRes
+    { registryVersionForSpec :: Maybe Version } deriving (Eq, Show)
+
+instance FromJSON RegistryVersionForSpecRes where
+    parseJSON Null       = pure (RegistryVersionForSpecRes Nothing)
+    parseJSON (Object o) = do
+        registryVersionForSpec <- o .:? "version"
+        pure . RegistryVersionForSpecRes $ registryVersionForSpec
+    parseJSON _ = fail "expected null or object"
+
+tmpAgentFileName :: Text
+tmpAgentFileName = "agent-tmp"
+
+agentFileName :: Text
+agentFileName = "agent"
+
+userAgentHeader :: ByteString
+userAgentHeader = [i|EmbassyOS/#{agentVersion}|]
+
+setUserAgent :: Request -> Request
+setUserAgent = setRequestHeader "User-Agent" [userAgentHeader]
+
+getYoungAgentBinary :: (Has RegistryUrl sig m, HasLabelled "filesystemBase" (Reader Text) sig m, Has (Lift IO) sig m)
+                    => VersionRange
+                    -> m ()
+getYoungAgentBinary avs = do
+    base <- ask @"filesystemBase"
+    let tmpAgentPath = toS $ executablePath `relativeTo` base </> tmpAgentFileName
+    tmpExists <- sendIO $ doesPathExist tmpAgentPath
+    when tmpExists $ sendIO $ removeFile tmpAgentPath
+    url     <- registryAppAgentUrl avs
+    request <- sendIO . fmap setUserAgent . parseRequestThrow $ toS url
+    sendIO $ runConduitRes $ httpSource request getResponseBody .| sinkFile tmpAgentPath
+    sendIO $ void $ readProcessWithExitCode "chmod" ["700", tmpAgentPath] ""
+
+getLifelineBinary :: (Has RegistryUrl sig m, HasFilesystemBase sig m, MonadIO m) => VersionRange -> m ()
+getLifelineBinary avs = do
+    base <- ask @"filesystemBase"
+    let lifelineTarget = lifelineBinaryPath `relativeTo` base
+    url     <- registryUrl
+    request <- liftIO . fmap setUserAgent . parseRequestThrow $ toS (url </> "sys/lifeline?spec=" <> show avs)
+    liftIO $ runConduitRes $ httpSource request getResponseBody .| sinkFile (toS lifelineTarget)
+    liftIO $ void $ readProcessWithExitCode "chmod" ["700", toS lifelineTarget] ""
+
+getAppManifest :: (MonadIO m, Has (Error S9Error) sig m, Has RegistryUrl sig m) => m AppManifestRes
+getAppManifest = do
+    manifestPath <- registryManifestUrl
+    req          <- liftIO $ fmap setUserAgent . parseRequestThrow $ toS manifestPath
+    val          <- (liftIO . try @SomeException) (httpBS req) >>= \case
+        Left  _ -> throwError RegistryUnreachableE
+        Right a -> pure $ getResponseBody a
+    parseBsManifest val >>= \case
+        Left  e -> throwError $ RegistryParseE manifestPath . toS $ e
+        Right a -> pure a
+
+
+getStoreAppInfo :: (MonadIO m, Has RegistryUrl sig m, Has (Error S9Error) sig m) => AppId -> m (Maybe StoreApp)
+getStoreAppInfo name = find ((== name) . storeAppId) . storeApps <$> getAppManifest
+
+parseBsManifest :: Has RegistryUrl sig m => ByteString -> m (Either String AppManifestRes)
+parseBsManifest bs = do
+    parseRegistryRes' <- parseRegistryRes
+    pure $ parseEither parseRegistryRes' . fromJust . decodeThrow $ bs
+
+parseRegistryRes :: Has RegistryUrl sig m => m (Value -> Parser AppManifestRes)
+parseRegistryRes = do
+    parseAppData' <- parseAppData
+    pure $ withObject "app registry response" $ \obj -> do
+        let keyVals       = HM.toList obj
+        let mManifestApps = fmap (\(k, v) -> parseMaybe (parseAppData' (AppId k)) v) keyVals
+        pure . AppManifestRes . catMaybes $ mManifestApps
+
+registryUrl :: (Has RegistryUrl sig m) => m Text
+registryUrl = maybe "https://registry.start9labs.com:443" show <$> getRegistryUrl
+
+registryManifestUrl :: Has RegistryUrl sig m => m Text
+registryManifestUrl = registryUrl <&> (</> "apps")
+
+registryAppAgentUrl :: Has RegistryUrl sig m => VersionRange -> m Text
+registryAppAgentUrl avs = registryUrl <&> (</> ("sys/agent?spec=" <> show avs))
+
+registryCheckVersionForSpecUrl :: Has RegistryUrl sig m => VersionRange -> m Text
+registryCheckVersionForSpecUrl avs = registryUrl <&> (</> ("sys/version/agent?spec=" <> show avs))
+
+parseAppData :: Has RegistryUrl sig m => m (AppId -> Value -> Parser StoreApp)
+parseAppData = do
+    url <- registryUrl
+    pure $ \storeAppId -> withObject "appmgr app data" $ \ad -> do
+        storeAppTitle            <- ad .: "title"
+        storeAppDescriptionShort <- ad .: "description" >>= (.: "short")
+        storeAppDescriptionLong  <- ad .: "description" >>= (.: "long")
+        storeAppIconUrl          <- fmap (\typ -> toS $ url </> "icons" </> show storeAppId <.> typ) $ ad .: "icon-type"
+        storeAppVersions         <- ad .: "version-info" >>= \case
+            []       -> fail "No Valid Version Info"
+            (x : xs) -> pure $ x :| xs
+        pure StoreApp { .. }
+
+getAppVersionForSpec :: (Has RegistryUrl sig m, Has (Error S9Error) sig m, MonadIO m)
+                     => AppId
+                     -> VersionRange
+                     -> m Version
+getAppVersionForSpec appId spec = do
+    let path = "apps/version" </> show appId <> "?spec=" <> show spec
+    val <- registryRequest path
+    parseOrThrow path val $ withObject "version response" $ \o -> do
+        v <- o .: "version"
+        pure v
+
+getLatestAgentVersion :: (Has RegistryUrl sig m, Has (Error S9Error) sig m, MonadIO m) => m Version
+getLatestAgentVersion = do
+    val <- registryRequest agentVersionPath
+    parseOrThrow agentVersionPath val $ withObject "version response" $ \o -> do
+        v <- o .: "version"
+        pure v
+    where agentVersionPath = "sys/version/agent"
+
+getLatestAgentVersionForSpec :: (Has RegistryUrl sig m, Has (Lift IO) sig m, Has (Error S9Error) sig m)
+                             => VersionRange
+                             -> m (Maybe Version)
+getLatestAgentVersionForSpec avs = do
+    url <- registryUrl
+    req <- sendIO $ fmap setUserAgent . parseRequestThrow . toS $ url </> agentVersionPath
+    res <- fmap (first jsonToS9Exception) . sendIO $ try @JSONException $ parseRes req
+    case res of
+        Left  e -> throwError e
+        Right a -> pure a
+    where
+        parseRes r = registryVersionForSpec . getResponseBody <$> httpJSON r
+        agentVersionPath  = "sys/version/agent?spec=" <> show avs
+        jsonToS9Exception = RegistryParseE (toS agentVersionPath) . show
+
+getAmbassadorUiForSpec :: (Has RegistryUrl sig m, HasLabelled "httpManager" (Reader Manager) sig m, MonadResource m)
+                       => VersionRange
+                       -> ByteStream m ()
+getAmbassadorUiForSpec avs = do
+    url     <- lift registryUrl
+    manager <- lift $ ask @"httpManager"
+    let target = url </> "sys/ambassador-ui.tar.gz?spec=" <> show avs
+    req  <- liftResourceT $ lift $ fmap setUserAgent . parseRequestThrow . toS $ target
+    resp <- lift $ S.http req manager
+    getResponseBody resp
+
+registryRequest :: (Has RegistryUrl sig m, Has (Error S9Error) sig m, MonadIO m) => Text -> m Value
+registryRequest path = do
+    url <- registryUrl
+    req <- liftIO . fmap setUserAgent . parseRequestThrow . toS $ url </> path
+    (liftIO . try @SomeException) (httpJSON req) >>= \case
+        Left  _ -> throwError RegistryUnreachableE
+        Right a -> pure $ getResponseBody a
+
+parseOrThrow :: (Has (Error S9Error) sig m) => Text -> a -> (a -> Parser b) -> m b
+parseOrThrow path val parser = case parseEither parser val of
+    Left  e -> throwError (RegistryParseE path $ toS e)
+    Right a -> pure a

agent/src/Lib/External/Specs/CPU.hs

@@ -0,0 +1,32 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Lib.External.Specs.CPU
+    ( getCpuInfo
+    )
+where
+
+import           Startlude
+import           Protolude.Unsafe               ( unsafeFromJust )
+
+import           Data.String.Interpolate.IsString
+import           System.Process
+
+import           Lib.External.Specs.Common
+
+lscpu :: IO Text
+lscpu = toS <$> readProcess "lscpu" [] ""
+
+getModelName :: Text -> Text
+getModelName = unsafeFromJust . getSpec "Model name"
+
+getCores :: Text -> Text
+getCores = unsafeFromJust . getSpec "CPU(s)"
+
+getClockSpeed :: Text -> Text
+getClockSpeed = (<> "MHz") . unsafeFromJust . getSpec "CPU max"
+
+getCpuInfo :: IO Text
+getCpuInfo = lscpu <&> do
+    model <- getModelName
+    cores <- getCores
+    clock <- getClockSpeed
+    pure $ [i|#{model}: #{cores} cores @ #{clock}|]

agent/src/Lib/External/Specs/Common.hs

@@ -0,0 +1,13 @@
+module Lib.External.Specs.Common where
+
+import           Startlude
+
+import qualified Data.Text                     as T
+
+getSpec :: Text -> Text -> Maybe Text
+getSpec spec output = do
+    mi <- modelItem
+    fmap T.strip $ T.splitOn ":" mi `atMay` 1
+    where
+        items     = lines output
+        modelItem = find (spec `T.isPrefixOf`) items

agent/src/Lib/External/Specs/Memory.hs

@@ -0,0 +1,12 @@
+module Lib.External.Specs.Memory where
+
+import           Startlude
+import           Protolude.Unsafe               ( unsafeFromJust )
+
+import           Lib.External.Specs.Common
+
+catMem :: IO Text
+catMem = readFile "/proc/meminfo"
+
+getMem :: IO Text
+getMem = unsafeFromJust . getSpec "MemTotal" <$> catMem

agent/src/Lib/External/Util.hs

@@ -0,0 +1,17 @@
+{-# LANGUAGE TupleSections #-}
+module Lib.External.Util where
+
+import           Startlude
+
+getLineByHeader :: Text -> [Text] -> Maybe Text
+getLineByHeader t = find (isPrefixOf (toS t :: String) . toS)
+
+truncateTo :: RealFloat a => Int -> a -> Double
+truncateTo n x = realToFrac $ fromIntegral (floor (x * t) :: Integer) / t where t = 10 ^ n
+
+truncateToS :: Int -> Double -> Double
+truncateToS n x = fromIntegral (floor (x * t) :: Integer) / t where t = 10 ^ n
+
+parseToPair :: (Text -> Maybe a) -> [Text] -> Maybe (Text, a)
+parseToPair parse [k, v] = ((k, ) <$> parse v) <|> ((v, ) <$> parse k)
+parseToPair _     _      = Nothing

agent/src/Lib/External/WpaSupplicant.hs

@@ -0,0 +1,102 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Lib.External.WpaSupplicant where
+
+import           Startlude
+
+import           Data.Bitraversable
+import qualified Data.HashMap.Strict           as HM
+import           Data.String.Interpolate.IsString
+import qualified Data.Text                     as T
+import           System.Process
+import           Control.Concurrent.Async.Lifted
+                                               as LAsync
+import           Control.Monad.Trans.Control    ( MonadBaseControl )
+
+runWlan0 :: ReaderT Text m a -> m a
+runWlan0 = flip runReaderT "wlan0"
+
+isConnectedToEthernet :: MonadIO m => m Bool
+isConnectedToEthernet = do
+    liftIO $ not . null . filter (T.isInfixOf "inet ") . lines . toS <$> readProcess "ifconfig" ["eth0"] ""
+
+-- There be bug here: if you're in the US, and add a network in Sweden, you'll set your wpa supplicant to be looking for networks in Sweden.
+-- so you won't be autoconnecting to anything in the US till you add another US guy.
+addNetwork :: MonadIO m => Text -> Text -> Text -> ReaderT Interface m ()
+addNetwork ssid psk country = do
+    interface <- ask
+    networkId <- checkNetwork ssid >>= \case
+        -- If the network already exists, we will update its password.
+        Just nId -> do
+            void . liftIO $ readProcess "wpa_cli" ["-i", toS interface, "new_password", toS nId, [i|"#{psk}"|]] ""
+            pure nId
+
+        -- Otherwise we create the network in the wpa_supplicant
+        Nothing -> do
+            nId <- liftIO $ T.strip . toS <$> readProcess "wpa_cli" ["-i", toS interface, "add_network"] ""
+            void . liftIO $ readProcess "wpa_cli"
+                                        ["-i", toS interface, "set_network", toS nId, "ssid", [i|"#{ssid}"|]]
+                                        ""
+            void . liftIO $ readProcess "wpa_cli" ["-i", toS interface, "set_network", toS nId, "psk", [i|"#{psk}"|]] ""
+            void . liftIO $ readProcess "wpa_cli" ["-i", toS interface, "set_network", toS nId, "scan_ssid", "1"] ""
+            pure nId
+
+    void . liftIO $ readProcess "wpa_cli" ["-i", toS interface, "set", "country", toS country] ""
+    void . liftIO $ readProcess "wpa_cli" ["-i", toS interface, "enable_network", toS networkId] ""
+    void . liftIO $ readProcess "wpa_cli" ["-i", toS interface, "save_config"] ""
+
+removeNetwork :: MonadIO m => Text -> ReaderT Interface m ()
+removeNetwork ssid = do
+    interface <- ask
+    checkNetwork ssid >>= \case
+        Nothing -> pure ()
+        Just x  -> liftIO $ do
+            void $ readProcess "wpa_cli" ["-i", toS interface, "remove_network", [i|#{x}|]] ""
+            void $ readProcess "wpa_cli" ["-i", toS interface, "save_config"] ""
+            void $ readProcess "wpa_cli" ["-i", toS interface, "reconfigure"] ""
+
+listNetworks :: MonadIO m => ReaderT Interface m [Text]
+listNetworks = do
+    interface <- ask
+    liftIO $ mapMaybe (`atMay` 1) . drop 1 . fmap (T.splitOn "\t") . lines . toS <$> readProcess
+        "wpa_cli"
+        ["-i", toS interface, "list_networks"]
+        ""
+
+type Interface = Text
+getCurrentNetwork :: (MonadBaseControl IO m, MonadIO m) => ReaderT Interface m (Maybe Text)
+getCurrentNetwork = do
+    interface <- ask @Text
+    liftIO $ guarded (/= "") . T.init . toS <$> readProcess "iwgetid" [toS interface, "--raw"] ""
+
+selectNetwork :: (MonadBaseControl IO m, MonadIO m) => Text -> Text -> ReaderT Interface m Bool
+selectNetwork ssid country = checkNetwork ssid >>= \case
+    Nothing  -> putStrLn @Text "SSID Not Found" *> pure False
+    Just nId -> do
+        interface <- ask
+        void . liftIO $ readProcess "wpa_cli" ["-i", toS interface, "select_network", toS nId] ""
+        void . liftIO $ readProcess "wpa_cli" ["-i", toS interface, "set", "country", toS country] ""
+        void . liftIO $ readProcess "wpa_cli" ["-i", toS interface, "save_config"] ""
+        mNew <- join . hush <$> LAsync.race (liftIO $ threadDelay 20_000_000)
+                                            (runMaybeT . asum $ repeat (MaybeT getCurrentNetwork))
+        listNetworks >>= \nets ->
+            for_ nets $ \net -> liftIO $ readProcess "wpa_cli" ["-i", toS interface, "enable_network", toS net] ""
+        pure $ case mNew of
+            Nothing         -> False
+            Just newCurrent -> newCurrent == ssid
+
+type NetworkId = Text
+checkNetwork :: MonadIO m => Text -> ReaderT Interface m (Maybe NetworkId)
+checkNetwork ssid = do
+    interface <- ask
+    HM.lookup ssid
+        .   HM.fromList
+        .   mapMaybe (bisequenceA . ((`atMay` 1) &&& (`atMay` 0)))
+        .   drop 1
+        .   fmap (T.splitOn "\t")
+        .   lines
+        .   toS
+        <$> liftIO (readProcess "wpa_cli" ["-i", toS interface, "list_networks"] "")
+
+-- TODO: Live Testing in GHCI
+runWpa :: ReaderT Interface m a -> m a
+runWpa = flip runReaderT "wlp5s0"

agent/src/Lib/IconCache.hs

@@ -0,0 +1,94 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Lib.IconCache where
+
+import           Startlude               hiding ( ask
+                                                , catch
+                                                , throwIO
+                                                , Reader
+                                                )
+
+import           Conduit
+import           Control.Concurrent.STM.TVar
+import           Control.Effect.Reader.Labelled
+import           Crypto.Hash
+import qualified Data.Conduit.Binary           as CB
+import qualified Data.HashMap.Strict           as HM
+import           Data.String.Interpolate.IsString
+import           Network.HTTP.Simple
+import           System.Directory
+import           System.FilePath
+import           System.IO.Error
+import           UnliftIO.Exception
+
+import           Lib.Error
+import           Lib.SystemPaths         hiding ( (</>) )
+import           Lib.Types.Core
+import           Database.Persist.Sql           ( runSqlPool
+                                                , repsert
+                                                , ConnectionPool
+                                                , delete
+                                                )
+import           Model
+import           Control.Effect.Error
+import           Crypto.Hash.Conduit            ( hashFile )
+import           Util.File                      ( removeFileIfExists )
+
+type HasIconTags sig m = HasLabelled "iconTagCache" (Reader (TVar (HM.HashMap AppId (Digest MD5)))) sig m
+
+findIcon :: (HasFilesystemBase sig m, MonadIO m) => AppId -> m (Maybe FilePath)
+findIcon appId = do
+    bp    <- toS <$> getAbsoluteLocationFor iconBasePath
+    icons <- liftIO $ (listDirectory bp) `catch` \(e :: IOException) ->
+        if isDoesNotExistError e then createDirectoryIfMissing True bp *> pure [] else throwIO e
+    pure $ (bp </>) <$> find ((show appId ==) . takeBaseName) icons
+
+saveIcon :: ( HasFilesystemBase sig m
+            , HasIconTags sig m
+            , HasLabelled "databaseConnection" (Reader ConnectionPool) sig m
+            , Has (Error S9Error) sig m
+            , MonadIO m
+            )
+         => String
+         -> m ()
+saveIcon url = do
+    bp  <- toS <$> getAbsoluteLocationFor iconBasePath
+    req <- case parseRequest url of
+        Nothing -> throwError $ RegistryParseE (toS url) "invalid url"
+        Just x  -> pure x
+    let saveAction = runConduit $ httpSource req getResponseBody .| CB.sinkFileCautious (bp </> takeFileName url)
+    liftIO $ runResourceT $ saveAction `catch` \(e :: IOException) -> if isDoesNotExistError e
+        then do
+            liftIO $ createDirectoryIfMissing True bp
+            saveAction
+        else throwIO e
+    tag <- hashFile (bp </> takeFileName url)
+    saveTag (AppId . toS $ takeFileName url) tag
+
+saveTag :: (HasIconTags sig m, HasLabelled "databaseConnection" (Reader ConnectionPool) sig m, MonadIO m)
+        => AppId
+        -> Digest MD5
+        -> m ()
+saveTag appId tag = do
+    cache <- ask @"iconTagCache"
+    pool  <- ask @"databaseConnection"
+    liftIO $ runSqlPool (repsert (IconDigestKey appId) (IconDigest tag)) pool `catch` \(e :: SomeException) ->
+        putStrLn @Text [i|Icon Cache Insertion Failed!: #{appId}, #{tag}, #{e}|]
+    liftIO $ atomically $ modifyTVar cache $ HM.insert appId tag
+
+clearIcon :: ( MonadIO m
+             , HasLabelled "iconTagCache" (Reader (TVar (HM.HashMap AppId v0))) sig m
+             , HasLabelled "databaseConnection" (Reader ConnectionPool) sig m
+             , HasLabelled "filesystemBase" (Reader Text) sig m
+             )
+          => AppId
+          -> m ()
+clearIcon appId = do
+    db       <- ask @"databaseConnection"
+    iconTags <- ask @"iconTagCache"
+    liftIO . atomically $ modifyTVar iconTags (HM.delete appId)
+    liftIO $ runSqlPool (delete (IconDigestKey appId)) db
+    findIcon appId >>= \case
+        Nothing -> pure ()
+        Just x  -> removeFileIfExists x

agent/src/Lib/Metrics.hs

@@ -0,0 +1,158 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module Lib.Metrics where
+
+import           Startlude
+
+import           Data.Aeson
+import           Data.IORef
+
+import           Foundation
+import           Lib.Error
+import           Lib.External.Metrics.Df
+import           Lib.External.Metrics.Iotop
+import           Lib.External.Metrics.ProcDev
+import           Lib.External.Metrics.Temperature
+import           Lib.External.Metrics.Top
+import           Lib.External.Metrics.Types
+
+-- will throw only if one of '$ top', '$ iotop, '$ procDev' commands fails on the command line.
+getServerMetrics :: MonadIO m => AgentCtx -> S9ErrT m ServerMetrics
+getServerMetrics agentCtx = do
+    temp            <- getTemperature
+    df              <- getDfMetrics
+    top             <- getTopMetrics
+    iotop           <- getIotopMetrics
+    (_, _, procDev) <- liftIO . readIORef . appProcDevMomentCache $ agentCtx
+
+    pure $ fromCommandLineMetrics (temp, df, top, iotop, procDev)
+
+data ServerMetrics = ServerMetrics
+    { serverMetricsTemperature       :: Maybe Celsius
+
+    , serverMetricMemPercentageUsed  :: Maybe Percentage
+    , serverMetricMemFree            :: Maybe MebiBytes
+    , serverMetricMemUsed            :: Maybe MebiBytes
+    , serverMetricSwapTotal          :: Maybe MebiBytes
+    , serverMetricSwapUsed           :: Maybe MebiBytes
+
+    , serverMetricCpuIdle            :: Maybe Percentage
+    , serverMetricCpuUserSpace       :: Maybe Percentage
+    , serverMetricWait               :: Maybe Percentage
+    , serverMetricCpuPercentageUsed  :: Maybe Percentage
+
+    , serverMetricCurrentRead        :: Maybe BytesPerSecond
+    , serverMetricCurrentWrite       :: Maybe BytesPerSecond
+    , serverMetricTotalRead          :: Maybe BytesPerSecond
+    , serverMetricTotalWrite         :: Maybe BytesPerSecond
+
+    , serverMetricRBytesPerSecond    :: Maybe BytesPerSecond
+    , serverMetricRPacketsPerSecond  :: Maybe BytesPerSecond
+    , serverMetricRErrorsPerSecond   :: Maybe BytesPerSecond
+    , serverMetricTBytesPerSecond    :: Maybe BytesPerSecond
+    , serverMetricTPacketsPerSecond  :: Maybe BytesPerSecond
+    , serverMetricTErrorsPerSecond   :: Maybe BytesPerSecond
+
+    , serverMetricDiskSize           :: Maybe Gigabytes
+    , serverMetricDiskUsed           :: Maybe Gigabytes
+    , serverMetricDiskAvailable      :: Maybe Gigabytes
+    , serverMetricDiskUsedPercentage :: Maybe Percentage
+    } deriving (Eq, Show)
+
+instance ToJSON ServerMetrics where
+    toJSON ServerMetrics {..} = object
+        [ "GENERAL" .= object ["Temperature" .= serverMetricsTemperature]
+        , "MEMORY" .= object
+            [ "Percent Used" .= serverMetricMemPercentageUsed
+            , "Free" .= serverMetricMemFree
+            , "Used" .= serverMetricMemUsed
+            , "Swap Used" .= serverMetricSwapUsed
+            , "Swap Free" .= serverMetricSwapTotal ?-? serverMetricSwapUsed
+            ]
+        , "CPU" .= object
+            [ "Percent Used" .= serverMetricCpuPercentageUsed
+            , "Percent Free" .= serverMetricCpuIdle
+            , "Percent User Space" .= serverMetricCpuUserSpace
+            , "Percent IO Wait" .= serverMetricWait
+            ]
+        , "DISK" .= object
+            [ "Percent Used" .= serverMetricDiskUsedPercentage
+            , "Size" .= serverMetricDiskSize
+            , "Used" .= serverMetricDiskUsed
+            , "Free" .= serverMetricDiskAvailable
+            , "Total Read" .= serverMetricTotalRead
+            , "Total Write" .= serverMetricTotalWrite
+            , "Current Read" .= serverMetricCurrentRead
+            , "Current Write" .= serverMetricCurrentWrite
+            ]
+        , "NETWORK" .= object
+            [ "Bytes Received" .= serverMetricRBytesPerSecond
+            , "Packets Received" .= serverMetricRPacketsPerSecond
+            , "Errors Received" .= serverMetricRErrorsPerSecond
+            , "Bytes Transmitted" .= serverMetricTBytesPerSecond
+            , "Packets Transmitted" .= serverMetricTPacketsPerSecond
+            , "Errors Transmitted" .= serverMetricTErrorsPerSecond
+            ]
+        ]
+    toEncoding ServerMetrics {..} = (pairs . fold)
+        [ "GENERAL" .= object ["Temperature" .= serverMetricsTemperature]
+        , "MEMORY" .= object
+            [ "Percent Used" .= serverMetricMemPercentageUsed
+            , "Free" .= serverMetricMemFree
+            , "Used" .= serverMetricMemUsed
+            , "Swap Used" .= serverMetricSwapUsed
+            , "Swap Free" .= serverMetricSwapTotal ?-? serverMetricSwapUsed
+            ]
+        , "CPU" .= object
+            [ "Percent Used" .= serverMetricCpuPercentageUsed
+            , "Percent Free" .= serverMetricCpuIdle
+            , "Percent User Space" .= serverMetricCpuUserSpace
+            , "Percent IO Wait" .= serverMetricWait
+            ]
+        , "DISK" .= object
+            [ "Percent Used" .= serverMetricDiskUsedPercentage
+            , "Size" .= serverMetricDiskSize
+            , "Used" .= serverMetricDiskUsed
+            , "Free" .= serverMetricDiskAvailable
+            , "Total Read" .= serverMetricTotalRead
+            , "Total Write" .= serverMetricTotalWrite
+            , "Current Read" .= serverMetricCurrentRead
+            , "Current Write" .= serverMetricCurrentWrite
+            ]
+        , "NETWORK" .= object
+            [ "Bytes Received" .= serverMetricRBytesPerSecond
+            , "Packets Received" .= serverMetricRPacketsPerSecond
+            , "Errors Received" .= serverMetricRErrorsPerSecond
+            , "Bytes Transmitted" .= serverMetricTBytesPerSecond
+            , "Packets Transmitted" .= serverMetricTPacketsPerSecond
+            , "Errors Transmitted" .= serverMetricTErrorsPerSecond
+            ]
+        ]
+
+fromCommandLineMetrics :: (Maybe Celsius, DfMetrics, TopMetrics, IotopMetrics, ProcDevMetrics) -> ServerMetrics
+fromCommandLineMetrics (temp, DfMetrics {..}, TopMetrics {..}, IotopMetrics {..}, ProcDevMetrics {..}) = ServerMetrics
+    { serverMetricsTemperature       = temp
+    , serverMetricMemPercentageUsed  = metricMemPercentageUsed
+    , serverMetricMemFree            = metricMemFree
+    , serverMetricMemUsed            = metricMemUsed
+    , serverMetricSwapTotal          = metricSwapTotal
+    , serverMetricSwapUsed           = metricSwapUsed
+    , serverMetricCpuIdle            = metricCpuIdle
+    , serverMetricCpuUserSpace       = metricCpuUserSpace
+    , serverMetricWait               = metricWait
+    , serverMetricCpuPercentageUsed  = metricCpuPercentageUsed
+    , serverMetricCurrentRead        = metricCurrentRead
+    , serverMetricCurrentWrite       = metricCurrentWrite
+    , serverMetricTotalRead          = metricTotalRead
+    , serverMetricTotalWrite         = metricTotalWrite
+    , serverMetricRBytesPerSecond    = metricRBytesPerSecond
+    , serverMetricRPacketsPerSecond  = metricRPacketsPerSecond
+    , serverMetricRErrorsPerSecond   = metricRErrorsPerSecond
+    , serverMetricTBytesPerSecond    = metricTBytesPerSecond
+    , serverMetricTPacketsPerSecond  = metricTPacketsPerSecond
+    , serverMetricTErrorsPerSecond   = metricTErrorsPerSecond
+    , serverMetricDiskSize           = metricDiskSize
+    , serverMetricDiskUsed           = metricDiskUsed
+    , serverMetricDiskAvailable      = metricDiskAvailable
+    , serverMetricDiskUsedPercentage = metricDiskUsedPercentage
+    }

agent/src/Lib/Migration.hs

@@ -0,0 +1,96 @@
+{-# LANGUAGE NamedFieldPuns      #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE TypeApplications    #-}
+
+module Lib.Migration where
+
+import           Data.Aeson
+import           Data.Aeson.Types
+import           Data.FileEmbed
+import           Data.Text                      ( split
+                                                , splitOn
+                                                , strip
+                                                )
+import           Database.Persist.Sql
+import           Lib.Error
+import           Lib.Types.Emver
+import           Model
+import           Startlude
+
+ioMigrationDbVersion :: ConnectionPool -> Version -> Version -> IO ()
+ioMigrationDbVersion dbConn sourceVersion targetVersion = do
+    putStrLn @Text $ "Executing migrations from " <> show sourceVersion <> " to " <> show targetVersion
+    runSqlPool (migrateDbVersions sourceVersion targetVersion & handleS9ErrNuclear) dbConn
+
+getCurrentDbVersion :: MonadIO m => ReaderT SqlBackend m (Maybe Version)
+getCurrentDbVersion =
+    fmap (executedMigrationTgtVersion . entityVal) <$> selectFirst [] [Desc ExecutedMigrationCreatedAt]
+
+getMigrations :: [MigrationFile]
+getMigrations = mapMaybe toMigrationFile $(embedDir "./migrations")
+
+migrateDbVersions :: MonadIO m => Version -> Version -> S9ErrT (ReaderT SqlBackend m) ()
+migrateDbVersions sourceVersion targetVersion = case mkMigrationCollection sourceVersion targetVersion getMigrations of
+    Just (MigrationCollection migrations) -> lift $ traverse executeMigration migrations $> ()
+    Nothing ->
+        throwE . PersistentE $ "No path of migrations from " <> show sourceVersion <> " to " <> show targetVersion
+
+executeMigration :: MonadIO m => MigrationFile -> ReaderT SqlBackend m ()
+executeMigration mf = migrateSql mf >> insertMigration mf $> ()
+
+insertMigration :: MonadIO m => MigrationFile -> ReaderT SqlBackend m (Key ExecutedMigration)
+insertMigration (MigrationFile source target _) = do
+    now <- liftIO getCurrentTime
+    fmap entityKey . insertEntity $ ExecutedMigration now now source target
+
+migrateSql :: MonadIO m => MigrationFile -> ReaderT SqlBackend m ()
+migrateSql MigrationFile { sqlContent } = do
+    print sqlContent'
+    traverse_ runIt sqlContent'
+    where
+        runIt       = liftA2 (*>) (liftIO . putStrLn) $ flip (rawSql @(Single Int)) [] . (<> ";") . strip
+        sqlContent' = filter (/= "") . fmap strip . split (== ';') $ decodeUtf8 sqlContent
+
+toMigrationFile :: (FilePath, ByteString) -> Maybe MigrationFile
+toMigrationFile (fp, bs) = case splitOn "::" (toS fp) of
+    [source, target] -> do
+        sourceVersion <- parseMaybe parseJSON $ String source
+        targetVersion <- parseMaybe parseJSON $ String target
+        let sqlContent = bs
+        pure MigrationFile { .. }
+    _ -> Nothing
+
+newtype MigrationCollection = MigrationCollection { unMigrations :: [MigrationFile] } deriving (Eq, Show)
+mkMigrationCollection :: Version -> Version -> [MigrationFile] -> Maybe MigrationCollection
+mkMigrationCollection source target migrations
+    | null migrations
+    = Nothing
+    | source == target
+    = Just $ MigrationCollection []
+    | otherwise
+    = let mNext = maximumByMay targetVersion $ filter
+              (\m -> sourceVersion m == source && targetVersion m > source && targetVersion m <= target)
+              migrations
+      in  case mNext of
+              Nothing -> Nothing
+              Just nextMig ->
+                  MigrationCollection
+                      .   (nextMig :)
+                      .   unMigrations
+                      <$> mkMigrationCollection (targetVersion nextMig) target migrations
+    where
+        maximumByMay :: (Foldable t, Ord b) => (a -> b) -> t a -> Maybe a
+        maximumByMay f as =
+            let reducer x acc = case acc of
+                    Nothing -> Just x
+                    Just y  -> if f x > f y then Just x else Just y
+            in  foldr reducer Nothing as
+
+data MigrationFile = MigrationFile
+    { sourceVersion :: Version
+    , targetVersion :: Version
+    , sqlContent    :: ByteString
+    }
+    deriving (Eq, Show)

agent/src/Lib/Notifications.hs

@@ -0,0 +1,109 @@
+{-# LANGUAGE GADTs           #-}
+{-# LANGUAGE QuasiQuotes     #-}
+{-# LANGUAGE RecordWildCards #-}
+module Lib.Notifications where
+
+import           Startlude               hiding ( get )
+
+import           Data.String.Interpolate.IsString
+import           Data.UUID.V4
+import           Database.Persist
+import           Database.Persist.Sql
+
+import           Lib.Error
+import           Lib.Types.Core
+import           Lib.Types.Emver
+import           Model
+
+emit :: MonadIO m => AppId -> Version -> AgentNotification -> SqlPersistT m (Entity Notification)
+emit appId version ty = do
+    uuid <- liftIO nextRandom
+    now  <- liftIO getCurrentTime
+    let k = (NotificationKey uuid)
+    let v = (Notification now Nothing appId version (toCode ty) (toTitle ty) (toMessage appId version ty))
+    insertKey k v
+    putStrLn $ toMessage appId version ty
+    pure $ Entity k v
+
+archive :: MonadIO m => [Key Notification] -> SqlPersistT m [Entity Notification]
+archive eventIds = do
+    now    <- liftIO getCurrentTime
+    events <- for eventIds $ flip updateGet [NotificationArchivedAt =. Just now]
+    pure $ zipWith Entity eventIds events
+
+data AgentNotification =
+      InstallSuccess
+    | InstallFailedGetApp
+    | InstallFailedAppMgrExitCode Int
+    | InstallFailedS9Error S9Error
+    | BackupSucceeded
+    | BackupFailed S9Error
+    | RestoreSucceeded
+    | RestoreFailed S9Error
+    | RestartFailed S9Error
+    | DockerFuckening
+
+-- CODES
+-- RULES:
+-- The first digit indicates the call to action and the tone of the error code as follows
+-- 0: General Information, No Action Required, Neutral Tone
+-- 1: Success Message, No Action Required, Positive Tone
+-- 2: Warning, Action Possible but NOT Required, Negative Tone
+-- 3: Error, Action Required, Negative Tone
+--
+-- The second digit indicates where the error was originated from as follows
+-- 0: Originates from Agent
+-- 1: Originates from App (Not presently used)
+--
+-- The remaining section of the code may be as long as you want but must be at least one digit
+-- EXAMPLES:
+-- 100
+-- |||> Code "0"
+-- ||> Originates from Agent
+-- |> Success Message
+--
+-- 213
+-- |||> Code "3"
+-- ||> Originates from App
+-- |> Warning Message
+--
+toCode :: AgentNotification -> Text
+toCode InstallSuccess                  = "100"
+toCode BackupSucceeded                 = "101"
+toCode RestoreSucceeded                = "102"
+toCode InstallFailedGetApp             = "300"
+toCode (InstallFailedAppMgrExitCode _) = "301"
+toCode DockerFuckening                 = "302"
+toCode (InstallFailedS9Error _)        = "303"
+toCode (BackupFailed         _)        = "304"
+toCode (RestoreFailed        _)        = "305"
+toCode (RestartFailed        _)        = "306"
+
+toTitle :: AgentNotification -> Text
+toTitle InstallSuccess                  = "Install succeeded"
+toTitle BackupSucceeded                 = "Backup succeeded"
+toTitle RestoreSucceeded                = "Restore succeeded"
+toTitle InstallFailedGetApp             = "Install failed"
+toTitle (InstallFailedAppMgrExitCode _) = "Install failed"
+toTitle (InstallFailedS9Error        _) = "Install failed"
+toTitle (BackupFailed                _) = "Backup failed"
+toTitle (RestoreFailed               _) = "Restore failed"
+toTitle (RestartFailed               _) = "Restart failed"
+toTitle DockerFuckening                 = "App unstoppable"
+
+toMessage :: AppId -> Version -> AgentNotification -> Text
+toMessage appId version InstallSuccess = [i|Successfully installed #{appId} at version #{version}|]
+toMessage appId version n@InstallFailedGetApp =
+    [i|Failed to install #{appId} at version #{version}, this should be impossible, contact support and give them the code #{toCode n}|]
+toMessage appId version n@(InstallFailedAppMgrExitCode ec)
+    = [i|Failed to install #{appId} at version #{version}, many things could cause this, contact support and give them the code #{toCode n}.#{ec}|]
+toMessage appId version n@(InstallFailedS9Error e)
+    = [i|Failed to install #{appId} at version #{version}, the dependency reverse index could not be updated, contact support and give them the code #{toCode n}.#{errorCode $ toError e}|]
+toMessage appId _version DockerFuckening
+    = [i|Despite attempting to stop #{appId}, it is still running. This is a known issue that can only be solved by restarting the server|]
+toMessage appId _version BackupSucceeded        = [i|Successfully backed up #{appId}|]
+toMessage appId _version RestoreSucceeded       = [i|Successfully restored #{appId}|]
+toMessage appId _version (BackupFailed  reason) = [i|Failed to back up #{appId}: #{errorMessage $ toError reason}|]
+toMessage appId _version (RestoreFailed reason) = [i|Failed to restore #{appId}: #{errorMessage $ toError reason}|]
+toMessage appId _version (RestartFailed reason) =
+    [i|Failed to restart #{appId}: #{errorMessage $ toError reason}. Please manually restart|]

agent/src/Lib/Password.hs

@@ -0,0 +1,77 @@
+module Lib.Password where
+
+import           Startlude
+import           Yesod.Auth.Util.PasswordStore  ( makePassword
+                                                , verifyPassword
+                                                , passwordStrength
+                                                )
+import qualified Data.ByteString.Char8         as BS
+                                                ( pack
+                                                , unpack
+                                                )
+import           Data.Text                      ( pack
+                                                , unpack
+                                                )
+
+import           Model
+
+-- Root account identifier
+rootAccountName :: Text
+rootAccountName = "embassy-root"
+
+
+-- | Default strength used for passwords (see "Yesod.Auth.Util.PasswordStore"
+--   for details).
+defaultStrength :: Int
+defaultStrength = 17
+
+-- | The type representing account information stored in the database should
+--   be an instance of this class.  It just provides the getter and setter
+--   used by the functions in this module.
+class HasPasswordHash account where
+    getPasswordHash :: account -> Text
+    setPasswordHash :: Text -> account -> account
+
+    {-# MINIMAL getPasswordHash, setPasswordHash #-}
+
+
+-- | Calculate a new-style password hash using "Yesod.Auth.Util.PasswordStore".
+passwordHash :: MonadIO m => Int -> Text -> m Text
+passwordHash strength pwd = do
+    h <- liftIO $ makePassword (BS.pack $ unpack pwd) strength
+    return $ pack $ BS.unpack h
+
+-- | Set password for account, using the given strength setting. Use this
+--   function, or 'setPassword', to produce a account record containing the
+--   hashed password.  Unlike previous versions of this module, no separate
+--   salt field is required for new passwords (but it may still be required
+--   for compatibility while old password hashes remain in the database).
+--
+--   This function does not change the database; the calling application
+--   is responsible for saving the data which is returned.
+setPasswordStrength :: (MonadIO m, HasPasswordHash account) => Int -> Text -> account -> m account
+setPasswordStrength strength pwd u = do
+    hashed <- passwordHash strength pwd
+    return $ setPasswordHash hashed u
+
+-- | As 'setPasswordStrength', but using the 'defaultStrength'
+setPassword :: (MonadIO m, HasPasswordHash account) => Text -> account -> m account
+setPassword = setPasswordStrength defaultStrength
+
+validatePass :: HasPasswordHash u => u -> Text -> Bool
+validatePass account password = do
+    let h = getPasswordHash account
+    -- NB plaintext password characters are truncated to 8 bits here,
+    -- and also in passwordHash above (the hash is already 8 bit).
+    -- This is for historical compatibility, but in practice it is
+    -- unlikely to reduce the entropy of most users' alphabets by much.
+    let hash'     = BS.pack $ unpack h
+        password' = BS.pack $ unpack password
+    if passwordStrength hash' > 0
+        -- Will give >0 for valid hash format, else treat as if wrong password
+        then verifyPassword password' hash'
+        else False
+
+instance HasPasswordHash Account where
+    getPasswordHash = accountPassword
+    setPasswordHash h u = u { accountPassword = h }

agent/src/Lib/ProductKey.hs

@@ -0,0 +1,12 @@
+module Lib.ProductKey where
+
+import           Startlude
+import           Protolude.Unsafe               ( unsafeHead )
+
+import           System.FilePath
+
+productKeyPath :: FilePath -> FilePath
+productKeyPath rt = rt </> "root/agent/product_key"
+
+getProductKey :: Text -> IO Text
+getProductKey rt = unsafeHead . lines <$> readFile (productKeyPath $ toS rt)

agent/src/Lib/SelfUpdate.hs

@@ -0,0 +1,226 @@
+{-# LANGUAGE QuasiQuotes         #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE TupleSections       #-}
+module Lib.SelfUpdate where
+
+import           Startlude               hiding ( runReader )
+
+import           Control.Carrier.Error.Either
+import           Control.Lens
+import           Data.Aeson
+import qualified Data.ByteString.Char8         as B8
+import           Data.IORef
+import           Data.List
+import           Data.String.Interpolate.IsString
+import           System.Posix.Files
+import           System.Process
+
+import           Constants
+import           Foundation
+import           Handler.Types.V0.Base
+import           Lib.Algebra.State.RegistryUrl
+import           Lib.Error
+import           Lib.External.Registry
+import           Lib.Sound                     as Sound
+import           Lib.Synchronizers
+import           Lib.SystemPaths
+import           Lib.Types.Emver
+import           Lib.WebServer
+import           Settings
+
+youngAgentPort :: Word16
+youngAgentPort = 5960
+
+waitForUpdateSignal :: AgentCtx -> IO ()
+waitForUpdateSignal foundation = do
+    eNewVersion <- runS9ErrT $ do
+        spec <- lift . takeMVar . appSelfUpdateSpecification $ foundation
+        let settings = appSettings foundation
+        v <- interp settings (getLatestAgentVersionForSpec spec) >>= \case
+            Nothing -> throwE $ UpdateSelfE GetLatestCompliantVersion "Not Found"
+            Just v  -> pure v
+        liftIO $ writeIORef (appIsUpdating foundation) (Just v)
+        updateAgent foundation spec
+    case eNewVersion of
+        Right (newVersion, youngAgentProcess) -> do
+            putStrLn @Text $ "New agent up and running: " <> show newVersion
+            runReaderT replaceExecutableWithYoungAgent (appSettings foundation)
+            killYoungAgent youngAgentProcess
+            shutdownAll []
+        Left e@(UpdateSelfE GetYoungAgentBinary _) -> do
+            logerror e
+            writeIORef (appIsUpdating foundation) Nothing
+            waitForNextUpdateSignal
+        Left e@(UpdateSelfE ShutdownWeb _) -> do
+            logerror e
+            writeIORef (appIsUpdating foundation) Nothing
+            waitForNextUpdateSignal
+        Left e@(UpdateSelfE StartupYoungAgent _) -> do
+            logerror e
+            writeIORef (appIsUpdating foundation) Nothing
+            waitForNextUpdateSignal
+        Left e@(UpdateSelfE (PingYoungAgent youngAgentProcess) _) -> do
+            logerror e
+            killYoungAgent youngAgentProcess
+            writeIORef (appIsUpdating foundation) Nothing
+            waitForNextUpdateSignal
+        Left e -> do -- unreachable
+            logerror e
+            waitForNextUpdateSignal
+    where
+        waitForNextUpdateSignal = waitForUpdateSignal foundation
+        logerror                = putStrLn @Text . show
+        interp s = ExceptT . liftIO . runError . injectFilesystemBaseFromContext s . runRegistryUrlIOC
+
+
+updateAgent :: AgentCtx -> VersionRange -> S9ErrT IO (Version, ProcessHandle)
+updateAgent foundation avs = do
+    -- get and save the binary of the new agent app
+    putStrLn @Text $ "Acquiring young agent binary for specification: " <> show avs
+    (tryTo . interp settings . getYoungAgentBinary $ avs) >>= \case
+        Left  e -> throwE $ UpdateSelfE GetYoungAgentBinary (show e)
+        Right _ -> putStrLn @Text "Succeeded"
+
+    -- start the new agent app. This is non blocking as a success would block indefinitely
+    startupYoungAgentProcessHandle <- startup 5
+
+    putStrLn @Text $ "Beginning young agent ping attempts..."
+    let attemptPing = do
+            lift (threadDelay delayBetweenAttempts)
+            tryTo pingYoungAgent >>= \case
+                Left e -> do
+                    putStrLn @Text (show e)
+                    pure (Left e)
+                x -> pure x
+    retryAction attempts attemptPing >>= \case
+        Left  e  -> throwE $ UpdateSelfE (PingYoungAgent startupYoungAgentProcessHandle) (show e)
+        Right av -> putStrLn @Text "Succeeded" >> pure (av, startupYoungAgentProcessHandle)
+    where
+        tryTo                = lift . try @SomeException
+        settings             = appSettings foundation
+        attempts             = 8
+        delayBetweenAttempts = 5 * 1000000 :: Int -- 5 seconds
+        startup :: Int -> S9ErrT IO ProcessHandle
+        startup startupAttempts = do
+            putStrLn @Text $ "Starting up young agent..."
+            tryTo (runReaderT startupYoungAgent $ appSettings foundation) >>= \case
+                Left e -> if "busy" `isInfixOf` show e && startupAttempts > 0-- sometimes the file handle hasn't closed yet
+                    then do
+                        putStrLn @Text "agent-tmp busy, reattempting in 500ms"
+                        liftIO (threadDelay 500_000)
+                        startup (startupAttempts - 1)
+                    else do
+                        putStrLn @Text (show e)
+                        throwE $ UpdateSelfE StartupYoungAgent (show e)
+                Right ph -> putStrLn @Text "Succeeded" >> pure ph
+        interp s = liftIO . injectFilesystemBaseFromContext s . injectFilesystemBaseFromContext s . runRegistryUrlIOC
+
+
+
+retryAction :: Monad m => Integer -> m (Either e a) -> m (Either e a)
+retryAction 1        action = action
+retryAction maxTries action = do
+    success <- action
+    case success of
+        Right a -> pure $ Right a
+        Left  _ -> retryAction (maxTries - 1) action
+
+replaceExecutableWithYoungAgent :: (MonadReader AppSettings m, MonadIO m) => m ()
+replaceExecutableWithYoungAgent = do
+    rt <- asks appFilesystemBase
+    let tmpAgent = (executablePath `relativeTo` rt) </> tmpAgentFileName
+    let agent    = (executablePath `relativeTo` rt) </> agentFileName
+
+    liftIO $ removeLink (toS agent)
+    liftIO $ rename (toS tmpAgent) (toS agent)
+
+
+-- We assume that all app versions must listen on the same port.
+youngAgentUrl :: Text
+youngAgentUrl = "http://localhost:" <> show youngAgentPort
+
+pingYoungAgent :: IO Version
+pingYoungAgent = do
+    (code, st_out, st_err) <- readProcessWithExitCode "curl" [toS $ toS youngAgentUrl </> "version"] ""
+    putStrLn st_out
+    putStrLn st_err
+    case code of
+        ExitSuccess -> case decodeStrict $ B8.pack st_out of
+            Nothing                 -> throwIO . InternalS9Error $ "unparseable version: " <> toS st_out
+            Just (AppVersionRes av) -> pure av
+        ExitFailure e -> throwIO . InternalS9Error $ "curl failure with exit code: " <> show e
+
+startupYoungAgent :: (MonadReader AppSettings m, MonadIO m) => m ProcessHandle
+startupYoungAgent = do
+    rt <- asks appFilesystemBase
+    let cmd = (proc (toS $ (executablePath `relativeTo` rt) </> tmpAgentFileName) ["--port", show youngAgentPort])
+            { create_group = True
+            }
+    ph <- liftIO $ view _4 <$> createProcess cmd
+    liftIO $ threadDelay 1_000_000 -- 1 second
+    liftIO $ getProcessExitCode ph >>= \case
+        Nothing -> pure ph
+        Just e  -> throwIO . InternalS9Error $ "young agent exited prematurely with exit code: " <> show e
+
+killYoungAgent :: ProcessHandle -> IO ()
+killYoungAgent p = do
+    mEC <- getProcessExitCode p
+    case mEC of
+        Nothing -> interruptProcessGroupOf p
+        Just _  -> pure ()
+    threadDelay appEndEstimate
+    where appEndEstimate = 10 * 1000000 :: Int --10 seconds
+
+runSyncOps :: [SyncOp] -> ReaderT AgentCtx IO [(Bool, Bool)]
+runSyncOps syncOps = do
+    ctx <- ask
+    let setUpdate b = if b
+            then liftIO $ writeIORef (appIsUpdating ctx) (Just agentVersion)
+            else liftIO $ writeIORef (appIsUpdating ctx) Nothing
+    res <- for syncOps $ \syncOp -> do
+        shouldRun <- syncOpShouldRun syncOp
+        putStrLn @Text [i|Sync Op "#{syncOpName syncOp}" should run: #{shouldRun}|]
+        when shouldRun $ do
+            putStrLn @Text [i|Running Sync Op: #{syncOpName syncOp}|]
+            setUpdate True
+            syncOpRun syncOp
+        pure $ (syncOpRequiresReboot syncOp, shouldRun)
+    setUpdate False
+    pure res
+
+synchronizeSystemState :: AgentCtx -> Version -> IO ()
+synchronizeSystemState ctx _version = handle @SomeException cleanup $ flip runReaderT ctx $ do
+    (restartsAndRuns, mTid) <- case synchronizer of
+        Synchronizer { synchronizerOperations } -> flip runStateT Nothing $ for synchronizerOperations $ \syncOp -> do
+            shouldRun <- lift $ syncOpShouldRun syncOp
+            putStrLn @Text [i|Sync Op "#{syncOpName syncOp}" should run: #{shouldRun}|]
+            when shouldRun $ do
+                whenM (isNothing <$> get) $ do
+                    tid <- liftIO . forkIO . forever $ playSong 300 updateInProgress *> threadDelay 20_000_000
+                    put (Just tid)
+                putStrLn @Text [i|Running Sync Op: #{syncOpName syncOp}|]
+                setUpdate True
+                lift $ syncOpRun syncOp
+            pure $ (syncOpRequiresReboot syncOp, shouldRun)
+    case mTid of
+        Nothing  -> pure ()
+        Just tid -> liftIO $ killThread tid
+    setUpdate False
+    when (any snd restartsAndRuns) $ liftIO $ playSong 400 marioPowerUp
+    when (any (uncurry (&&)) restartsAndRuns) $ liftIO do
+        callCommand "/bin/sync"
+        callCommand "/sbin/reboot"
+    where
+        setUpdate :: MonadIO m => Bool -> m ()
+        setUpdate b = if b
+            then liftIO $ writeIORef (appIsUpdating ctx) (Just agentVersion)
+            else liftIO $ writeIORef (appIsUpdating ctx) Nothing
+        cleanup :: SomeException -> IO ()
+        cleanup e = do
+            void $ try @SomeException Sound.stop
+            void $ try @SomeException Sound.unexport
+            let e' = InternalE $ show e
+            flip runReaderT ctx $ cantFail $ failUpdate e'
+

agent/src/Lib/Sound.hs

@@ -0,0 +1,248 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections       #-}
+module Lib.Sound where
+
+import           Startlude               hiding ( rotate )
+
+import           Control.Monad.Trans.Cont
+import           Control.Carrier.Writer.Strict
+import           System.FileLock
+
+import           Util.Function
+
+-- General
+
+rotate :: forall a . (Enum a, Bounded a) => a -> Int -> a
+rotate base step = toEnum $ (fromEnum base + step) `mod` size + (fromEnum $ minBound @a)
+    where size = fromEnum (maxBound @a) - fromEnum (minBound @a) + 1
+{-# INLINE rotate #-}
+
+
+-- Interface
+
+export :: IO ()
+export = writeFile "/sys/class/pwm/pwmchip0/export" "0"
+
+unexport :: IO ()
+unexport = writeFile "/sys/class/pwm/pwmchip0/unexport" "0"
+
+
+-- Constants
+
+semitoneK :: Double
+semitoneK = 2 ** (1 / 12)
+{-# INLINE semitoneK #-}
+
+
+-- Data Types
+
+data Note = Note Semitone Word8
+    deriving (Eq, Show)
+
+data Semitone =
+      C
+    | Db
+    | D
+    | Eb
+    | E
+    | F
+    | Gb
+    | G
+    | Ab
+    | A
+    | Bb
+    | B
+    deriving (Eq, Ord, Show, Enum, Bounded)
+
+newtype Interval = Interval Int deriving newtype (Num)
+
+data TimeSlice =
+      Sixteenth
+    | Eighth
+    | Quarter
+    | Half
+    | Whole
+    | Triplet TimeSlice
+    | Dot TimeSlice
+    | Tie TimeSlice TimeSlice
+    deriving (Eq, Show)
+
+
+-- Theory Manipulation
+
+interval :: Interval -> Note -> Note
+interval (Interval n) (Note step octave) =
+    let (o', s') = n `quotRem` 12
+        newStep  = step `rotate` s'
+        offset   = if
+            | newStep > step && s' < 0 -> subtract 1
+            | newStep < step && s' > 0 -> (+ 1)
+            | otherwise                -> id
+    in  Note newStep (offset $ octave + fromIntegral o')
+{-# INLINE interval #-}
+
+minorThird :: Interval
+minorThird = Interval 3
+
+majorThird :: Interval
+majorThird = Interval 3
+
+fourth :: Interval
+fourth = Interval 5
+
+fifth :: Interval
+fifth = Interval 7
+
+circleOfFourths :: Note -> [Note]
+circleOfFourths = iterate (interval fourth)
+
+circleOfFifths :: Note -> [Note]
+circleOfFifths = iterate (interval fifth)
+
+-- Theory To Interface Target
+
+noteFreq :: Note -> Double
+noteFreq (Note semi oct) = semitoneK ** (fromIntegral $ fromEnum semi) * c0 * (2 ** fromIntegral oct)
+    where
+        a4 = 440
+        c0 = a4 / (semitoneK ** 9) / (2 ** 4)
+
+-- tempo is in quarters per minute
+timeSliceToMicro :: Word16 -> TimeSlice -> Int
+timeSliceToMicro tempo timeSlice = case timeSlice of
+    Sixteenth          -> uspq `div` 4
+    Eighth             -> uspq `div` 2
+    Quarter            -> uspq
+    Half               -> uspq * 2
+    Whole              -> uspq * 4
+    Triplet timeSlice' -> timeSliceToMicro tempo timeSlice' * 2 `div` 3
+    Dot     timeSlice' -> timeSliceToMicro tempo timeSlice' * 3 `div` 2
+    Tie ts1 ts2        -> timeSliceToMicro tempo ts1 + timeSliceToMicro tempo ts2
+    where uspq = floor @Double $ 60 / fromIntegral tempo * 1_000_000
+
+
+-- Player
+
+periodFile :: FilePath
+periodFile = "/sys/class/pwm/pwmchip0/pwm0/period"
+
+dutyFile :: FilePath
+dutyFile = "/sys/class/pwm/pwmchip0/pwm0/duty_cycle"
+
+switchFile :: FilePath
+switchFile = "/sys/class/pwm/pwmchip0/pwm0/enable"
+
+play :: Note -> IO ()
+play note' = do
+    prd' <- readFile periodFile
+    case prd' of
+        "0\n" -> writeFile periodFile "1000"
+        _     -> pure ()
+    let prd = round @_ @Int $ 1 / noteFreq note' * 1_000_000_000 -- pwm needs it in nanos
+    writeFile dutyFile   "0"
+    writeFile periodFile (show prd)
+    writeFile dutyFile   (show $ prd `div` 2)
+    writeFile switchFile "1"
+
+stop :: IO ()
+stop = writeFile switchFile "0"
+
+playForDuration :: Note -> Int -> IO ()
+playForDuration note' duration = handle @SomeException (\e -> stop *> throwIO e) $ do
+    play note'
+    threadDelay (floor @Double $ fromIntegral duration * 0.95)
+    stop
+    threadDelay (ceiling @Double $ fromIntegral duration * 0.05)
+
+time :: IO () -> IO (UTCTime, UTCTime)
+time action = do
+    t0 <- getCurrentTime
+    action
+    t1 <- getCurrentTime
+    pure (t0, t1)
+
+playSong :: Word16 -> Song -> IO ()
+playSong = flip runCont id .* playSong'
+{-# INLINE playSong #-}
+
+playSongTimed :: Word16 -> Song -> IO (UTCTime, UTCTime)
+playSongTimed tempo song = runCont (playSong' tempo song) time
+{-# INLINE playSongTimed #-}
+
+playSong' :: Word16 -> Song -> Cont (IO b) (IO ())
+playSong' tempo song = cont $ \f -> bracket acquire release $ \_ -> f $ do
+    for_ song $ \(n, ts) -> do
+        let duration = timeSliceToMicro tempo ts
+        case n of
+            Nothing -> threadDelay duration
+            Just x  -> playForDuration x duration
+    where
+        soundLock = "/root/agent/sound.lock"
+        acquire   = do
+            l <- lockFile soundLock Exclusive
+            export
+            pure l
+        release l = do
+            void $ try @SomeException stop
+            void $ try @SomeException unexport
+            unlockFile l
+
+
+-- Songs
+
+type Song = [(Maybe Note, TimeSlice)]
+
+marioDeath :: Song
+marioDeath =
+    [ (Just $ Note B 4, Quarter)
+    , (Just $ Note F 5, Quarter)
+    , (Nothing        , Quarter)
+    , (Just $ Note F 5, Quarter)
+    , (Just $ Note F 5, Triplet Half)
+    , (Just $ Note E 5, Triplet Half)
+    , (Just $ Note D 5, Triplet Half)
+    , (Just $ Note C 5, Quarter)
+    , (Just $ Note E 4, Quarter)
+    , (Nothing        , Quarter)
+    , (Just $ Note E 4, Quarter)
+    , (Just $ Note C 4, Half)
+    ]
+
+marioPowerUp :: Song
+marioPowerUp =
+    [ (Just $ Note G 4 , Triplet Eighth)
+    , (Just $ Note B 4 , Triplet Eighth)
+    , (Just $ Note D 5 , Triplet Eighth)
+    , (Just $ Note G 5 , Triplet Eighth)
+    , (Just $ Note B 5 , Triplet Eighth)
+    , (Just $ Note Ab 4, Triplet Eighth)
+    , (Just $ Note C 5 , Triplet Eighth)
+    , (Just $ Note Eb 5, Triplet Eighth)
+    , (Just $ Note Ab 5, Triplet Eighth)
+    , (Just $ Note C 5 , Triplet Eighth)
+    , (Just $ Note Bb 4, Triplet Eighth)
+    , (Just $ Note D 5 , Triplet Eighth)
+    , (Just $ Note F 5 , Triplet Eighth)
+    , (Just $ Note Bb 5, Triplet Eighth)
+    , (Just $ Note D 6 , Triplet Eighth)
+    ]
+
+marioCoin :: Song
+marioCoin = [(Just $ Note B 5, Eighth), (Just $ Note E 6, Tie (Dot Quarter) Half)]
+
+updateInProgress :: Song
+updateInProgress = take 6 $ (, Triplet Eighth) . Just <$> circleOfFifths (Note A 3)
+
+beethoven :: Song
+beethoven = run . execWriter $ do
+    tell $ replicate 3 (Just $ Note E 5, Eighth)
+    tell $ [(Just $ Note C 5, Half)]
+    tell $ [(Nothing @Note, Eighth)]
+    tell $ replicate 3 (Just $ Note D 5, Eighth)
+    tell $ [(Just $ Note B 5, Half)]
+
+restoreActionInProgress :: Song
+restoreActionInProgress = take 5 $ (, Triplet Eighth) . Just <$> circleOfFourths (Note C 4)
+
+backupActionInProgress :: [(Maybe Note, TimeSlice)]
+backupActionInProgress = reverse restoreActionInProgress

agent/src/Lib/Ssh.hs

@@ -0,0 +1,81 @@
+{-# LANGUAGE TupleSections #-}
+module Lib.Ssh where
+
+import           Startlude
+
+import           Control.Lens
+import           Crypto.Hash
+import           Data.Aeson
+import           Data.ByteArray          hiding ( null
+                                                , view
+                                                )
+import           Data.ByteArray.Encoding
+import           Data.ByteString.Builder
+import           Data.ByteString.Lazy           ( toStrict )
+import           Data.List                      ( partition )
+import qualified Data.Text                     as T
+import           System.Directory
+
+import           Lib.SystemPaths
+import           Settings
+
+data SshAlg = RSA | ECDSA | Ed25519 | DSA deriving (Eq, Show)
+instance ToJSON SshAlg where
+    toJSON = String . \case
+        RSA     -> "ssh-rsa"
+        ECDSA   -> "ecdsa-sha2-nistp256"
+        Ed25519 -> "ssh-ed25519"
+        DSA     -> "ssh-dss"
+
+getSshKeys :: (MonadReader AppSettings m, MonadIO m) => m [Text]
+getSshKeys = do
+    base <- asks appFilesystemBase
+    liftIO $ doesFileExist (toS $ sshKeysFilePath `relativeTo` base) >>= \case
+        False -> pure []
+        True  -> lines . T.strip <$> readFile (toS $ sshKeysFilePath `relativeTo` base)
+
+fingerprint :: Text -> Either String (SshAlg, Text, Text)
+fingerprint sshKey = do
+    (alg, b64, host) <- case T.split isSpace sshKey of
+        [alg, bin, host] -> (, encodeUtf8 bin, host) <$> parseAlg alg
+        [alg, bin]       -> (, encodeUtf8 bin, "") <$> parseAlg alg
+        _                -> Left $ "Invalid SSH Key: " <> toS sshKey
+    bin <- convertFromBase @_ @ByteString Base64 b64
+    let dig    = unpack . convert @_ @ByteString $ hashWith MD5 bin
+    let hex = fmap (byteString . convertToBase @ByteString Base16 . singleton) dig
+    let colons = intersperse (charUtf8 ':') hex
+    pure . (alg, , host) . decodeUtf8 . toStrict . toLazyByteString $ fold colons
+    where
+
+        parseAlg :: Text -> Either String SshAlg
+        parseAlg alg = case alg of
+            "ssh-rsa"             -> Right RSA
+            "ecdsa-sha2-nistp256" -> Right ECDSA
+            "ssh-ed25519"         -> Right Ed25519
+            "ssh-dss"             -> Right DSA
+            _                     -> Left $ "Invalid SSH Alg: " <> toS alg
+
+createSshKey :: (MonadReader AppSettings m, MonadIO m) => Text -> m ()
+createSshKey key = do
+    base <- asks appFilesystemBase
+    let writeFirstKeyToFile k = writeFile (toS $ sshKeysFilePath `relativeTo` base) (k <> "\n")
+    liftIO $ doesFileExist (toS $ sshKeysFilePath `relativeTo` base) >>= \case
+        False -> writeFirstKeyToFile sanitizedKey
+        True  -> addKeyToFile (toS $ sshKeysFilePath `relativeTo` base) sanitizedKey
+    where sanitizedKey = T.strip key
+
+addKeyToFile :: FilePath -> Text -> IO ()
+addKeyToFile path k = do
+    oldKeys <- filter (not . T.null) . lines <$> readFile path
+    writeFile path $ unlines (k : oldKeys)
+
+-- true if key deleted, false if key did not exist
+deleteSshKey :: (MonadReader AppSettings m, MonadIO m) => Text -> m Bool
+deleteSshKey fp = do
+    base <- asks appFilesystemBase
+    let rewriteFile others = liftIO $ writeFile (toS $ sshKeysFilePath `relativeTo` base) $ unlines others
+    getSshKeys >>= \case
+        []   -> pure False
+        keys -> do
+            let (existed, others) = partition ((Right fp ==) . fmap (view _2) . fingerprint) keys
+            if null existed then pure False else rewriteFile others >> pure True

agent/src/Lib/Ssl.hs

@@ -0,0 +1,355 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE QuasiQuotes #-}
+module Lib.Ssl where
+
+import           Startlude
+
+import           Control.Lens
+import           Data.String.Interpolate.IsString
+import           System.Process
+
+root_CA_CERT_NAME :: Text
+root_CA_CERT_NAME = "Embassy Local Root CA"
+
+root_CA_OPENSSL_CONF :: FilePath -> ByteString
+root_CA_OPENSSL_CONF path = [i|
+# OpenSSL root CA configuration file.
+# Copy to `/root/ca/openssl.cnf`.
+
+[ ca ]
+# `man ca`
+default_ca = CA_default
+
+[ CA_default ]
+# Directory and file locations.
+dir               = #{path}
+certs             = $dir/certs
+crl_dir           = $dir/crl
+new_certs_dir     = $dir/newcerts
+database          = $dir/index.txt
+serial            = $dir/serial
+RANDFILE          = $dir/private/.rand
+
+# The root key and root certificate.
+private_key       = $dir/private/ca.key.pem
+certificate       = $dir/certs/ca.cert.pem
+
+# For certificate revocation lists.
+crlnumber         = $dir/crlnumber
+crl               = $dir/crl/ca.crl.pem
+crl_extensions    = crl_ext
+default_crl_days  = 30
+
+# SHA-1 is deprecated, so use SHA-2 instead.
+default_md        = sha256
+
+name_opt          = ca_default
+cert_opt          = ca_default
+default_days      = 375
+preserve          = no
+policy            = policy_loose
+
+[ policy_loose ]
+# Allow the intermediate CA to sign a more diverse range of certificates.
+# See the POLICY FORMAT section of the `ca` man page.
+countryName             = optional
+stateOrProvinceName     = optional
+localityName            = optional
+organizationName        = optional
+organizationalUnitName  = optional
+commonName              = supplied
+emailAddress            = optional
+
+[ req ]
+# Options for the `req` tool (`man req`).
+default_bits        = 4096
+distinguished_name  = req_distinguished_name
+string_mask         = utf8only
+prompt              = no
+
+# SHA-1 is deprecated, so use SHA-2 instead.
+default_md          = sha256
+
+# Extension to add when the -x509 option is used.
+x509_extensions     = v3_ca
+
+[ req_distinguished_name ]
+# See <https://en.wikipedia.org/wiki/Certificate_signing_request>.
+CN = #{root_CA_CERT_NAME}
+O = Start9 Labs
+OU = Embassy
+
+[ v3_ca ]
+# Extensions for a typical CA (`man x509v3_config`).
+subjectKeyIdentifier = hash
+authorityKeyIdentifier = keyid:always,issuer
+basicConstraints = critical, CA:true
+keyUsage = critical, digitalSignature, cRLSign, keyCertSign
+
+[ v3_intermediate_ca ]
+# Extensions for a typical intermediate CA (`man x509v3_config`).
+subjectKeyIdentifier = hash
+authorityKeyIdentifier = keyid:always,issuer
+basicConstraints = critical, CA:true, pathlen:0
+keyUsage = critical, digitalSignature, cRLSign, keyCertSign
+
+[ usr_cert ]
+# Extensions for client certificates (`man x509v3_config`).
+basicConstraints = CA:FALSE
+nsCertType = client, email
+nsComment = "OpenSSL Generated Client Certificate"
+subjectKeyIdentifier = hash
+authorityKeyIdentifier = keyid,issuer
+keyUsage = critical, nonRepudiation, digitalSignature, keyEncipherment
+extendedKeyUsage = clientAuth, emailProtection
+
+[ server_cert ]
+# Extensions for server certificates (`man x509v3_config`).
+basicConstraints = CA:FALSE
+nsCertType = server
+nsComment = "OpenSSL Generated Server Certificate"
+subjectKeyIdentifier = hash
+authorityKeyIdentifier = keyid,issuer:always
+keyUsage = critical, digitalSignature, keyEncipherment
+extendedKeyUsage = serverAuth
+
+[ crl_ext ]
+# Extension for CRLs (`man x509v3_config`).
+authorityKeyIdentifier=keyid:always
+
+[ ocsp ]
+# Extension for OCSP signing certificates (`man ocsp`).
+basicConstraints = CA:FALSE
+subjectKeyIdentifier = hash
+authorityKeyIdentifier = keyid,issuer
+keyUsage = critical, digitalSignature
+extendedKeyUsage = critical, OCSPSigning
+|]
+
+intermediate_CA_OPENSSL_CONF :: Text -> ByteString
+intermediate_CA_OPENSSL_CONF path = [i|
+# OpenSSL intermediate CA configuration file.
+# Copy to `/root/ca/intermediate/openssl.cnf`.
+
+[ ca ]
+# `man ca`
+default_ca = CA_default
+
+[ CA_default ]
+# Directory and file locations.
+dir               = #{path}
+certs             = $dir/certs
+crl_dir           = $dir/crl
+new_certs_dir     = $dir/newcerts
+database          = $dir/index.txt
+serial            = $dir/serial
+RANDFILE          = $dir/private/.rand
+
+# The root key and root certificate.
+private_key       = $dir/private/intermediate.key.pem
+certificate       = $dir/certs/intermediate.cert.pem
+
+# For certificate revocation lists.
+crlnumber         = $dir/crlnumber
+crl               = $dir/crl/intermediate.crl.pem
+crl_extensions    = crl_ext
+default_crl_days  = 30
+
+# SHA-1 is deprecated, so use SHA-2 instead.
+default_md        = sha256
+
+name_opt          = ca_default
+cert_opt          = ca_default
+default_days      = 375
+preserve          = no
+copy_extensions   = copy
+policy            = policy_loose
+
+
+[ policy_loose ]
+# Allow the intermediate CA to sign a more diverse range of certificates.
+# See the POLICY FORMAT section of the `ca` man page.
+countryName             = optional
+stateOrProvinceName     = optional
+localityName            = optional
+organizationName        = optional
+organizationalUnitName  = optional
+commonName              = supplied
+emailAddress            = optional
+
+[ req ]
+# Options for the `req` tool (`man req`).
+default_bits        = 4096
+distinguished_name  = req_distinguished_name
+string_mask         = utf8only
+prompt              = no
+
+# SHA-1 is deprecated, so use SHA-2 instead.
+default_md          = sha256
+
+# Extension to add when the -x509 option is used.
+x509_extensions     = v3_ca
+
+[ req_distinguished_name ]
+CN = Embassy Local Intermediate CA
+O = Start9 Labs
+OU = Embassy
+
+[ v3_ca ]
+# Extensions for a typical CA (`man x509v3_config`).
+subjectKeyIdentifier = hash
+authorityKeyIdentifier = keyid:always,issuer
+basicConstraints = critical, CA:true
+keyUsage = critical, digitalSignature, cRLSign, keyCertSign
+
+[ v3_intermediate_ca ]
+# Extensions for a typical intermediate CA (`man x509v3_config`).
+subjectKeyIdentifier = hash
+authorityKeyIdentifier = keyid:always,issuer
+basicConstraints = critical, CA:true, pathlen:0
+keyUsage = critical, digitalSignature, cRLSign, keyCertSign
+
+[ usr_cert ]
+# Extensions for client certificates (`man x509v3_config`).
+basicConstraints = CA:FALSE
+nsCertType = client, email
+nsComment = "OpenSSL Generated Client Certificate"
+subjectKeyIdentifier = hash
+authorityKeyIdentifier = keyid,issuer
+keyUsage = critical, nonRepudiation, digitalSignature, keyEncipherment
+extendedKeyUsage = clientAuth, emailProtection
+
+[ server_cert ]
+# Extensions for server certificates (`man x509v3_config`).
+basicConstraints = CA:FALSE
+nsCertType = server
+nsComment = "OpenSSL Generated Server Certificate"
+subjectKeyIdentifier = hash
+authorityKeyIdentifier = keyid,issuer:always
+keyUsage = critical, digitalSignature, keyEncipherment
+extendedKeyUsage = serverAuth
+
+[ crl_ext ]
+# Extension for CRLs (`man x509v3_config`).
+authorityKeyIdentifier=keyid:always
+
+[ ocsp ]
+# Extension for OCSP signing certificates (`man ocsp`).
+basicConstraints = CA:FALSE
+subjectKeyIdentifier = hash
+authorityKeyIdentifier = keyid,issuer
+keyUsage = critical, digitalSignature
+extendedKeyUsage = critical, OCSPSigning
+|]
+
+domain_CSR_CONF :: Text -> ByteString
+domain_CSR_CONF name = [i|
+[req]
+default_bits = 4096
+default_md = sha256
+distinguished_name = req_distinguished_name
+prompt = no
+
+[req_distinguished_name]
+CN = #{name}
+O = Start9 Labs
+OU = Embassy
+|]
+
+writeRootCaCert :: MonadIO m => FilePath -> FilePath -> FilePath -> m (ExitCode, String, String)
+writeRootCaCert confPath keyFilePath certFileDestinationPath = liftIO $ readProcessWithExitCode
+    "openssl"
+    [ "req"
+    , -- use x509
+      "-new"
+    , -- new request
+      "-x509"
+    , -- self signed x509
+      "-nodes"
+    , -- no passphrase
+      "-days"
+    , -- expires in...
+      "3650"
+    , -- valid for 10 years. Max is 20 years
+      "-key"
+    , -- source private key
+      toS keyFilePath
+    , "-out"
+    -- target cert path
+    , toS certFileDestinationPath
+    , "-config"
+      -- configured by...
+    , toS confPath
+    ]
+    ""
+
+data DeriveCertificate = DeriveCertificate
+    { applicantConfPath :: FilePath
+    , applicantKeyPath  :: FilePath
+    , applicantCertPath :: FilePath
+    , signingConfPath   :: FilePath
+    , signingKeyPath    :: FilePath
+    , signingCertPath   :: FilePath
+    , duration          :: Integer
+    }
+writeIntermediateCert :: MonadIO m => DeriveCertificate -> m (ExitCode, String, String)
+writeIntermediateCert DeriveCertificate {..} = liftIO $ interpret $ do
+    -- openssl genrsa -out dump/int.key 4096
+    segment $ openssl [i|genrsa -out #{applicantKeyPath} 4096|]
+    -- openssl req -new -config dump/int-csr.conf -key dump/int.key -nodes -out dump/int.csr
+    segment $ openssl [i|req -new
+                             -config #{applicantConfPath}
+                             -key #{applicantKeyPath}
+                             -nodes
+                             -out #{applicantCertPath <> ".csr"}|]
+    -- openssl x509 -CA dump/ca.crt -CAkey dump/ca.key -CAcreateserial -days 3650 -req -in dump/int.csr -out dump/int.crt
+    segment $ openssl [i|ca -batch
+                            -config #{signingConfPath}
+                            -rand_serial
+                            -keyfile #{signingKeyPath}
+                            -cert #{signingCertPath}
+                            -extensions v3_intermediate_ca
+                            -days #{duration}
+                            -notext
+                            -in #{applicantCertPath <> ".csr"}
+                            -out #{applicantCertPath}|]
+    liftIO $ readFile signingCertPath >>= appendFile applicantCertPath
+
+writeLeafCert :: MonadIO m => DeriveCertificate -> Text -> Text -> m (ExitCode, String, String)
+writeLeafCert DeriveCertificate {..} hostname torAddress = liftIO $ interpret $ do
+    segment $ openssl [i|genrsa -out #{applicantKeyPath} 4096|]
+    segment $ openssl [i|req -config #{applicantConfPath}
+                             -key #{applicantKeyPath}
+                             -new
+                             -addext subjectAltName=DNS:#{hostname},DNS:*.#{hostname},DNS:#{torAddress},DNS:*.#{torAddress}
+                             -out #{applicantCertPath <> ".csr"}|]
+    segment $ openssl [i|ca -batch
+                            -config #{signingConfPath}
+                            -rand_serial
+                            -keyfile #{signingKeyPath}
+                            -cert #{signingCertPath}
+                            -extensions server_cert
+                            -days #{duration}
+                            -notext
+                            -in #{applicantCertPath <> ".csr"}
+                            -out #{applicantCertPath}
+                            |]
+    liftIO $ readFile signingCertPath >>= appendFile applicantCertPath
+
+openssl :: Text -> IO (ExitCode, String, String)
+openssl = ($ "") . readProcessWithExitCode "openssl" . fmap toS . words
+{-# INLINE openssl #-}
+
+interpret :: ExceptT ExitCode (StateT (String, String) IO) () -> IO (ExitCode, String, String)
+interpret = fmap (over _1 (either id (const ExitSuccess)) . regroup) . flip runStateT ("", "") . runExceptT
+{-# INLINE interpret #-}
+
+regroup :: (a, (b, c)) -> (a, b, c)
+regroup (a, (b, c)) = (a, b, c)
+{-# INLINE regroup #-}
+
+segment :: IO (ExitCode, String, String) -> ExceptT ExitCode (StateT (String, String) IO) ()
+segment action = liftIO action >>= \case
+    (ExitSuccess, o, e) -> modify (bimap (<> o) (<> e))
+    (ec         , o, e) -> modify (bimap (<> o) (<> e)) *> throwE ec
+{-# INLINE segment #-}

agent/src/Lib/Synchronizers.hs

@@ -0,0 +1,437 @@
+{-# OPTIONS_GHC -fno-warn-type-defaults #-}
+{-# LANGUAGE ExtendedDefaultRules #-}
+{-# LANGUAGE QuasiQuotes          #-}
+{-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE TemplateHaskell      #-}
+module Lib.Synchronizers where
+
+import           Startlude               hiding ( check )
+import qualified Startlude.ByteStream          as ByteStream
+import qualified Startlude.ByteStream.Char8    as ByteStream
+
+import qualified Control.Effect.Reader.Labelled
+                                               as Fused
+import           Control.Carrier.Lift           ( runM )
+import           Control.Monad.Trans.Reader     ( mapReaderT )
+import           Control.Monad.Trans.Resource
+import           Data.Attoparsec.Text
+import qualified Data.ByteString               as BS
+import qualified Data.ByteString.Char8         as B8
+import qualified Data.Conduit                  as Conduit
+import qualified Data.Conduit.Combinators      as Conduit
+import qualified Data.Conduit.Tar              as Conduit
+import           Data.Conduit.Shell      hiding ( arch
+                                                , patch
+                                                , stream
+                                                , hostname
+                                                )
+import           Data.FileEmbed
+import qualified Data.HashMap.Strict           as HM
+import           Data.IORef
+import           Data.String.Interpolate.IsString
+import qualified Data.Yaml                     as Yaml
+import           Exinst
+import           System.FilePath                ( splitPath
+                                                , joinPath
+                                                , (</>)
+                                                )
+import           System.FilePath.Posix          ( takeDirectory )
+import           System.Directory
+import           System.IO.Error
+import           System.Posix.Files
+import qualified Streaming.Prelude             as Stream
+import qualified Streaming.Conduit             as Conduit
+import qualified Streaming.Zip                 as Stream
+
+import           Constants
+import           Foundation
+import           Lib.ClientManifest
+import           Lib.Error
+import qualified Lib.External.AppMgr           as AppMgr
+import           Lib.External.Registry
+import           Lib.Sound
+import           Lib.Ssl
+import           Lib.Tor
+import           Lib.Types.Core
+import           Lib.Types.NetAddress
+import           Lib.Types.Emver
+import           Lib.SystemCtl
+import           Lib.SystemPaths         hiding ( (</>) )
+import           Settings
+import           Util.File
+import qualified Lib.Algebra.Domain.AppMgr     as AppMgr2
+import           Daemon.ZeroConf                ( getStart9AgentHostname )
+
+
+data Synchronizer = Synchronizer
+    { synchronizerVersion    :: Version
+    , synchronizerOperations :: [SyncOp]
+    }
+
+data SyncOp = SyncOp
+    { syncOpName           :: Text
+    , syncOpShouldRun      :: ReaderT AgentCtx IO Bool -- emit true if op is to be run
+    , syncOpRun            :: ReaderT AgentCtx IO ()
+    , syncOpRequiresReboot :: Bool
+    }
+
+data Arch = ArmV7 | ArmV8 deriving (Show)
+data KernelVersion = KernelVersion
+    { kernelVersionNumber :: Version
+    , kernelVersionArch   :: Arch
+    }
+    deriving Show
+
+parseKernelVersion :: Parser KernelVersion
+parseKernelVersion = do
+    major' <- decimal
+    minor' <- char '.' *> decimal
+    patch' <- char '.' *> decimal
+    arch   <- string "-v7l+" *> pure ArmV7 <|> string "-v8+" *> pure ArmV8
+    pure $ KernelVersion (Version (major', minor', patch', 0)) arch
+
+synchronizer :: Synchronizer
+synchronizer = sync_0_2_5
+{-# INLINE synchronizer #-}
+
+sync_0_2_5 :: Synchronizer
+sync_0_2_5 = Synchronizer
+    "0.2.5"
+    [ syncCreateAgentTmp
+    , syncCreateSshDir
+    , syncRemoveAvahiSystemdDependency
+    , syncInstallAppMgr
+    , syncFullUpgrade
+    , sync32BitKernel
+    , syncInstallNginx
+    , syncWriteNginxConf
+    , syncInstallDuplicity
+    , syncInstallExfatFuse
+    , syncInstallExfatUtils
+    , syncInstallAmbassadorUI
+    , syncOpenHttpPorts
+    , syncUpgradeLifeline
+    , syncPrepSslRootCaDir
+    , syncPrepSslIntermediateCaDir
+    , syncPersistLogs
+    ]
+
+syncCreateAgentTmp :: SyncOp
+syncCreateAgentTmp = SyncOp "Create Agent Tmp Dir" check migrate False
+    where
+        check = do
+            s   <- asks appSettings
+            tmp <- injectFilesystemBaseFromContext s $ getAbsoluteLocationFor agentTmpDirectory
+            liftIO $ not <$> doesPathExist (toS tmp)
+        migrate = do
+            s   <- asks appSettings
+            tmp <- injectFilesystemBaseFromContext s $ getAbsoluteLocationFor agentTmpDirectory
+            liftIO $ createDirectoryIfMissing True (toS tmp)
+
+syncCreateSshDir :: SyncOp
+syncCreateSshDir = SyncOp "Create SSH directory" check migrate False
+    where
+        check = do
+            base <- asks $ appFilesystemBase . appSettings
+            liftIO $ not <$> doesPathExist (toS $ sshKeysDirectory `relativeTo` base)
+        migrate = do
+            base <- asks $ appFilesystemBase . appSettings
+            liftIO $ createDirectoryIfMissing False (toS $ sshKeysDirectory `relativeTo` base)
+
+syncRemoveAvahiSystemdDependency :: SyncOp
+syncRemoveAvahiSystemdDependency = SyncOp "Remove Avahi Systemd Dependency" check migrate False
+    where
+        wanted = decodeUtf8 $ $(embedFile "config/agent.service")
+        check  = do
+            base    <- asks $ appFilesystemBase . appSettings
+            content <- liftIO $ readFile (toS $ agentServicePath `relativeTo` base)
+            pure (content /= wanted)
+        migrate = do
+            base <- asks $ appFilesystemBase . appSettings
+            liftIO $ writeFile (toS $ agentServicePath `relativeTo` base) wanted
+            void $ liftIO systemCtlDaemonReload
+
+-- the main purpose of this is the kernel upgrade but it does upgrade all packages on the system, maybe we should
+-- reconsider the heavy handed approach here
+syncFullUpgrade :: SyncOp
+syncFullUpgrade = SyncOp "Full Upgrade" check migrate True
+    where
+        check = liftIO . run $ do
+            v <- decodeUtf8 <<$>> (uname ("-r" :: Text) $| conduit await)
+            case parse parseKernelVersion <$> v of
+                Just (Done _ (KernelVersion (Version av) _)) -> if av < (4, 19, 118, 0) then pure True else pure False
+                _ -> pure False
+        migrate = liftIO . run $ do
+            shell "apt update"
+            shell "apt full-upgrade -y"
+
+sync32BitKernel :: SyncOp
+sync32BitKernel = SyncOp "32 Bit Kernel Switch" check migrate True
+    where
+        getBootCfgPath = getAbsoluteLocationFor bootConfigPath
+        check          = do
+            settings <- asks appSettings
+            cfg      <- injectFilesystemBaseFromContext settings getBootCfgPath
+            liftIO . run $ fmap isNothing $ (shell [i|grep "arm_64bit=0" #{cfg} || true|] $| conduit await)
+        migrate = do
+            base <- asks $ appFilesystemBase . appSettings
+            let tmpFile = bootConfigTempPath `relativeTo` base
+            let bootCfg = bootConfigPath `relativeTo` base
+            contents <- liftIO $ readFile (toS bootCfg)
+            let contents' = unlines . (<> ["arm_64bit=0"]) . filter (/= "arm_64bit=1") . lines $ contents
+            liftIO $ writeFile (toS tmpFile) contents'
+            liftIO $ renameFile (toS tmpFile) (toS bootCfg)
+
+syncInstallNginx :: SyncOp
+syncInstallNginx = SyncOp "Install Nginx" check migrate False
+    where
+        check   = liftIO . run $ fmap isNothing (shell [i|which nginx || true|] $| conduit await)
+        migrate = liftIO . run $ do
+            apt "update"
+            apt "install" "nginx" "-y"
+
+syncInstallDuplicity :: SyncOp
+syncInstallDuplicity = SyncOp "Install duplicity" check migrate False
+    where
+        check   = liftIO . run $ fmap isNothing (shell [i|which duplicity || true|] $| conduit await)
+        migrate = liftIO . run $ do
+            apt "update"
+            apt "install" "-y" "duplicity"
+
+syncInstallExfatFuse :: SyncOp
+syncInstallExfatFuse = SyncOp "Install exfat-fuse" check migrate False
+    where
+        check =
+            liftIO
+                $       (run (shell [i|dpkg -l|] $| shell [i|grep exfat-fuse|] $| conduit await) $> False)
+                `catch` \(e :: ProcessException) -> case e of
+                            ProcessException _ (ExitFailure 1) -> pure True
+                            _ -> throwIO e
+        migrate = liftIO . run $ do
+            apt "update"
+            apt "install" "-y" "exfat-fuse"
+
+syncInstallExfatUtils :: SyncOp
+syncInstallExfatUtils = SyncOp "Install exfat-utils" check migrate False
+    where
+        check =
+            liftIO
+                $       (run (shell [i|dpkg -l|] $| shell [i|grep exfat-utils|] $| conduit await) $> False)
+                `catch` \(e :: ProcessException) -> case e of
+                            ProcessException _ (ExitFailure 1) -> pure True
+                            _ -> throwIO e
+        migrate = liftIO . run $ do
+            apt "update"
+            apt "install" "-y" "exfat-utils"
+
+syncWriteConf :: Text -> ByteString -> SystemPath -> SyncOp
+syncWriteConf name contents' confLocation = SyncOp [i|Write #{name} Conf|] check migrate False
+    where
+        contents = decodeUtf8 contents'
+        check    = do
+            base <- asks $ appFilesystemBase . appSettings
+            conf <-
+                liftIO
+                $       (Just <$> readFile (toS $ confLocation `relativeTo` base))
+                `catch` (\(e :: IOException) -> if isDoesNotExistError e then pure Nothing else throwIO e)
+            case conf of
+                Nothing -> pure True
+                Just co -> pure $ if co == contents then False else True
+        migrate = do
+            base <- asks $ appFilesystemBase . appSettings
+            void . liftIO $ createDirectoryIfMissing True (takeDirectory (toS $ confLocation `relativeTo` base))
+            liftIO $ writeFile (toS $ confLocation `relativeTo` base) contents
+
+syncPrepSslRootCaDir :: SyncOp
+syncPrepSslRootCaDir = SyncOp "Create Embassy Root CA Environment" check migrate False
+    where
+        check = do
+            base <- asks $ appFilesystemBase . appSettings
+            liftIO . fmap not . doesPathExist . toS $ rootCaDirectory `relativeTo` base
+        migrate = do
+            base <- asks $ appFilesystemBase . appSettings
+            liftIO $ do
+                createDirectoryIfMissing True . toS $ rootCaDirectory `relativeTo` base
+                for_ ["/certs", "/crl", "/newcerts", "/private"] $ \p -> do
+                    createDirectoryIfMissing True . toS $ p `relativeTo` (rootCaDirectory `relativeTo` base)
+                setFileMode (toS $ (rootCaDirectory <> "/private") `relativeTo` base) (7 `shiftL` 6)
+                writeFile (toS $ (rootCaDirectory <> "/index.txt") `relativeTo` base) ""
+                writeFile (toS $ (rootCaDirectory <> "/serial") `relativeTo` base)    "1000"
+                BS.writeFile (toS $ rootCaOpenSslConfPath `relativeTo` base)
+                             (root_CA_OPENSSL_CONF . toS $ rootCaDirectory `relativeTo` base)
+
+syncPrepSslIntermediateCaDir :: SyncOp
+syncPrepSslIntermediateCaDir = SyncOp "Create Embassy Intermediate CA Environment" check migrate False
+    where
+        check = do
+            base <- asks $ appFilesystemBase . appSettings
+            liftIO . fmap not . doesPathExist . toS $ intermediateCaDirectory `relativeTo` base
+        migrate = do
+            base <- asks $ appFilesystemBase . appSettings
+            liftIO $ do
+                createDirectoryIfMissing True . toS $ intermediateCaDirectory `relativeTo` base
+                for_ ["/certs", "/crl", "/newcerts", "/private"] $ \p -> do
+                    createDirectoryIfMissing True . toS $ (intermediateCaDirectory <> p) `relativeTo` base
+                setFileMode (toS $ (intermediateCaDirectory <> "/private") `relativeTo` base) (7 `shiftL` 6)
+                writeFile (toS $ (intermediateCaDirectory <> "/index.txt") `relativeTo` base) ""
+                writeFile (toS $ (intermediateCaDirectory <> "/serial") `relativeTo` base)    "1000"
+                BS.writeFile (toS $ intermediateCaOpenSslConfPath `relativeTo` base)
+                             (intermediate_CA_OPENSSL_CONF . toS $ intermediateCaDirectory `relativeTo` base)
+
+syncWriteNginxConf :: SyncOp
+syncWriteNginxConf = syncWriteConf "Nginx" $(embedFile "config/nginx.conf") nginxConfig
+
+syncInstallAmbassadorUI :: SyncOp
+syncInstallAmbassadorUI = SyncOp "Install Ambassador UI" check migrate False
+    where
+        check = do
+            base <- asks (appFilesystemBase . appSettings)
+            liftIO (doesPathExist (toS $ ambassadorUiPath `relativeTo` base)) >>= \case
+                True -> do
+                    manifest <- liftIO $ readFile (toS $ ambassadorUiManifestPath `relativeTo` base)
+                    case Yaml.decodeEither' (encodeUtf8 manifest) of
+                        Left  _            -> pure False
+                        Right (Some1 _ cm) -> case cm of
+                            (V0 cmv0) -> pure $ clientManifestV0AppVersion cmv0 /= agentVersion
+                False -> pure True
+        migrate = mapReaderT runResourceT $ do
+            base <- asks (appFilesystemBase . appSettings)
+            liftIO $ removePathForcibly (toS $ ambassadorUiPath `relativeTo` base)
+
+            void
+                . runInContext
+                -- untar and save to path
+                $ streamUntar (ambassadorUiPath `relativeTo` base)
+                -- unzip
+                . Stream.gunzip
+                -- download
+                $ getAmbassadorUiForSpec (exactly agentVersion)
+
+            runM $ injectFilesystemBase base $ do
+                -- if the ssl config has already been setup, we want to override the config with new UI details
+                -- otherwise we leave it alone
+                whenM (liftIO $ doesFileExist (toS $ nginxSitesAvailable nginxSslConf `relativeTo` base)) $ do
+                    sid <- getStart9AgentHostname
+                    let hostname = sid <> ".local"
+                    installAmbassadorUiNginxHTTPS
+                        (NginxSiteConfOverride
+                            hostname
+                            443
+                            (Just $ NginxSsl { nginxSslKeyPath         = entityKeyPath sid
+                                             , nginxSslCertPath        = entityCertPath sid
+                                             , nginxSslOnlyServerNames = [hostname]
+                                             }
+                            )
+                        )
+                        nginxSslConf
+                installAmbassadorUiNginxHTTP nginxTorConf
+
+        streamUntar :: (MonadResource m, MonadThrow m) => Text -> ByteStream.ByteStream m () -> m ()
+        streamUntar root stream = Conduit.runConduit $ Conduit.fromBStream stream .| Conduit.untar \f -> do
+            let path = toS . (toS root </>) . joinPath . drop 1 . splitPath . B8.unpack . Conduit.filePath $ f
+            print path
+            if (Conduit.fileType f == Conduit.FTDirectory)
+                then liftIO $ createDirectoryIfMissing True path
+                else Conduit.sinkFile path
+
+installAmbassadorUiNginxHTTP :: (MonadIO m, HasFilesystemBase sig m) => SystemPath -> m ()
+installAmbassadorUiNginxHTTP = installAmbassadorUiNginx Nothing
+
+installAmbassadorUiNginxHTTPS :: (MonadIO m, HasFilesystemBase sig m) => NginxSiteConfOverride -> SystemPath -> m ()
+installAmbassadorUiNginxHTTPS o = installAmbassadorUiNginx $ Just o
+
+-- Private. Installs an nginx conf from client-manifest to 'fileName' and restarts nginx.
+installAmbassadorUiNginx :: (MonadIO m, HasFilesystemBase sig m)
+                         => Maybe NginxSiteConfOverride
+                         -> SystemPath -- nginx conf file name
+                         -> m ()
+installAmbassadorUiNginx mSslOverrides fileName = do
+    base   <- Fused.ask @"filesystemBase"
+
+    -- parse app manifest
+    -- generate nginx conf from app manifest
+    -- write conf to ambassador target location
+    appEnv <- flip runReaderT base . handleS9ErrNuclear $ liftA2
+        (HM.intersectionWith (,))
+        (AppMgr2.runAppMgrCliC $ HM.mapMaybe AppMgr2.infoResTorAddress <$> AppMgr2.list [AppMgr2.flags| |])
+        AppMgr.readLanIps -- TODO: get appmgr to expose this or guarantee its structure
+    agentTor <- getAgentHiddenServiceUrl
+    let fullEnv = HM.insert (AppId "start9-ambassador") (TorAddress agentTor, LanIp "127.0.0.1") appEnv
+
+    removeFileIfExists $ nginxAvailableConf base
+    removeFileIfExists $ nginxEnabledConf base
+
+    flip runReaderT fullEnv
+        $   transpile mSslOverrides (ambassadorUiClientManifiest base) (nginxAvailableConf base)
+        >>= \case
+                True  -> pure ()
+                False -> throwIO . InternalS9Error $ "Failed to write ambassador ui nginx config " <> show fileName
+    liftIO $ createSymbolicLink (nginxAvailableConf base) (nginxEnabledConf base)
+
+    -- restart nginx
+    void . liftIO $ systemCtl RestartService "nginx"
+    where
+        ambassadorUiClientManifiest b = toS $ (ambassadorUiPath <> "/client-manifest.yaml") `relativeTo` b
+        nginxAvailableConf b = toS $ (nginxSitesAvailable fileName) `relativeTo` b
+        nginxEnabledConf b = toS $ (nginxSitesEnabled fileName) `relativeTo` b
+
+syncOpenHttpPorts :: SyncOp
+syncOpenHttpPorts = SyncOp "Open Hidden Service Port 80" check migrate False
+    where
+        check = runResourceT $ do
+            base <- asks $ appFilesystemBase . appSettings
+            res  <-
+                ByteStream.readFile (toS $ AppMgr.torrcBase `relativeTo` base)
+                & ByteStream.lines
+                & Stream.mapped ByteStream.toStrict
+                & Stream.map decodeUtf8
+                & Stream.filter
+                      ( (    (== ["HiddenServicePort", "443", "127.0.0.1:443"])
+                        <||> (== ["HiddenServicePort", "80", "127.0.0.1:80"])
+                        )
+                      . words
+                      )
+                & Stream.toList_
+            if length res < 2 then pure True else pure False
+        migrate = cantFail . flip catchE failUpdate $ do
+            lift $ syncOpRun $ syncWriteConf "Torrc" $(embedFile "config/torrc") AppMgr.torrcBase
+            AppMgr.torReload
+
+syncInstallAppMgr :: SyncOp
+syncInstallAppMgr = SyncOp "Install AppMgr" check migrate False
+    where
+        check = runExceptT AppMgr.getAppMgrVersion >>= \case
+            Left  _ -> pure True
+            Right v -> not . (v <||) <$> asks (appMgrVersionSpec . appSettings)
+        migrate = fmap (either absurd id) . runExceptT . flip catchE failUpdate $ do
+            avs <- asks $ appMgrVersionSpec . appSettings
+            av  <- AppMgr.installNewAppMgr avs
+            unless (av <|| avs) $ throwE $ AppMgrVersionE av avs
+
+syncUpgradeLifeline :: SyncOp
+syncUpgradeLifeline = SyncOp "Upgrade Lifeline" check migrate False
+    where
+        clearResets :: SystemPath
+        clearResets = "/usr/local/bin/clear-resets.sh"
+        check       = do
+            base <- asks $ appFilesystemBase . appSettings
+            liftIO $ doesFileExist . toS $ clearResets `relativeTo` base
+        migrate = do
+            base <- asks $ appFilesystemBase . appSettings
+            removeFileIfExists . toS $ lifelineBinaryPath `relativeTo` base
+            mapReaderT runResourceT $ runInContext $ getLifelineBinary (exactly "0.2.0")
+            removeFileIfExists . toS $ clearResets `relativeTo` base
+
+syncPersistLogs :: SyncOp
+syncPersistLogs =
+    (syncWriteConf "Journald" $(embedFile "config/journald.conf") journaldConfig) { syncOpRequiresReboot = True }
+
+failUpdate :: S9Error -> ExceptT Void (ReaderT AgentCtx IO) ()
+failUpdate e = do
+    ref <- asks appIsUpdateFailed
+    putStrLn $ "UPDATE FAILED: " <> errorMessage (toError e)
+    liftIO $ playSong 216 beethoven
+    liftIO $ writeIORef ref (Just e)
+
+cantFail :: Monad m => ExceptT Void m a -> m a
+cantFail = fmap (either absurd id) . runExceptT

agent/src/Lib/SystemCtl.hs

@@ -0,0 +1,23 @@
+module Lib.SystemCtl where
+
+import           Startlude               hiding ( words )
+import           Protolude.Unsafe               ( unsafeHead )
+
+import           Data.String
+import           System.Process
+import           Text.Casing
+
+data ServiceAction =
+      StartService
+    | StopService
+    | RestartService
+    deriving (Eq, Show)
+
+toAction :: ServiceAction -> String
+toAction = fmap toLower . unsafeHead . words . wordify . show
+
+systemCtl :: ServiceAction -> Text -> IO ExitCode
+systemCtl action service = rawSystem "systemctl" [toAction action, toS service]
+
+systemCtlDaemonReload :: IO ExitCode
+systemCtlDaemonReload = rawSystem "systemctl" ["daemon-reload"]

agent/src/Lib/SystemPaths.hs

@@ -0,0 +1,254 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module Lib.SystemPaths where
+
+import           Startlude               hiding ( (<.>)
+                                                , Reader
+                                                , ask
+                                                , runReader
+                                                )
+
+import           Control.Effect.Labelled        ( Labelled
+                                                , runLabelled
+                                                )
+import           Control.Effect.Reader.Labelled
+import           Data.List
+import qualified Data.Text                     as T
+import qualified Protolude.Base                as P
+                                                ( show )
+import           System.IO.Error                ( isDoesNotExistError )
+import           System.Directory
+
+import           Lib.Types.Core
+import           Settings
+
+strJoin :: Char -> Text -> Text -> Text
+strJoin c a b = case (T.unsnoc a, T.uncons b) of
+    (Nothing     , Nothing     ) -> ""
+    (Nothing     , Just _      ) -> b
+    (Just _      , Nothing     ) -> a
+    (Just (_, c0), Just (c1, s)) -> case (c0 == c, c1 == c) of
+        (True , True ) -> a <> s
+        (False, False) -> a <> T.singleton c <> b
+        _              -> a <> b
+
+(</>) :: Text -> Text -> Text
+(</>) = strJoin '/'
+
+(<.>) :: Text -> Text -> Text
+(<.>) = strJoin '.'
+
+-- system paths behave the same as FilePaths mostly except that they can be rebased onto alternative roots so that things
+-- can be tested in an isolated way. This uses a church encoding.
+newtype SystemPath = SystemPath { relativeTo :: Text -> Text }
+instance Eq SystemPath where
+    (==) a b = a `relativeTo` "/" == b `relativeTo` "/"
+instance Show SystemPath where
+    show sp = P.show $ sp `relativeTo` "/"
+instance Semigroup SystemPath where
+    (SystemPath f) <> (SystemPath g) = SystemPath $ g . f
+instance Monoid SystemPath where
+    mempty = SystemPath id
+instance IsString SystemPath where
+    fromString (c : cs) = case c of
+        '/' -> relBase . toS $ cs
+        _   -> relBase . toS $ c : cs
+    fromString [] = mempty
+
+leaf :: SystemPath -> Text
+leaf = last . T.splitOn "/" . show
+
+relBase :: Text -> SystemPath
+relBase = SystemPath . flip (</>)
+
+type HasFilesystemBase sig m = HasLabelled "filesystemBase" (Reader Text) sig m
+
+injectFilesystemBase :: Monad m => Text -> Labelled "filesystemBase" (ReaderT Text) m a -> m a
+injectFilesystemBase fsbase = flip runReaderT fsbase . runLabelled @"filesystemBase"
+
+injectFilesystemBaseFromContext :: Monad m => AppSettings -> Labelled "filesystemBase" (ReaderT Text) m a -> m a
+injectFilesystemBaseFromContext = injectFilesystemBase . appFilesystemBase
+
+getAbsoluteLocationFor :: HasFilesystemBase sig m => SystemPath -> m Text
+getAbsoluteLocationFor path = do
+    base <- ask @"filesystemBase"
+    pure $ path `relativeTo` base
+
+readSystemPath :: (HasFilesystemBase sig m, MonadIO m) => SystemPath -> m (Maybe Text)
+readSystemPath path = do
+    loadPath <- getAbsoluteLocationFor path
+    contents <-
+        liftIO
+        $       (Just <$> readFile (toS loadPath))
+        `catch` (\(e :: IOException) -> if isDoesNotExistError e then pure Nothing else throwIO e)
+    pure contents
+
+-- like the above, but throws IO error if file not found
+readSystemPath' :: (HasFilesystemBase sig m, MonadIO m) => SystemPath -> m Text
+readSystemPath' path = do
+    loadPath <- getAbsoluteLocationFor path
+    contents <- liftIO . readFile . toS $ loadPath
+    pure contents
+
+writeSystemPath :: (HasFilesystemBase sig m, MonadIO m) => SystemPath -> Text -> m ()
+writeSystemPath path contents = do
+    loadPath <- getAbsoluteLocationFor path
+    liftIO $ writeFile (toS loadPath) contents
+
+deleteSystemPath :: (HasFilesystemBase sig m, MonadIO m) => SystemPath -> m ()
+deleteSystemPath path = do
+    loadPath <- getAbsoluteLocationFor path
+    liftIO $ removePathForcibly (toS loadPath)
+
+dbPath :: (HasFilesystemBase sig m, HasLabelled "sqlDatabase" (Reader Text) sig m) => m Text
+dbPath = do
+    rt     <- ask @"filesystemBase"
+    dbName <- ask @"sqlDatabase"
+    pure $ rt </> "root/agent" </> toS dbName
+
+uiPath :: SystemPath
+uiPath = "/var/www/html"
+
+agentDataDirectory :: SystemPath
+agentDataDirectory = "/root/agent"
+
+agentTmpDirectory :: SystemPath
+agentTmpDirectory = "/root/agent/tmp"
+
+bootConfigPath :: SystemPath
+bootConfigPath = "/boot/config.txt"
+
+bootConfigTempPath :: SystemPath
+bootConfigTempPath = "/boot/config_tmp.txt"
+
+executablePath :: SystemPath
+executablePath = "/usr/local/bin"
+
+-- Caches --
+
+iconBasePath :: SystemPath
+iconBasePath = "/root/agent/icons"
+
+-- Nginx --
+
+nginxConfig :: SystemPath
+nginxConfig = "/etc/nginx/nginx.conf"
+
+journaldConfig :: SystemPath
+journaldConfig = "/etc/systemd/journald.conf"
+
+nginxSitesAvailable :: SystemPath -> SystemPath
+nginxSitesAvailable = ("/etc/nginx/sites-available" <>)
+
+nginxSitesEnabled :: SystemPath -> SystemPath
+nginxSitesEnabled = ("/etc/nginx/sites-enabled" <>)
+
+nginxTorConf :: SystemPath
+nginxTorConf = "/start9-ambassador.conf"
+
+nginxSslConf :: SystemPath
+nginxSslConf = "/start9-ambassador-ssl.conf"
+
+-- SSH --
+
+sshKeysDirectory :: SystemPath
+sshKeysDirectory = "/home/pi/.ssh"
+
+sshKeysFilePath :: SystemPath
+sshKeysFilePath = sshKeysDirectory <> "authorized_keys"
+
+-- Zero Conf --
+
+avahiPath :: SystemPath
+avahiPath = "/etc/avahi"
+
+avahiServiceFolder :: SystemPath
+avahiServiceFolder = avahiPath <> "services"
+
+avahiServicePath :: Text -> SystemPath
+avahiServicePath svc = avahiServiceFolder <> relBase (svc <.> "service")
+
+-- Ambassador UI --
+
+ambassadorUiPath :: SystemPath
+ambassadorUiPath = uiPath <> "/start9-ambassador"
+
+ambassadorUiManifestPath :: SystemPath
+ambassadorUiManifestPath = ambassadorUiPath <> "/client-manifest.yaml"
+
+-- Tor --
+
+agentTorHiddenServiceDirectory :: SystemPath
+agentTorHiddenServiceDirectory = "/var/lib/tor/agent"
+
+agentTorHiddenServiceHostnamePath :: SystemPath
+agentTorHiddenServiceHostnamePath = agentTorHiddenServiceDirectory <> "/hostname"
+
+agentTorHiddenServicePrivateKeyPath :: SystemPath
+agentTorHiddenServicePrivateKeyPath = agentTorHiddenServiceDirectory <> "/hs_ed25519_secret_key"
+
+-- Server Config --
+
+serverNamePath :: SystemPath
+serverNamePath = "/root/agent/name.txt"
+
+altRegistryUrlPath :: SystemPath
+altRegistryUrlPath = "/root/agent/alt_registry_url.txt"
+
+-- Session Auth Key --
+
+sessionSigningKeyPath :: SystemPath
+sessionSigningKeyPath = "/root/agent/start9.aes"
+
+-- AppMgr --
+
+appMgrRootPath :: SystemPath
+appMgrRootPath = "/root/appmgr"
+
+appMgrAppPath :: AppId -> SystemPath
+appMgrAppPath = ((appMgrRootPath <> "apps") <>) . relBase . unAppId
+
+lifelineBinaryPath :: SystemPath
+lifelineBinaryPath = "/usr/local/bin/lifeline"
+
+-- Open SSL --
+
+rootCaDirectory :: SystemPath
+rootCaDirectory = agentDataDirectory <> "/ca"
+
+rootCaKeyPath :: SystemPath
+rootCaKeyPath = rootCaDirectory <> "/private/embassy-root-ca.key.pem"
+
+rootCaCertPath :: SystemPath
+rootCaCertPath = rootCaDirectory <> "/certs/embassy-root-ca.cert.pem"
+
+rootCaOpenSslConfPath :: SystemPath
+rootCaOpenSslConfPath = rootCaDirectory <> "/openssl.conf"
+
+intermediateCaDirectory :: SystemPath
+intermediateCaDirectory = rootCaDirectory <> "/intermediate"
+
+intermediateCaKeyPath :: SystemPath
+intermediateCaKeyPath = intermediateCaDirectory <> "/private/embassy-int-ca.key.pem"
+
+intermediateCaCertPath :: SystemPath
+intermediateCaCertPath = intermediateCaDirectory <> "/certs/embassy-int-ca.crt.pem"
+
+intermediateCaOpenSslConfPath :: SystemPath
+intermediateCaOpenSslConfPath = intermediateCaDirectory <> "/openssl.conf"
+
+sslDirectory :: SystemPath
+sslDirectory = "/etc/nginx/ssl"
+
+entityKeyPath :: Text -> SystemPath
+entityKeyPath hostname = sslDirectory <> relBase ("/" <> hostname <> "-local.key.pem")
+
+entityCertPath :: Text -> SystemPath
+entityCertPath hostname = sslDirectory <> relBase ("/" <> hostname <> "-local.crt.pem")
+
+entityConfPath :: Text -> SystemPath
+entityConfPath hostname = sslDirectory <> relBase ("/" <> hostname <> "-local.conf")
+
+-- Systemd
+
+agentServicePath :: SystemPath
+agentServicePath = "/etc/systemd/system/agent.service"

agent/src/Lib/Tor.hs

@@ -0,0 +1,13 @@
+module Lib.Tor where
+
+import           Startlude
+
+import qualified Data.Text                     as T
+
+import           Lib.SystemPaths
+
+getAgentHiddenServiceUrl :: (HasFilesystemBase sig m, MonadIO m) => m Text
+getAgentHiddenServiceUrl = T.strip <$> readSystemPath' agentTorHiddenServiceHostnamePath
+
+getAgentHiddenServiceUrlMaybe :: (HasFilesystemBase sig m, MonadIO m) => m (Maybe Text)
+getAgentHiddenServiceUrlMaybe = fmap T.strip <$> readSystemPath agentTorHiddenServiceHostnamePath

agent/src/Lib/TyFam/ConditionalData.hs

@@ -0,0 +1,20 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Lib.TyFam.ConditionalData where
+
+import           Startlude
+
+import           Data.Singletons.TH
+
+type Include :: Bool -> Type -> Type
+type family Include p a where
+    Include 'True a = a
+    Include 'False _ = ()
+genDefunSymbols [''Include]
+type Keep :: Type ~> Type
+type Keep = IncludeSym1 'True
+type Full :: ((Type ~> Type) -> Type) -> Type
+type Full t = t Keep
+type Strip :: Type ~> Type
+type Strip = IncludeSym1 'False
+type Stripped :: ((Type ~> Type) -> Type) -> Type
+type Stripped t = t Strip

agent/src/Lib/Types/Core.hs

@@ -0,0 +1,114 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Lib.Types.Core where
+
+import           Startlude
+import qualified GHC.Read                       ( Read(..) )
+import qualified GHC.Show                       ( Show(..) )
+
+import           Data.Aeson                     ( withText
+                                                , FromJSON(parseJSON)
+                                                , FromJSONKey(fromJSONKey)
+                                                , Value(String)
+                                                , ToJSON(toJSON)
+                                                , ToJSONKey(toJSONKey)
+                                                )
+import           Data.Functor.Contravariant     ( Contravariant(contramap) )
+import           Data.Singletons.TH
+import           Database.Persist               ( PersistField(..)
+                                                , PersistValue(PersistText)
+                                                , SqlType(SqlString)
+                                                )
+import           Database.Persist.Sql           ( PersistFieldSql(..) )
+import           Yesod.Core                     ( PathPiece(..) )
+import           Control.Monad.Fail             ( MonadFail(fail) )
+import           Data.Text                      ( toUpper )
+import           Web.HttpApiData
+
+newtype AppId = AppId { unAppId :: Text } deriving (Eq, Ord)
+deriving newtype instance ToHttpApiData AppId
+deriving newtype instance FromHttpApiData AppId
+
+instance IsString AppId where
+    fromString = AppId . fromString
+instance Show AppId where
+    show = toS . unAppId
+instance Read AppId where
+    readsPrec _ s = [(AppId $ toS s, "")]
+instance Hashable AppId where
+    hashWithSalt n = hashWithSalt n . unAppId
+instance ToJSON AppId where
+    toJSON = toJSON . unAppId
+instance FromJSON AppId where
+    parseJSON = fmap AppId . parseJSON
+instance PathPiece AppId where
+    toPathPiece   = unAppId
+    fromPathPiece = fmap AppId . fromPathPiece
+instance PersistField AppId where
+    toPersistValue = PersistText . show
+    fromPersistValue (PersistText t) = Right . AppId $ toS t
+    fromPersistValue other           = Left $ "Invalid AppId: " <> show other
+instance PersistFieldSql AppId where
+    sqlType _ = SqlString
+instance FromJSONKey AppId where
+    fromJSONKey = fmap AppId fromJSONKey
+instance ToJSONKey AppId where
+    toJSONKey = contramap unAppId toJSONKey
+
+
+data AppContainerStatus =
+      Running
+    | Stopped
+    | Paused
+    | Restarting
+    | Removing
+    | Dead deriving (Eq, Show)
+instance ToJSON AppContainerStatus where
+    toJSON Paused = String "STOPPED" -- we never want to show paused to the Front End
+    toJSON other  = String . toUpper . show $ other
+instance FromJSON AppContainerStatus where
+    parseJSON = withText "health status" $ \case
+        "RUNNING"    -> pure Running
+        "STOPPED"    -> pure Stopped
+        "PAUSED"     -> pure Paused
+        "RESTARTING" -> pure Restarting
+        "REMOVING"   -> pure Removing
+        "DEAD"       -> pure Dead
+        _            -> fail "unknown status"
+
+data AppAction = Start | Stop deriving (Eq, Show)
+
+data BackupJobType = CreateBackup | RestoreBackup deriving (Eq, Show)
+
+$(singletons [d|
+    data AppTmpStatus
+        = Installing
+        | CreatingBackup
+        | RestoringBackup
+        | NeedsConfig
+        | BrokenDependencies
+        | Crashed
+        | StoppingT
+        | RestartingT
+        deriving (Eq, Show) |])
+
+instance ToJSON AppTmpStatus where
+    toJSON = String . \case
+        Installing         -> "INSTALLING"
+        CreatingBackup     -> "CREATING_BACKUP"
+        RestoringBackup    -> "RESTORING_BACKUP"
+        NeedsConfig        -> "NEEDS_CONFIG"
+        BrokenDependencies -> "BROKEN_DEPENDENCIES"
+        Crashed            -> "CRASHED"
+        RestartingT        -> "RESTARTING"
+        StoppingT          -> "STOPPING"
+
+data AppStatus
+    = AppStatusTmp AppTmpStatus
+    | AppStatusAppMgr AppContainerStatus
+    deriving (Eq, Show)
+instance ToJSON AppStatus where
+    toJSON (AppStatusTmp    s) = toJSON s
+    toJSON (AppStatusAppMgr s) = toJSON s

agent/src/Lib/Types/Emver.hs

@@ -0,0 +1,258 @@
+{- |
+Module : Lib.Types.Emver
+Description : Semver with 4th digit extension for Embassy
+License : Start9 Non-Commercial
+Maintainer : keagan@start9labs.com
+Stability : experimental
+Portability : portable
+
+This module was designed to address the problem of releasing updates to Embassy Packages where the upstream project was
+either unaware of or apathetic towards supporting their application on the Embassy platform. In most cases, the original
+package will support <https://semver.org/spec/v2.0.0.html semver2>. This leaves us with the problem where we would like
+to preserve the original package's version, since one of the goals of the Embassy platform is transparency. However, on
+occasion, we have screwed up and published a version of a package that needed to have its metadata updated. In this
+scenario we were left with the conundrum of either unilaterally claiming a version number of a package we did not author
+or let the issue persist until the next update. Neither of these promote good user experiences, for different reasons.
+This module extends the semver standard linked above with a 4th digit, which is given PATCH semantics.
+-}
+
+module Lib.Types.Emver
+    ( major
+    , minor
+    , patch
+    , revision
+    , satisfies
+    , (<||)
+    , (||>)
+    -- we do not export 'None' because it is useful for its internal algebraic properties only
+    , VersionRange(Anchor, Any, None)
+    , Version(..)
+    , AnyRange(..)
+    , AllRange(..)
+    , conj
+    , disj
+    , exactly
+    , parseVersion
+    , parseRange
+    )
+where
+
+import           Prelude
+import qualified Data.Attoparsec.Text          as Atto
+import           Data.Function
+import           Data.Functor                   ( (<&>)
+                                                , ($>)
+                                                )
+import           Control.Applicative            ( liftA2
+                                                , Alternative((<|>))
+                                                )
+import           Data.String                    ( IsString(..) )
+import qualified Data.Text                     as T
+
+-- | AppVersion is the core representation of the SemverQuad type.
+newtype Version = Version { unVersion :: (Word, Word, Word, Word) } deriving (Eq, Ord)
+instance Show Version where
+    show (Version (x, y, z, q)) =
+        let postfix = if q == 0 then "" else '.' : show q in show x <> "." <> show y <> "." <> show z <> postfix
+instance IsString Version where
+    fromString s = either error id $ Atto.parseOnly parseVersion (T.pack s)
+
+-- | A change in the value found at 'major' implies a breaking change in the API that this version number describes
+major :: Version -> Word
+major (Version (x, _, _, _)) = x
+
+-- | A change in the value found at 'minor' implies a backwards compatible addition to the API that this version number
+-- describes
+minor :: Version -> Word
+minor (Version (_, y, _, _)) = y
+
+-- | A change in the value found at 'patch' implies that the implementation of the API has changed without changing the
+-- invariants promised by the API. In many cases this will be incremented when repairing broken functionality
+patch :: Version -> Word
+patch (Version (_, _, z, _)) = z
+
+-- | This is the fundamentally new value in comparison to the original semver 2.0 specification. It is given the same
+-- semantics as 'patch' above, which begs the question, when should you update this value instead of that one. Generally
+-- speaking, if you are both the package author and maintainer, you should not ever increment this number, as it is
+-- redundant with 'patch'. However, if you maintain a package on some distribution channel, and you are /not/ the
+-- original author, then it is encouraged for you to increment 'quad' instead of 'patch'.
+revision :: Version -> Word
+revision (Version (_, _, _, q)) = q
+
+
+-- | 'Operator' is the type that specifies how to compare against the target version. Right represents the ordering,
+-- Left negates it
+type Operator = Either Ordering Ordering
+
+-- | 'VersionRange' is the algebra of sets of versions. They can be constructed by having an 'Anchor' term which
+-- compares against the target version, or can be described with 'Conj' which is a conjunction, or 'Disj', which is a
+-- disjunction. The 'Any' and 'All' terms are primarily there to round out the algebra, but 'Any' is also exposed due to
+-- its usage in semantic versioning in general. The 'None' term is not useful to the end user as there would be no
+-- reasonable usage of it to describe version sets. It is included for its utility as a unit on 'Disj' and possibly as
+-- a zero on 'Conj'
+--
+-- Laws (reflected in implementations of smart constructors):
+-- Commutativity of conjunction: Conj a b === Conj b a
+-- Commutativity of disjunction: Disj a b === Disj b a
+-- Associativity of conjunction: Conj (Conj a b) c === Conj a (Conj b c)
+-- Associativity of disjunction: Disj (Disj a b) c === Disj a (Disj b c)
+-- Identity of conjunction: Any `Conj` a === a
+-- Identity of disjunction: None `Disj` a === a
+-- Zero of conjunction: None `Conj` a === None
+-- Zero of disjunction: Any `Disj` a === Any
+-- Distributivity of conjunction over disjunction: Conj a (Disj b c) === Disj (Conj a b) (Conj a c)
+-- Distributivity of disjunction over conjunction: Disj a (Conj b c) === Conj (Disj a b) (Disj a c)
+data VersionRange
+    = Anchor Operator Version
+    | Conj VersionRange VersionRange
+    | Disj VersionRange VersionRange
+    | Any
+    | None
+    deriving (Eq)
+
+-- | Smart constructor for conjunctions. Eagerly evaluates zeros and identities
+conj :: VersionRange -> VersionRange -> VersionRange
+conj Any  b    = b
+conj a    Any  = a
+conj None _    = None
+conj _    None = None
+conj a    b    = Conj a b
+
+-- | Smart constructor for disjunctions. Eagerly evaluates zeros and identities
+disj :: VersionRange -> VersionRange -> VersionRange
+disj Any  _    = Any
+disj _    Any  = Any
+disj None b    = b
+disj a    None = a
+disj a    b    = Disj a b
+
+exactly :: Version -> VersionRange
+exactly = Anchor (Right EQ)
+
+instance Show VersionRange where
+    show (Anchor (  Left  EQ) v           ) = '!' : '=' : show v
+    show (Anchor (  Right EQ) v           ) = '=' : show v
+    show (Anchor (  Left  LT) v           ) = '>' : '=' : show v
+    show (Anchor (  Right LT) v           ) = '<' : show v
+    show (Anchor (  Left  GT) v           ) = '<' : '=' : show v
+    show (Anchor (  Right GT) v           ) = '>' : show v
+    show (Conj   a@(Disj _ _) b@(Disj _ _)) = paren (show a) <> (' ' : paren (show b))
+    show (Conj   a@(Disj _ _) b           ) = paren (show a) <> (' ' : show b)
+    show (Conj   a            b@(Disj _ _)) = show a <> (' ' : paren (show b))
+    show (Conj   a            b           ) = show a <> (' ' : show b)
+    show (Disj   a            b           ) = show a <> " || " <> show b
+    show Any                                = "*"
+    show None                               = "!"
+instance Read VersionRange where
+    readsPrec _ s = case Atto.parseOnly parseRange (T.pack s) of
+        Left  _ -> []
+        Right a -> [(a, "")]
+
+paren :: String -> String
+paren = mappend "(" . flip mappend ")"
+
+newtype AnyRange = AnyRange { unAnyRange :: VersionRange }
+instance Semigroup AnyRange where
+    (<>) = AnyRange <<$>> disj `on` unAnyRange
+instance Monoid AnyRange where
+    mempty = AnyRange None
+
+newtype AllRange = AllRange { unAllRange :: VersionRange }
+instance Semigroup AllRange where
+    (<>) = AllRange <<$>> conj `on` unAllRange
+instance Monoid AllRange where
+    mempty = AllRange Any
+
+-- | Predicate for deciding whether the 'Version' is in the 'VersionRange'
+satisfies :: Version -> VersionRange -> Bool
+satisfies v (Anchor op v') = either (\c x y -> compare x y /= c) (\c x y -> compare x y == c) op v v'
+satisfies v (Conj   a  b ) = v `satisfies` a && v `satisfies` b
+satisfies v (Disj   a  b ) = v `satisfies` a || v `satisfies` b
+satisfies _ Any            = True
+satisfies _ None           = False
+
+(<||) :: Version -> VersionRange -> Bool
+(<||) = satisfies
+{-# INLINE (<||) #-}
+
+(||>) :: VersionRange -> Version -> Bool
+(||>) = flip satisfies
+{-# INLINE (||>) #-}
+
+(<<$>>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)
+(<<$>>) = fmap . fmap
+{-# INLINE (<<$>>) #-}
+
+parseOperator :: Atto.Parser Operator
+parseOperator =
+    (Atto.char '=' $> Right EQ)
+        <|> (Atto.string "!=" $> Left EQ)
+        <|> (Atto.string ">=" $> Left LT)
+        <|> (Atto.string "<=" $> Left GT)
+        <|> (Atto.char '>' $> Right GT)
+        <|> (Atto.char '<' $> Right LT)
+
+parseVersion :: Atto.Parser Version
+parseVersion = do
+    major' <- Atto.decimal <* Atto.char '.'
+    minor' <- Atto.decimal <* Atto.char '.'
+    patch' <- Atto.decimal
+    quad'  <- Atto.option 0 $ Atto.char '.' *> Atto.decimal
+    pure $ Version (major', minor', patch', quad')
+
+-- >>> Atto.parseOnly parseRange "=2.3.4 1.2.3.4 - 2.3.4.5 (>3.0.0 || <3.4.5)"
+-- Right =2.3.4 >=1.2.3.4 <=2.3.4.5 ((>3.0.0 || <3.4.5))
+-- >>> Atto.parseOnly parseRange "0.2.6"
+-- Right =0.2.6
+parseRange :: Atto.Parser VersionRange
+parseRange = s <|> (Atto.char '*' *> pure Any) <|> (Anchor (Right EQ) <$> parseVersion)
+    where
+        sub = Atto.char '(' *> Atto.skipSpace *> parseRange <* Atto.skipSpace <* Atto.char ')'
+        s =
+            unAnyRange
+                .   foldMap AnyRange
+                <$> ((p <|> sub) `Atto.sepBy1` (Atto.skipSpace *> Atto.string "||" <* Atto.skipSpace))
+        p = unAllRange . foldMap AllRange <$> ((a <|> sub) `Atto.sepBy1` Atto.space)
+        a = liftA2 Anchor parseOperator parseVersion <|> caret <|> tilde <|> wildcard <|> hyphen
+
+-- >>> liftA2 satisfies (Atto.parseOnly parseVersion "0.20.1.1") (Atto.parseOnly parseRange "^0.20.1")
+-- Right True
+caret :: Atto.Parser VersionRange
+caret = (Atto.char '^' *> parseVersion) <&> \case
+    v@(Version (0, 0, 0, _)) -> Anchor (Right EQ) v
+    v@(Version (0, 0, z, _)) -> rangeIE v (Version (0, 0, z + 1, 0))
+    v@(Version (0, y, _, _)) -> rangeIE v (Version (0, y + 1, 0, 0))
+    v@(Version (x, _, _, _)) -> rangeIE v (Version (x + 1, 0, 0, 0))
+
+-- >>> Atto.parseOnly tilde "~1.2.3.4"
+-- Right >=1.2.3.4 <1.2.4
+tilde :: Atto.Parser VersionRange
+tilde = (Atto.char '~' *> (Atto.decimal `Atto.sepBy1` Atto.char '.')) >>= \case
+    [x, y, z, q] -> pure $ rangeIE (Version (x, y, z, q)) (Version (x, y, z + 1, 0))
+    [x, y, z]    -> pure $ rangeIE (Version (x, y, z, 0)) (Version (x, y + 1, 0, 0))
+    [x, y]       -> pure $ rangeIE (Version (x, y, 0, 0)) (Version (x, y + 1, 0, 0))
+    [x]          -> pure $ rangeIE (Version (x, 0, 0, 0)) (Version (x + 1, 0, 0, 0))
+    o            -> fail $ "Invalid number of version numbers: " <> show (length o)
+
+range :: Bool -> Bool -> Version -> Version -> VersionRange
+range inc0 inc1 v0 v1 =
+    let lo = if inc0 then Left LT else Right GT
+        hi = if inc1 then Left GT else Right LT
+    in  Conj (Anchor lo v0) (Anchor hi v1)
+
+rangeIE :: Version -> Version -> VersionRange
+rangeIE = range True False
+
+-- >>> Atto.parseOnly wildcard "1.2.3.x"
+-- Right >=1.2.3 <1.2.4
+wildcard :: Atto.Parser VersionRange
+wildcard = (Atto.many1 (Atto.decimal <* Atto.char '.') <* Atto.char 'x') >>= \case
+    [x, y, z] -> pure $ rangeIE (Version (x, y, z, 0)) (Version (x, y, z + 1, 0))
+    [x, y]    -> pure $ rangeIE (Version (x, y, 0, 0)) (Version (x, y + 1, 0, 0))
+    [x]       -> pure $ rangeIE (Version (x, 0, 0, 0)) (Version (x + 1, 0, 0, 0))
+    o         -> fail $ "Invalid number of version numbers: " <> show (length o)
+
+-- >>> Atto.parseOnly hyphen "0.1.2.3 - 1.2.3.4"
+-- Right >=0.1.2.3 <=1.2.3.4
+hyphen :: Atto.Parser VersionRange
+hyphen = liftA2 (range True True) parseVersion (Atto.skipSpace *> Atto.char '-' *> Atto.skipSpace *> parseVersion)

agent/src/Lib/Types/Emver/Orphans.hs

@@ -0,0 +1,40 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Lib.Types.Emver.Orphans where
+
+import           Startlude
+
+import           Data.Aeson
+
+import           Lib.Types.Emver
+import           Database.Persist
+import           Database.Persist.Sql
+import qualified Data.Attoparsec.Text          as Atto
+import           Control.Monad.Fail
+import qualified Data.Text                     as T
+import           Yesod.Core.Dispatch
+
+instance ToJSON Version where
+    toJSON = String . show
+instance FromJSON Version where
+    parseJSON = withText
+        "Quad Semver"
+        \t -> case Atto.parseOnly parseVersion t of
+            Left  e -> fail e
+            Right a -> pure a
+instance ToJSON VersionRange where
+    toJSON = String . show
+instance FromJSON VersionRange where
+    parseJSON = withText "Quad Semver Range" $ \t -> case Atto.parseOnly parseRange t of
+        Left  e -> fail e
+        Right a -> pure a
+
+instance PersistField Version where
+    toPersistValue   = toPersistValue @Text . show
+    fromPersistValue = first T.pack . Atto.parseOnly parseVersion <=< fromPersistValue
+
+instance PersistFieldSql Version where
+    sqlType _ = SqlString
+
+instance PathPiece VersionRange where
+    toPathPiece   = show
+    fromPathPiece = hush . Atto.parseOnly parseRange

agent/src/Lib/Types/NetAddress.hs

@@ -0,0 +1,13 @@
+module Lib.Types.NetAddress where
+
+import           Startlude
+import           Protolude.Base                 ( show )
+
+newtype TorAddress = TorAddress { unTorAddress :: Text } deriving (Eq)
+instance Show TorAddress where
+    show = toS . unTorAddress
+
+newtype LanIp = LanIp { unLanIp :: Text } deriving (Eq)
+instance Show LanIp where
+    show = toS . unLanIp
+

agent/src/Lib/Types/ServerApp.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE QuasiQuotes          #-}
+{-# LANGUAGE RecordWildCards      #-}
+{-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE TemplateHaskell      #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Lib.Types.ServerApp where
+
+import           Startlude               hiding ( break )
+
+import           Data.Aeson
+
+import           Lib.Types.Core
+import           Lib.Types.Emver
+import           Lib.Types.Emver.Orphans        ( )
+
+data StoreApp = StoreApp
+    { storeAppId               :: AppId
+    , storeAppTitle            :: Text
+    , storeAppDescriptionShort :: Text
+    , storeAppDescriptionLong  :: Text
+    , storeAppIconUrl          :: Text
+    , storeAppVersions         :: NonEmpty StoreAppVersionInfo
+    }
+    deriving (Eq, Show)
+
+data StoreAppVersionInfo = StoreAppVersionInfo
+    { storeAppVersionInfoVersion      :: Version
+    , storeAppVersionInfoReleaseNotes :: Text
+    }
+    deriving (Eq, Show)
+instance Ord StoreAppVersionInfo where
+    compare = compare `on` storeAppVersionInfoVersion
+instance FromJSON StoreAppVersionInfo where
+    parseJSON = withObject "Store App Version Info" $ \o -> do
+        storeAppVersionInfoVersion      <- o .: "version"
+        storeAppVersionInfoReleaseNotes <- o .: "release-notes"
+        pure StoreAppVersionInfo { .. }
+instance ToJSON StoreAppVersionInfo where
+    toJSON StoreAppVersionInfo {..} =
+        object ["version" .= storeAppVersionInfoVersion, "releaseNotes" .= storeAppVersionInfoReleaseNotes]

agent/src/Lib/Types/Url.hs

@@ -0,0 +1,50 @@
+module Lib.Types.Url where
+
+import           Startlude
+
+import           Control.Monad.Fail
+import qualified Data.Attoparsec.Text          as A
+import qualified GHC.Show                       ( Show(..) )
+
+-- this is a very weak definition of url, it needs to be fleshed out in accordance with https://www.ietf.org/rfc/rfc1738.txt
+data Url = Url
+    { urlScheme :: Text
+    , urlHost   :: Text
+    , urlPort   :: Word16
+    }
+    deriving Eq
+instance Show Url where
+    show (Url scheme host port) = toS $ scheme <> "://" <> host <> ":" <> show port
+
+parseUrl :: Text -> Either String Url
+parseUrl t = A.parseOnly urlParser (toS t)
+
+urlParser :: A.Parser Url
+urlParser = do
+    (scheme, defPort) <- A.option ("https", 443) $ schemeParser >>= \case
+        "http"  -> pure ("http", 80)
+        "https" -> pure ("https", 443)
+        other   -> fail $ "Invalid Scheme: " <> toS other
+    eHost <- fmap Left (untilParser ":") <|> fmap Right (atLeastParser 2)
+    case eHost of
+        Left  host -> Url scheme host <$> portParser
+        Right host -> pure $ Url scheme host defPort
+
+untilParser :: Text -> A.Parser Text
+untilParser t = toS <$> A.manyTill A.anyChar (A.string t)
+
+atLeastParser :: Int -> A.Parser Text
+atLeastParser n = do
+    minLength <- toS <$> A.count n A.anyChar
+    rest      <- A.takeText
+    pure $ minLength <> rest
+
+portParser :: A.Parser Word16
+portParser = do
+    port <- A.decimal
+    A.atEnd >>= \case
+        True  -> pure port
+        False -> fail "invalid port"
+
+schemeParser :: A.Parser Text
+schemeParser = toS <$> A.manyTill A.anyChar (A.string "://")

agent/src/Lib/WebServer.hs

@@ -0,0 +1,185 @@
+{-# LANGUAGE QuasiQuotes      #-}
+{-# LANGUAGE RecordWildCards  #-}
+{-# LANGUAGE TemplateHaskell  #-}
+{-# LANGUAGE TupleSections    #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ViewPatterns     #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Lib.WebServer where
+
+import           Startlude               hiding ( exp )
+
+import           Control.Monad.Logger
+import           Data.Default
+import           Data.IORef
+import           Language.Haskell.TH.Syntax     ( qLocation )
+import           Network.Wai
+import           Network.Wai.Handler.Warp       ( Settings
+                                                , defaultSettings
+                                                , defaultShouldDisplayException
+                                                , runSettings
+                                                , setHost
+                                                , setOnException
+                                                , setPort
+                                                )
+import           Network.Wai.Middleware.Cors    ( CorsResourcePolicy(..)
+                                                , cors
+                                                , simpleCorsResourcePolicy
+                                                )
+import           Network.Wai.Middleware.RequestLogger
+                                                ( Destination(Logger)
+                                                , IPAddrSource(..)
+                                                , OutputFormat(..)
+                                                , destination
+                                                , mkRequestLogger
+                                                , outputFormat
+                                                )
+import           Yesod.Core
+import           Yesod.Core.Types        hiding ( Logger )
+
+import           Auth
+import           Foundation
+import           Handler.Apps
+import           Handler.Authenticate
+import           Handler.Backups
+import           Handler.Hosts
+import           Handler.Icons
+import           Handler.Login
+import           Handler.Notifications
+import           Handler.PasswordUpdate
+import           Handler.PowerOff
+import           Handler.Register
+import           Handler.SelfUpdate
+import           Handler.SshKeys
+import           Handler.Status
+import           Handler.Wifi
+import           Handler.V0
+import           Settings
+
+-- This line actually creates our YesodDispatch instance. It is the second half
+-- of the call to mkYesodData which occurs in Foundation.hs. Please see the
+-- comments there for more details.
+mkYesodDispatch "AgentCtx" resourcesAgentCtx
+
+instance YesodSubDispatch Auth AgentCtx where
+    yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth)
+
+-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
+-- applying some additional middlewares.
+makeApplication :: AgentCtx -> IO Application
+makeApplication foundation = do
+    logWare <- makeLogWare foundation
+    -- Create the WAI application and apply middlewares
+    appPlain <- toWaiAppPlain foundation
+    let origin = case appCorsOverrideStar $ appSettings foundation of
+            Nothing -> Nothing
+            Just override -> Just ([encodeUtf8 override], True)
+    pure . logWare . cors (const . Just $ policy origin) . defaultMiddlewaresNoLogging $ appPlain
+    where
+        policy o = simpleCorsResourcePolicy
+            { corsOrigins        = o
+            , corsMethods        = ["GET", "POST", "HEAD", "PUT", "DELETE", "TRACE", "CONNECT", "OPTIONS", "PATCH"]
+            , corsRequestHeaders = [ "app-version"
+                                   , "Accept"
+                                   , "Accept-Charset"
+                                   , "Accept-Encoding"
+                                   , "Accept-Language"
+                                   , "Accept-Ranges"
+                                   , "Age"
+                                   , "Allow"
+                                   , "Authorization"
+                                   , "Cache-Control"
+                                   , "Connection"
+                                   , "Content-Encoding"
+                                   , "Content-Language"
+                                   , "Content-Length"
+                                   , "Content-Location"
+                                   , "Content-MD5"
+                                   , "Content-Range"
+                                   , "Content-Type"
+                                   , "Date"
+                                   , "ETag"
+                                   , "Expect"
+                                   , "Expires"
+                                   , "From"
+                                   , "Host"
+                                   , "If-Match"
+                                   , "If-Modified-Since"
+                                   , "If-None-Match"
+                                   , "If-Range"
+                                   , "If-Unmodified-Since"
+                                   , "Last-Modified"
+                                   , "Location"
+                                   , "Max-Forwards"
+                                   , "Pragma"
+                                   , "Proxy-Authenticate"
+                                   , "Proxy-Authorization"
+                                   , "Range"
+                                   , "Referer"
+                                   , "Retry-After"
+                                   , "Server"
+                                   , "TE"
+                                   , "Trailer"
+                                   , "Transfer-Encoding"
+                                   , "Upgrade"
+                                   , "User-Agent"
+                                   , "Vary"
+                                   , "Via"
+                                   , "WWW-Authenticate"
+                                   , "Warning"
+                                   , "Content-Disposition"
+                                   , "MIME-Version"
+                                   , "Cookie"
+                                   , "Set-Cookie"
+                                   , "Origin"
+                                   , "Prefer"
+                                   , "Preference-Applied"
+                                   ]
+            , corsIgnoreFailures = True
+            }
+
+startWeb :: AgentCtx -> IO ()
+startWeb foundation = do
+    app <- makeApplication foundation
+
+    putStrLn @Text $ "Launching Web Server on port " <> show (appPort $ appSettings foundation)
+    action <- async $ runSettings (warpSettings foundation) app
+
+    setWebProcessThreadId (asyncThreadId action) foundation
+    wait action
+
+shutdownAll :: [ThreadId] -> IO ()
+shutdownAll threadIds = do
+    for_ threadIds killThread
+    exitSuccess
+
+shutdownWeb :: AgentCtx -> IO ()
+shutdownWeb AgentCtx {..} = do
+    mThreadId <- readIORef appWebServerThreadId
+    for_ mThreadId $ \tid -> do
+        killThread tid
+        writeIORef appWebServerThreadId Nothing
+
+makeLogWare :: AgentCtx -> IO Middleware
+makeLogWare foundation = mkRequestLogger def
+    { outputFormat = if appDetailedRequestLogging $ appSettings foundation
+                         then Detailed True
+                         else Apache (if appIpFromHeader $ appSettings foundation then FromFallback else FromSocket)
+    , destination  = Logger $ loggerSet $ appLogger foundation
+    }
+
+-- | Warp settings for the given foundation value.
+warpSettings :: AgentCtx -> Settings
+warpSettings foundation =
+    setPort (fromIntegral . appPort $ appSettings foundation)
+        $ setHost (appHost $ appSettings foundation)
+        $ setOnException
+              (\_req e -> when (defaultShouldDisplayException e) $ messageLoggerSource
+                  foundation
+                  (appLogger foundation)
+                  $(qLocation >>= liftLoc)
+                  "yesod"
+                  LevelError
+                  (toLogStr $ "Exception from Warp: " ++ show e)
+              )
+              defaultSettings

agent/src/Model.hs

@@ -0,0 +1,62 @@
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE EmptyDataDecls        #-}
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoDeriveAnyClass      #-}
+{-# LANGUAGE QuasiQuotes           #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE UndecidableInstances  #-}
+module Model where
+
+import           Startlude
+
+import           Crypto.Hash
+import           Data.UUID
+import           Database.Persist.TH
+
+import           Lib.Types.Core
+import           Lib.Types.Emver
+import           Lib.Types.Emver.Orphans        ( )
+import           Orphans.Digest                 ( )
+import           Orphans.UUID                   ( )
+
+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
+Account
+   createdAt UTCTime
+   updatedAt UTCTime
+   name Text
+   password Text
+   UniqueAccount name
+
+ExecutedMigration
+    createdAt UTCTime
+    updatedAt UTCTime
+    srcVersion Version
+    tgtVersion Version
+    deriving Eq
+    deriving Show
+
+Notification json
+    Id UUID
+    createdAt UTCTime
+    archivedAt UTCTime Maybe
+    appId AppId
+    appVersion Version
+    code Text
+    title Text
+    message Text
+    deriving Eq
+    deriving Show
+
+BackupRecord sql=backup
+    Id UUID
+    createdAt UTCTime
+    appId AppId
+    appVersion Version
+    succeeded Bool
+
+IconDigest
+    Id AppId
+    tag (Digest MD5)
+|]

agent/src/Orphans/Digest.hs

@@ -0,0 +1,25 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Orphans.Digest where
+
+import           Startlude
+
+import           Crypto.Hash
+import           Data.ByteArray
+import           Data.ByteArray.Encoding
+import           Data.String.Interpolate.IsString
+import           Database.Persist.Sql
+import           Web.HttpApiData
+
+instance HashAlgorithm a => PersistField (Digest a) where
+    toPersistValue = PersistByteString . convert
+    fromPersistValue (PersistByteString bs) =
+        note [i|Invalid Digest: #{decodeUtf8 $ convertToBase Base16 bs}|] . digestFromByteString $ bs
+    fromPersistValue other = Left $ "Invalid Digest: " <> show other
+
+instance HashAlgorithm a => PersistFieldSql (Digest a) where
+    sqlType _ = SqlBlob
+
+instance HashAlgorithm a => ToHttpApiData (Digest a) where
+    toUrlPiece = decodeUtf8 . convertToBase Base16

agent/src/Orphans/UUID.hs

@@ -0,0 +1,18 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Orphans.UUID where
+
+import           Startlude
+
+import           Data.UUID
+import           Database.Persist.Sql
+import           Yesod.Core
+
+instance PathPiece UUID where
+    toPathPiece   = show
+    fromPathPiece = readMaybe
+instance PersistField UUID where
+    toPersistValue = PersistText . show
+    fromPersistValue (PersistText t) = note "Invalid UUID" $ readMaybe t
+    fromPersistValue other           = Left $ "Invalid UUID: " <> show other
+instance PersistFieldSql UUID where
+    sqlType _ = SqlString

agent/src/Settings.hs

@@ -0,0 +1,85 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+-- | Settings are centralized, as much as possible, into this file. This
+-- includes database connection settings, static file locations, etc.
+-- In addition, you can configure a number of different aspects of Yesod
+-- by overriding methods in the Yesod typeclass. That instance is
+-- declared in the Foundation.hs file.
+module Settings where
+
+import           Startlude
+
+import qualified Control.Effect.Labelled       as Fused
+import qualified Control.Exception             as Exception
+import           Data.Aeson
+import           Data.FileEmbed                 ( embedFile )
+import           Data.Yaml                      ( decodeEither' )
+import           Database.Persist.Sqlite        ( SqliteConf(..) )
+import           Network.Wai.Handler.Warp       ( HostPreference )
+import           Yesod.Default.Config2          ( applyEnvValue
+                                                , configSettingsYml
+                                                )
+import           Lib.Types.Emver
+import           Lib.Types.Emver.Orphans        ( )
+
+-- | Runtime settings to configure this application. These settings can be
+-- loaded from various sources: defaults, environment variables, config files,
+-- theoretically even a database.
+data AppSettings = AppSettings
+    { appDatabaseConf           :: SqliteConf
+    -- ^ Configuration settings for accessing the database.
+    , appHost                   :: HostPreference
+    -- ^ Host/interface the server should bind to.
+    , appPort                   :: Word16
+    -- ^ Port to listen on
+    , appIpFromHeader           :: Bool
+    -- ^ Get the IP address from the header when logging. Useful when sitting
+    -- behind a reverse proxy.
+    , appDetailedRequestLogging :: Bool
+    -- ^ Use detailed request logging system
+    , appShouldLogAll           :: Bool
+    -- ^ Should all log messages be displayed?
+    , appMgrVersionSpec         :: VersionRange
+    , appFilesystemBase         :: Text
+    , appCorsOverrideStar       :: Maybe Text
+    }
+    deriving Show
+
+instance FromJSON AppSettings where
+    parseJSON = withObject "AppSettings" $ \o -> do
+        appDatabaseConf <- o .: "database" >>= withObject
+            "database conf"
+            (\db -> do
+                dbName   <- db .: "database"
+                poolSize <- db .: "poolsize"
+                pure $ SqliteConf dbName poolSize
+            )
+
+        appHost                   <- fromString <$> o .: "host"
+        appPort                   <- o .: "port"
+        appIpFromHeader           <- o .: "ip-from-header"
+
+        appDetailedRequestLogging <- o .:? "detailed-logging" .!= False
+        appShouldLogAll           <- o .:? "should-log-all" .!= False
+
+        appMgrVersionSpec         <- o .: "app-mgr-version-spec"
+        appFilesystemBase         <- o .: "filesystem-base"
+        appCorsOverrideStar       <- o .:? "cors-override-star"
+        return AppSettings { .. }
+
+-- | Raw bytes at compile time of @config/settings.yml@
+configSettingsYmlBS :: ByteString
+configSettingsYmlBS = $(embedFile configSettingsYml)
+
+-- | @config/settings.yml@, parsed to a @Value@.
+configSettingsYmlValue :: Value
+configSettingsYmlValue = either Exception.throw id $ decodeEither' configSettingsYmlBS
+
+-- | A version of @AppSettings@ parsed at compile time from @config/settings.yml@.
+compileTimeAppSettings :: AppSettings
+compileTimeAppSettings = case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of
+    Error   e        -> panic $ toS e
+    Success settings -> settings
+
+injectSettings :: Monad m => AppSettings -> Fused.Labelled "appSettings" (ReaderT AppSettings) m a -> m a
+injectSettings s = flip runReaderT s . Fused.runLabelled @"appSettings"

agent/src/Startlude.hs

@@ -0,0 +1,128 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Startlude
+    ( module X
+    , module Startlude
+    )
+where
+
+import           Control.Arrow                 as X
+                                                ( (&&&) )
+import           Control.Comonad               as X
+import           Control.Monad.Trans.Maybe     as X
+import           Control.Error.Util            as X
+                                         hiding ( (??) )
+import           Data.Coerce                   as X
+import           Data.String                   as X
+                                                ( String
+                                                , fromString
+                                                )
+import           Data.Time.Clock               as X
+import           Protolude                     as X
+                                         hiding ( bool
+                                                , hush
+                                                , isLeft
+                                                , isRight
+                                                , note
+                                                , tryIO
+                                                , readMaybe
+                                                , (:+:)
+                                                , throwError
+                                                , toTitle
+                                                , toStrict
+                                                , toUpper
+                                                , Handler(..)
+                                                , yield
+                                                , type (==)
+                                                )
+import qualified Protolude                     as P
+                                                ( readMaybe )
+
+-- not reexported
+import           Control.Monad.Logger
+import           Control.Monad.Trans.Resource
+import qualified Control.Carrier.Lift          as FE
+import qualified Control.Carrier.Reader        as FE
+import qualified Control.Carrier.Error.Church  as FE
+import qualified Control.Effect.Labelled       as FE
+import           Data.Singletons.Prelude.Eq     ( PEq )
+import           Yesod.Core                     ( MonadHandler(..) )
+import           Control.Monad.Trans.Control
+import           Control.Monad.Base
+
+id :: a -> a
+id = identity
+
+ioLogFailure :: Exception e => String -> e -> IO ()
+ioLogFailure t e = putStrLn @Text (toS t <> show e) >> pure ()
+
+readMaybe :: Read a => Text -> Maybe a
+readMaybe = P.readMaybe . toS
+
+-- orphans for stitching fused effects into the larger ecosystem
+instance MonadResource (sub m) => MonadResource (FE.Labelled label sub m) where
+    liftResourceT = FE.Labelled . liftResourceT
+instance MonadResource m => MonadResource (FE.LiftC m) where
+    liftResourceT = FE.LiftC . liftResourceT
+instance MonadResource m => MonadResource (FE.ReaderC r m)  where
+    liftResourceT = lift . liftResourceT
+instance MonadResource m => MonadResource (FE.ErrorC e m) where
+    liftResourceT = lift . liftResourceT
+
+
+instance MonadThrow (sub m) => MonadThrow (FE.Labelled label sub m) where
+    throwM = FE.Labelled . throwM
+instance MonadThrow m => MonadThrow (FE.LiftC m) where
+    throwM = FE.LiftC . throwM
+
+instance MonadLogger m => MonadLogger (FE.LiftC m) where
+instance MonadLogger (sub m) => MonadLogger (FE.Labelled label sub m) where
+    monadLoggerLog a b c d = FE.Labelled $ monadLoggerLog a b c d
+
+instance MonadHandler m => MonadHandler (FE.LiftC m) where
+    type HandlerSite (FE.LiftC m) = HandlerSite m
+    type SubHandlerSite (FE.LiftC m) = SubHandlerSite m
+    liftHandler    = FE.LiftC . liftHandler
+    liftSubHandler = FE.LiftC . liftSubHandler
+
+instance MonadHandler (sub m) => MonadHandler (FE.Labelled label sub m) where
+    type HandlerSite (FE.Labelled label sub m) = HandlerSite (sub m)
+    type SubHandlerSite (FE.Labelled label sub m) = SubHandlerSite (sub m)
+    liftHandler    = FE.Labelled . liftHandler
+    liftSubHandler = FE.Labelled . liftSubHandler
+
+instance MonadTransControl t => MonadTransControl (FE.Labelled k t) where
+    type StT (FE.Labelled k t) a = StT t a
+    liftWith f = FE.Labelled $ liftWith $ \run -> f (run . FE.runLabelled)
+    restoreT = FE.Labelled . restoreT
+instance MonadBase IO (t m) => MonadBase IO (FE.Labelled k t m) where
+    liftBase = FE.Labelled . liftBase
+instance MonadBaseControl IO (t m) => MonadBaseControl IO (FE.Labelled k t m) where
+    type StM (FE.Labelled k t m) a = StM (t m) a
+    liftBaseWith f = FE.Labelled $ liftBaseWith $ \run -> f (run . FE.runLabelled)
+    restoreM = FE.Labelled . restoreM
+instance MonadBase IO m => MonadBase IO (FE.LiftC m) where
+    liftBase = FE.LiftC . liftBase
+instance MonadTransControl FE.LiftC where
+    type StT (FE.LiftC) a = a
+    liftWith f = FE.LiftC $ f $ FE.runM
+    restoreT = FE.LiftC
+instance MonadBaseControl IO m => MonadBaseControl IO (FE.LiftC m) where
+    type StM (FE.LiftC m) a = StM m a
+    liftBaseWith = defaultLiftBaseWith
+    restoreM     = defaultRestoreM
+instance MonadBase IO m => MonadBase IO (FE.ErrorC e m) where
+    liftBase = liftBaseDefault
+instance MonadTransControl (FE.ErrorC e) where
+    type StT (FE.ErrorC e) a = Either e a
+    liftWith f = FE.ErrorC $ \_ leaf -> f (FE.runError (pure . Left) (pure . Right)) >>= leaf
+    restoreT m = FE.ErrorC $ \fail leaf -> m >>= \case
+        Left  e -> fail e
+        Right a -> leaf a
+instance MonadBaseControl IO m => MonadBaseControl IO (FE.ErrorC e m) where
+    type StM (FE.ErrorC e m) a = StM m (Either e a)
+    liftBaseWith = defaultLiftBaseWith
+    restoreM     = defaultRestoreM
+
+
+instance PEq Type -- DRAGONS? I may rue the day I decided to do this

agent/src/Startlude/ByteStream.hs

@@ -0,0 +1,13 @@
+-- {-# OPTIONS_GHC -fno-warn-unused-imports #-}
+module Startlude.ByteStream
+    ( module Startlude.ByteStream
+    , module BS
+    )
+where
+
+import           Data.ByteString.Streaming     as BS
+                                         hiding ( ByteString )
+import           Data.ByteString.Streaming     as X
+                                                ( ByteString )
+
+type ByteStream m = X.ByteString m

agent/src/Startlude/ByteStream/Char8.hs

@@ -0,0 +1,7 @@
+module Startlude.ByteStream.Char8
+    ( module X
+    )
+where
+
+import           Data.ByteString.Streaming.Char8
+                                               as X

agent/src/Util/Conduit.hs

@@ -0,0 +1,23 @@
+module Util.Conduit where
+
+import           Startlude
+
+import           Conduit
+import           Data.Text                     as T
+import           Data.Attoparsec.Text
+
+parseC :: MonadIO m => Parser b -> ConduitT Text b m ()
+parseC parser = fix $ \cont -> parseWith g parser "" >>= \case
+    Done rest result -> do
+        yield result
+        unless (T.null rest) $ leftover rest >> cont
+    Fail _ _ msg -> panic $ toS msg
+    Partial _    -> panic "INCOMPLETE PARSE"
+    where
+        g :: MonadIO m => ConduitT Text o m Text
+        g = await >>= \case
+            Nothing -> pure mempty
+            Just x  -> print x >> pure x
+
+lineParser :: Parser Text
+lineParser = takeTill isEndOfLine <* endOfLine

agent/src/Util/File.hs

@@ -0,0 +1,12 @@
+module Util.File where
+
+import           Startlude
+
+import           System.Directory
+import           System.IO.Error
+
+removeFileIfExists :: MonadIO m => FilePath -> m ()
+removeFileIfExists fileName = liftIO $ removeFile fileName `catch` handleExists
+    where
+        handleExists e | isDoesNotExistError e = return ()
+                       | otherwise             = throwIO e

agent/src/Util/Function.hs

@@ -0,0 +1,16 @@
+module Util.Function where
+
+import           Startlude
+
+infixr 9 .*
+(.*) :: (b -> c) -> (a0 -> a1 -> b) -> a0 -> a1 -> c
+(.*) = (.) . (.)
+{-# INLINE (.*) #-}
+
+infixr 9 .**
+(.**) :: (b -> c) -> (a0 -> a1 -> a2 -> b) -> a0 -> a1 -> a2 -> c
+(.**) = (.) . (.*)
+{-# INLINE (.**) #-}
+
+uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
+uncurry3 f (a, b, c) = f a b c

agent/src/Util/Text.hs

@@ -0,0 +1,24 @@
+module Util.Text where
+
+import           Data.Text                      ( strip )
+import           Startlude
+import           Text.Regex                     ( matchRegexAll
+                                                , mkRegex
+                                                , subRegex
+                                                )
+
+
+-- | Behaves like Ruby gsub implementation
+gsub :: Text -> Text -> Text -> Text
+gsub regex replaceWith str = toS $ subRegex (mkRegex $ toS regex) (toS str) (toS replaceWith)
+
+containsMatch :: Text -> Text -> Bool
+containsMatch regex str = not . null $ getMatches regex str
+
+getMatches :: Text -> Text -> [Text]
+getMatches regex str
+    | str == "" = []
+    | otherwise = case matchRegexAll (mkRegex $ toS regex) (toS str) of
+        Nothing                   -> []
+        Just (_, ""   , after, _) -> getMatches regex (toS . strip . toS $ after)
+        Just (_, match, after, _) -> toS match : getMatches regex (toS after)