mirror of
https://github.com/Start9Labs/start-os.git
synced 2026-04-01 21:13:09 +00:00
0.2.5 initial commit
Makefile incomplete
This commit is contained in:
Aiden McClelland
196
agent/src/Lib/External/Registry.hs
vendored
Normal file
196
agent/src/Lib/External/Registry.hs
vendored
Normal file
@@ -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
|
||||
Reference in New Issue
Block a user