mirror of
https://github.com/Start9Labs/start-os.git
synced 2026-03-26 10:21:52 +00:00
125 lines
5.2 KiB
Haskell
125 lines
5.2 KiB
Haskell
{-# 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 Lib.Types.Emver
|
|
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
|
|
|
|
postWelcomeR :: Version -> Handler ()
|
|
postWelcomeR version = runDB $ repsert (WelcomeAckKey version) WelcomeAck
|
|
|
|
getSpecs :: MonadIO m => AppSettings -> S9ErrT m SpecsRes
|
|
getSpecs settings = do
|
|
specsCPU <- liftIO getCpuInfo
|
|
specsMem <- liftIO getMem
|
|
specsDisk <- fmap show . metricDiskSize <$> getDfMetrics
|
|
specsNetworkId <- runM $ injectFilesystemBaseFromContext settings getStart9AgentHostname
|
|
specsTorAddress <- runM $ injectFilesystemBaseFromContext settings getAgentHiddenServiceUrl
|
|
|
|
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
|