optional lan

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

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

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 { .. }

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
+