mirror of
https://github.com/Start9Labs/start-os.git
synced 2026-03-26 18:31:52 +00:00
optional lan
This commit is contained in:
Keagan McClelland
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
43
agent/src/Lib/External/AppManifest.hs
vendored
43
agent/src/Lib/External/AppManifest.hs
vendored
@@ -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 { .. }
|
||||
|
||||
Reference in New Issue
Block a user