From adab9e7fca2b2abbf90de49e55c2b074ff5fa029 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Fri, 5 Mar 2021 12:14:13 -0700 Subject: [PATCH] optional lan --- agent/src/Handler/Apps.hs | 45 +++++++++------- agent/src/Handler/Types/Apps.hs | 6 ++- agent/src/Lib/External/AppManifest.hs | 43 +++++++++++++--- agent/test/Lib/External/AppManifestSpec.hs | 60 +++++++++++++++++++--- 4 files changed, 120 insertions(+), 34 deletions(-) diff --git a/agent/src/Handler/Apps.hs b/agent/src/Handler/Apps.hs index ad4f93bbc..e6548f550 100644 --- a/agent/src/Handler/Apps.hs +++ b/agent/src/Handler/Apps.hs @@ -7,29 +7,29 @@ {-# LANGUAGE TypeApplications #-} module Handler.Apps where -import Startlude hiding ( modify - , execState +import Startlude hiding ( Reader , asks - , Reader - , runReader , catchError - , forkFinally , empty + , execState + , forkFinally + , modify + , runReader ) -import Control.Carrier.Reader import Control.Carrier.Error.Church import Control.Carrier.Lift +import Control.Carrier.Reader 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 qualified Control.Exception.Lifted as Lifted import Control.Lens hiding ( (??) ) import Control.Monad.Logger import Control.Monad.Trans.Control ( MonadBaseControl ) @@ -38,13 +38,13 @@ import Data.Aeson import Data.Aeson.Lens import Data.Aeson.Types ( parseMaybe ) 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 Data.IORef import qualified Data.List.NonEmpty as NE import Data.Singletons -import Data.Singletons.Prelude.Bool ( SBool(..) - , If +import Data.Singletons.Prelude.Bool ( If + , SBool(..) ) import Data.Singletons.Prelude.List ( Elem ) import qualified Data.Text as Text @@ -55,8 +55,8 @@ import Exinst import Network.HTTP.Types import qualified Network.JSONRPC as JSONRPC import Yesod.Core.Content -import Yesod.Core.Json import Yesod.Core.Handler hiding ( cached ) +import Yesod.Core.Json import Yesod.Core.Types ( JSONResponse(..) ) import Yesod.Persist.Core @@ -70,9 +70,9 @@ import qualified Lib.Algebra.Domain.AppMgr as AppMgr2 import Lib.Algebra.State.RegistryUrl import Lib.Background import Lib.Error +import qualified Lib.External.AppManifest as AppManifest import qualified Lib.External.AppMgr as AppMgr import qualified Lib.External.Registry as Reg -import qualified Lib.External.AppManifest as AppManifest import Lib.IconCache import qualified Lib.Notifications as Notifications import Lib.SystemPaths @@ -249,19 +249,28 @@ getInstalledAppsLogic = do , appInstalledPreviewVersionInstalled = storeAppVersionInfoVersion , appInstalledPreviewTorAddress = Nothing , appInstalledPreviewLanAddress = Nothing - , appInstalledPreviewUi = False + , appInstalledPreviewTorUi = False + , appInstalledPreviewLanUi = False } installedPreviews = flip HML.mapWithKey remapped \appId (s, v, AppMgr2.InfoRes {..}) -> - let lanAddress = LanAddress . (".onion" `Text.replace` ".local") . unTorAddress <$> infoResTorAddress + let + mLanAddress = do -- Maybe + addrBase <- infoResTorAddress + let + lanConfs = mapMaybe AppManifest.portMapEntryLan + $ AppManifest.appManifestPortMapping infoResManifest + guard (not . null $ lanConfs) + pure $ LanAddress . (".onion" `Text.replace` ".local") . unTorAddress $ addrBase in AppInstalledPreview { appInstalledPreviewBase = AppBase appId infoResTitle (iconUrl appId v) - , appInstalledPreviewStatus = s + , appInstalledPreviewStatus = s , appInstalledPreviewVersionInstalled = v - , appInstalledPreviewTorAddress = infoResTorAddress - , appInstalledPreviewLanAddress = lanAddress - , appInstalledPreviewUi = AppManifest.uiAvailable infoResManifest + , appInstalledPreviewTorAddress = infoResTorAddress + , appInstalledPreviewLanAddress = mLanAddress + , appInstalledPreviewTorUi = AppManifest.torUiAvailable infoResManifest + , appInstalledPreviewLanUi = AppManifest.lanUiAvailable infoResManifest } pure $ HML.elems $ HML.union installingPreviews installedPreviews diff --git a/agent/src/Handler/Types/Apps.hs b/agent/src/Handler/Types/Apps.hs index 5265446c9..a9b2396f2 100644 --- a/agent/src/Handler/Types/Apps.hs +++ b/agent/src/Handler/Types/Apps.hs @@ -47,7 +47,8 @@ data AppInstalledPreview = AppInstalledPreview , appInstalledPreviewVersionInstalled :: Version , appInstalledPreviewTorAddress :: Maybe TorAddress , appInstalledPreviewLanAddress :: Maybe LanAddress - , appInstalledPreviewUi :: Bool + , appInstalledPreviewTorUi :: Bool + , appInstalledPreviewLanUi :: Bool } deriving (Eq, Show) instance ToJSON AppInstalledPreview where @@ -56,7 +57,8 @@ instance ToJSON AppInstalledPreview where , "versionInstalled" .= appInstalledPreviewVersionInstalled , "torAddress" .= (unTorAddress <$> appInstalledPreviewTorAddress) , "lanAddress" .= (unLanAddress <$> appInstalledPreviewLanAddress) - , "ui" .= appInstalledPreviewUi + , "torUi" .= appInstalledPreviewTorUi + , "lanUi" .= appInstalledPreviewLanUi ] data InstallNewAppReq = InstallNewAppReq diff --git a/agent/src/Lib/External/AppManifest.hs b/agent/src/Lib/External/AppManifest.hs index f14952c6f..5e9bafbc2 100644 --- a/agent/src/Lib/External/AppManifest.hs +++ b/agent/src/Lib/External/AppManifest.hs @@ -9,12 +9,12 @@ import Data.Aeson import qualified Data.HashMap.Strict as HM import qualified Data.Yaml as Yaml +import Control.Monad.Fail ( MonadFail(fail) ) 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) @@ -54,6 +54,7 @@ data Action = Action , actionWarning :: Maybe Text , actionAllowedStatuses :: [AppContainerStatus] } + deriving Show instance FromJSON Action where parseJSON = withObject "AppAction" $ \o -> do actionId <- o .: "id" @@ -80,7 +81,7 @@ data AppManifest where , appManifestDescShort :: Text , appManifestDescLong :: Text , appManifestReleaseNotes :: Text - , appManifestPortMapping :: HM.HashMap Word16 Word16 + , appManifestPortMapping :: [PortMapEntry] , appManifestImageType :: ImageType , appManifestMount :: FilePath , appManifestAssets :: [AssetMapping] @@ -91,9 +92,16 @@ data AppManifest where , appManifestStartAlert :: Maybe Text , appManifestActions :: [Action] } -> AppManifest +deriving instance Show AppManifest -uiAvailable :: AppManifest -> Bool -uiAvailable AppManifest {..} = isJust $ HM.lookup 80 appManifestPortMapping +torUiAvailable :: AppManifest -> Bool +torUiAvailable AppManifest {..} = any (== 80) $ portMapEntryTor <$> appManifestPortMapping + +lanUiAvailable :: AppManifest -> Bool +lanUiAvailable AppManifest {..} = any id $ fmap portMapEntryLan appManifestPortMapping <&> \case + Just Standard -> True + Just (Custom 443) -> True + _ -> False instance FromJSON AppManifest where parseJSON = withObject "App Manifest " $ \o -> do @@ -103,7 +111,7 @@ instance FromJSON AppManifest where appManifestDescShort <- o .: "description" >>= (.: "short") appManifestDescLong <- o .: "description" >>= (.: "long") appManifestReleaseNotes <- o .: "release-notes" - appManifestPortMapping <- o .: "ports" >>= fmap HM.fromList . traverse parsePortMapping + appManifestPortMapping <- o .: "ports" appManifestImageType <- o .: "image" >>= (.: "type") appManifestMount <- o .: "mount" appManifestAssets <- o .: "assets" >>= traverse parseJSON @@ -114,12 +122,31 @@ instance FromJSON AppManifest where appManifestStartAlert <- o .:? "start-alert" appManifestActions <- o .: "actions" pure $ AppManifest { .. } - where - parsePortMapping = withObject "Port Mapping" $ \o -> liftA2 (,) (o .: "tor") (o .: "internal") - parseDepInfo = withObject "Dep Info" $ (.: "version") + where parseDepInfo = withObject "Dep Info" $ (.: "version") getAppManifest :: (MonadIO m, HasFilesystemBase sig m) => AppId -> S9ErrT m (Maybe AppManifest) getAppManifest appId = do base <- ask @"filesystemBase" ExceptT $ first (ManifestParseE appId) <$> liftIO (Yaml.decodeFileEither . toS $ (appMgrAppPath appId <> "manifest.yaml") `relativeTo` base) + +data LanConfiguration = Standard | Custom Word16 deriving (Eq, Show) +instance FromJSON LanConfiguration where + parseJSON = liftA2 (<|>) standard custom + where + standard = + withText "Standard Lan" \t -> if t == "standard" then pure Standard else fail "Not Standard Lan Conf" + custom = withObject "Custom Lan" $ \o -> do + Custom <$> o .: "port" +data PortMapEntry = PortMapEntry + { portMapEntryInternal :: Word16 + , portMapEntryTor :: Word16 + , portMapEntryLan :: Maybe LanConfiguration + } + deriving (Eq, Show) +instance FromJSON PortMapEntry where + parseJSON = withObject "Port Map Entry" $ \o -> do + portMapEntryInternal <- o .: "internal" + portMapEntryTor <- o .: "tor" + portMapEntryLan <- o .:? "lan" + pure PortMapEntry { .. } diff --git a/agent/test/Lib/External/AppManifestSpec.hs b/agent/test/Lib/External/AppManifestSpec.hs index f0ac9ee50..c0448cffe 100644 --- a/agent/test/Lib/External/AppManifestSpec.hs +++ b/agent/test/Lib/External/AppManifestSpec.hs @@ -66,12 +66,60 @@ assets: hidden-service-version: v3 |] +mastodon330Manifest :: ByteString +mastodon330Manifest = [i| +--- +id: mastodon +version: 3.3.0.1 +title: Mastodon +description: + short: "A free, open-source social network server." + long: "Mastodon is a free, open-source social network server based on ActivityPub where users can follow friends and discover new ones. On Mastodon, users can publish anything they want: links, pictures, text, video. All Mastodon servers are interoperable as a federated network (users on one server can seamlessly communicate with users from another one, including non-Mastodon software that implements ActivityPub)!" +release-notes: Added an acation to reset the admin password +install-alert: "After starting mastodon for the first time, it can take a long time (several minutes) to be ready.\nPlease be patient. On future starts of the service, it will be faster, but still takes longer than other services.\nMake sure to sign up for a user before giving out your link. The first user to sign up is set as the admin user.\n" +uninstall-alert: ~ +restore-alert: ~ +start-alert: "It may take several minutes after startup for this service to be ready for use.\n" +has-instructions: true +os-version-required: ">=0.2.8" +os-version-recommended: ">=0.2.8" +ports: + - internal: 80 + tor: 80 + lan: standard + - internal: 3000 + tor: 3000 + lan: ~ + - internal: 4000 + tor: 4000 + lan: ~ +image: + type: tar +shm-size-mb: ~ +mount: /root/persistence +public: ~ +shared: ~ +assets: [] +hidden-service-version: v3 +dependencies: {} +actions: + - id: reset-admin-password + name: Reset Admin Password + description: This action will reset your admin password to a random value + allowed-statuses: + - RUNNING + command: + - docker_entrypoint.sh + - reset_admin_password.sh +|] + + spec :: Spec spec = do describe "parsing app manifest ports" $ do - it "should yield true for cups 0.2.3" $ do - res <- decodeThrow @IO @AppManifest cups023Manifest - uiAvailable res `shouldBe` True - it "should yield false for cups 0.2.3 Mod" $ do - res <- decodeThrow @IO @AppManifest cups023ManifestModNoUI - uiAvailable res `shouldBe` False + it "should parse mastodon 3.3.0" $ do + res <- decodeThrow @IO @AppManifest mastodon330Manifest + print res + lanUiAvailable res `shouldBe` True + torUiAvailable res `shouldBe` True +