diff --git a/.gitignore b/.gitignore index e5150ad..4e52e74 100644 --- a/.gitignore +++ b/.gitignore @@ -27,4 +27,5 @@ stack.yaml.lock agent_* agent.* version -**/*.s9pk \ No newline at end of file +**/*.s9pk +**/appmgr \ No newline at end of file diff --git a/config/routes b/config/routes index 3296dcf..4a2d706 100644 --- a/config/routes +++ b/config/routes @@ -1,11 +1,15 @@ -/apps AppsManifestR GET --get current apps listing +/apps AppsManifestR GET -- get current apps listing +/apps/#S9PK/#Text/manifest AppManifestR GET -- get app manifest from appmgr +/apps/#S9PK/#Text/config AppConfigR GET -- get app config from appmgr + /version VersionR GET -/apps/version/#Text VersionAppR GET --get most recent appId version -/sys/version/#Text VersionSysR GET --get most recent sys app version +/apps/version/#Text VersionAppR GET -- get most recent appId version +/sys/version/#Text VersionSysR GET -- get most recent sys app version /icons/#PNG IconsR GET -- get icons -!/apps/#S9PK AppR GET --get most recent appId at appversion spec, defaults to >=0.0.0 -- ?spec={semver-spec} -!/sys/#SYS_EXTENSIONLESS SysR GET --get most recent sys app -- ?spec={semver-spec} \ No newline at end of file +!/apps/#S9PK AppR GET -- get most recent appId at appversion spec, defaults to >=0.0.0 -- ?spec={semver-spec} + +!/sys/#SYS_EXTENSIONLESS SysR GET -- get most recent sys app -- ?spec={semver-spec} \ No newline at end of file diff --git a/package.yaml b/package.yaml index 7f9a284..8636379 100644 --- a/package.yaml +++ b/package.yaml @@ -9,6 +9,8 @@ default-extensions: - NamedFieldPuns - NumericUnderscores - OverloadedStrings +- StandaloneDeriving +- FlexibleInstances dependencies: - base >=4.12 && <5 @@ -49,6 +51,8 @@ dependencies: - yesod - yesod-core - yesod-persistent +- shakespeare +- typed-process library: source-dirs: src diff --git a/src/Handler/Apps.hs b/src/Handler/Apps.hs index a483a0c..3ab643b 100644 --- a/src/Handler/Apps.hs +++ b/src/Handler/Apps.hs @@ -40,6 +40,7 @@ import Lib.Types.AppIndex import Lib.Types.Semver import Lib.Types.FileSystem import Lib.Error +import Lib.External.AppMgr import Settings import Database.Queries import Network.Wai ( Request(requestHeaderUserAgent) ) @@ -85,6 +86,26 @@ getSysR e = do sysResourceDir <- ( "sys") . resourcesDir . appSettings <$> getYesod getApp sysResourceDir e +getAppManifestR :: Extension "s9pk" -> Text -> Handler TypedContent +getAppManifestR e@(Extension appId) v = do + appmgrVersion <- lookupGetParam "appmgr" >>= \case + Nothing -> sendResponseStatus status400 ("Appmgr version required" :: Text) + Just a -> pure $ toS a + appMgrDir <- (<> "/") . ( appmgrVersion) . ( "appmgr") . ( "sys") . resourcesDir . appSettings <$> getYesod + appDir <- (<> "/") . ( toS v) . ( appId) . ( "apps") . resourcesDir . appSettings <$> getYesod + manifest <- handleS9ErrT $ getManifest appMgrDir appDir e + pure $ TypedContent "application/json" (toContent manifest) + +getAppConfigR :: Extension "s9pk" -> Text -> Handler TypedContent +getAppConfigR e@(Extension appId) v = do + appmgrVersion <- lookupGetParam "appmgr" >>= \case + Nothing -> sendResponseStatus status400 ("Appmgr version required" :: Text) + Just a -> pure $ toS a + appMgrDir <- (<> "/") . ( appmgrVersion) . ( "appmgr") . ( "sys") . resourcesDir . appSettings <$> getYesod + appDir <- (<> "/") . ( toS v) . ( appId) . ( "apps") . resourcesDir . appSettings <$> getYesod + config <- handleS9ErrT $ getConfig appMgrDir appDir e + pure $ TypedContent "application/json" (toContent config) + getAppR :: Extension "s9pk" -> Handler TypedContent getAppR e = do appResourceDir <- ( "apps") . resourcesDir . appSettings <$> getYesod diff --git a/src/Lib/Error.hs b/src/Lib/Error.hs index db796f6..d30c496 100644 --- a/src/Lib/Error.hs +++ b/src/Lib/Error.hs @@ -1,14 +1,19 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE QuasiQuotes #-} + module Lib.Error where import Startlude import Network.HTTP.Types import Yesod.Core +import Data.String.Interpolate.IsString type S9ErrT m = ExceptT S9Error m -data S9Error = PersistentE Text +data S9Error = + PersistentE Text + | AppMgrE Text Int deriving (Show, Eq) instance Exception S9Error @@ -17,8 +22,12 @@ instance Exception S9Error toError :: S9Error -> Error toError = \case PersistentE t -> Error DATABASE_ERROR t + AppMgrE cmd code -> Error APPMGR_ERROR [i|"appmgr #{cmd}" exited with #{code}|] + +data ErrorCode = + DATABASE_ERROR + | APPMGR_ERROR -data ErrorCode = DATABASE_ERROR deriving (Eq, Show) instance ToJSON ErrorCode where toJSON = String . show @@ -42,7 +51,9 @@ instance ToContent S9Error where toStatus :: S9Error -> Status toStatus = \case - PersistentE _ -> status500 + PersistentE _ -> status500 + AppMgrE _ _ -> status500 + handleS9ErrT :: MonadHandler m => S9ErrT m a -> m a handleS9ErrT action = runExceptT action >>= \case diff --git a/src/Lib/External/AppMgr.hs b/src/Lib/External/AppMgr.hs new file mode 100644 index 0000000..7a246aa --- /dev/null +++ b/src/Lib/External/AppMgr.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Lib.External.AppMgr where + +import Startlude + +import qualified Data.ByteString.Lazy as LBS +import Data.String.Interpolate.IsString +import System.Process.Typed hiding ( createPipe ) + +import Lib.Error +import Lib.Registry + +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) + +getConfig :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m Text +getConfig appmgrPath appPath e@(Extension appId) = fmap decodeUtf8 $ do + (ec, out) <- readProcessInheritStderr (appmgrPath <> "appmgr") ["inspect", "info", appPath <> show e, "-C", "--json"] "" + case ec of + ExitSuccess -> pure out + ExitFailure n -> throwE $ AppMgrE [i|info #{appId} -C \--json|] n + +getManifest :: (MonadIO m, KnownSymbol a) => FilePath -> FilePath -> Extension a -> S9ErrT m ByteString +getManifest appmgrPath appPath e@(Extension appId) = do + (ec, bs) <- readProcessInheritStderr (appmgrPath <> "appmgr") ["inspect", "info", appPath <> show e, "-M", "--json"] "" + case ec of + ExitSuccess -> pure bs + ExitFailure n -> throwE $ AppMgrE [i|info -M #{appId} \--json|] n \ No newline at end of file diff --git a/test/Handler/AppSpec.hs b/test/Handler/AppSpec.hs index 135ca8c..0cdc379 100644 --- a/test/Handler/AppSpec.hs +++ b/test/Handler/AppSpec.hs @@ -71,4 +71,11 @@ spec = do setUrl ("/sys/agent?spec=0.0.0" :: Text) statusIs 200 apps <- runDBtest $ selectList ([] :: [Filter SApp])[] - assertEq "no apps should exist" (length apps) 0 \ No newline at end of file + assertEq "no apps should exist" (length apps) 0 + describe "GET /apps/#S9PK/#Text/manifest" $ + withApp $ it "gets bitcoin manifest" $ do + request $ do + setMethod "GET" + setUrl ("/apps/bitcoind.s9pk/0.2.5/manifest?appmgr=0.2.5" :: Text) + statusIs 200 + bodyContains "{\"id\":\"bitcoind\",\"version\":\"0.20.1\",\"title\":\"Bitcoin Core\",\"description\":{\"short\":\"Bitcoin Full Node by Bitcoin Core\",\"long\":\"Bitcoin is an innovative payment network and a new kind of money. Bitcoin uses peer-to-peer technology to operate with no central authority or banks; managing transactions and the issuing of bitcoins is carried out collectively by the network. Bitcoin is open-source; its design is public, nobody owns or controls Bitcoin and everyone can take part. Through many of its unique properties, Bitcoin allows exciting uses that could not be covered by any previous payment system.\"},\"release-notes\":\"https://github.com/bitcoin/bitcoin/blob/master/doc/release-notes/release-notes-0.20.1.md\",\"has-instructions\":true,\"os-version-required\":\">=0.2.4\",\"os-version-recommended\":\">=0.2.4\",\"ports\":[{\"internal\":8332,\"tor\":8332},{\"internal\":8333,\"tor\":8333}],\"image\":{\"type\":\"tar\"},\"mount\":\"/root/.bitcoin\",\"assets\":[{\"src\":\"bitcoin.conf.template\",\"dst\":\".\",\"overwrite\":true}],\"hidden-service-version\":\"v2\",\"dependencies\":{}}"