Merge pull request #24 from Start9Labs/feature/app-endpoints

add routes for getting app config and manifest

.gitignore

@@ -28,3 +28,4 @@ agent_*
 agent.*
 version
 **/*.s9pk
+**/appmgr

config/routes

@@ -1,6 +1,9 @@
 
 
 /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
@@ -8,4 +11,5 @@
 
 /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}

config/settings.yml

@@ -32,6 +32,7 @@ resources-path: "_env:RESOURCES_PATH:/var/www/html/resources"
 ssl-path: "_env:SSL_PATH:/var/ssl"
 registry-hostname: "_env:REGISTRY_HOSTNAME:registry.start9labs.com"
 tor-port: "_env:TOR_PORT:447"
+static-bin-dir: "_env:STATIC_BIN:/usr/local/bin/"
 
 database:
   database: "_env:PG_DATABASE:start9_registry"

package.yaml

@@ -2,13 +2,15 @@ name: start9-registry
 version: 0.1.0
 
 default-extensions:
-- NoImplicitPrelude
+- FlexibleInstances
 - GeneralizedNewtypeDeriving
 - LambdaCase
 - MultiWayIf
 - NamedFieldPuns
+- NoImplicitPrelude
 - NumericUnderscores
 - OverloadedStrings
+- StandaloneDeriving
 
 dependencies:
 - base >=4.12 && <5
@@ -34,10 +36,12 @@ dependencies:
 - persistent-template
 - process
 - protolude
+- shakespeare
 - template-haskell
 - text
 - time
 - transformers
+- typed-process
 - unordered-containers
 - unix
 - wai

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,20 @@ getSysR e = do
     sysResourceDir <- (</> "sys") . resourcesDir . appSettings <$> getYesod
     getApp sysResourceDir e
 
+getAppManifestR :: Extension "s9pk" -> Text -> Handler TypedContent
+getAppManifestR e@(Extension appId) v = do
+    appMgrDir <- (<> "/") . staticBinDir . 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
+    appMgrDir <- (<> "/") . staticBinDir . 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

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
@@ -43,6 +52,8 @@ instance ToContent S9Error where
 toStatus :: S9Error -> Status
 toStatus = \case
     PersistentE _          -> status500
+    AppMgrE     _ _        -> status500
+
 
 handleS9ErrT :: MonadHandler m => S9ErrT m a -> m a
 handleS9ErrT action = runExceptT action >>= \case

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

src/Settings.hs

@@ -50,6 +50,7 @@ data AppSettings = AppSettings
     , sslCsrLocation            :: FilePath
     , sslCertLocation           :: FilePath
     , torPort                   :: AppPort
+    , staticBinDir              :: FilePath
     }
 
 instance FromJSON AppSettings where
@@ -64,6 +65,7 @@ instance FromJSON AppSettings where
         sslPath                   <- o .: "ssl-path"
         registryHostname          <- o .: "registry-hostname"
         torPort                   <- o .: "tor-port"
+        staticBinDir              <- o .: "static-bin-dir"
 
         let sslKeyLocation  = sslPath </> "key.pem"
         let sslCsrLocation  = sslPath </> "certificate.csr"

test/Handler/AppSpec.hs

@@ -72,3 +72,10 @@ spec = do
             statusIs 200
             apps <- runDBtest $ selectList ([] :: [Filter SApp])[]
             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" :: 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\":{}}"