salmon-apps 0.1.0.0 → 0.2.0.0

raw patch · 29 files changed

+8070/−293 lines, 29 filesdep +QuickCheckdep +asyncdep +networkdep ~salmon-opsdep ~salmon-ops-recipesnew-component:exe:salmon-cloudrunnew-component:exe:salmon-docs-syncnew-component:exe:salmon-pgvector-demonew-component:exe:salmon-reportPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, async, network, tasty-quickcheck

Dependency ranges changed: salmon-ops, salmon-ops-recipes

API changes (from Hackage documentation)

Files

• CHANGELOG.md +15/−1
• app/CloudrunApp.hs +6/−0
• app/DocsSyncApp.hs +6/−0
• app/PgVectorDemoApp.hs +6/−0
• app/ReportApp.hs +6/−0
• salmon-apps.cabal +65/−5
• src/Cloudrun.hs +958/−0
• src/DocsSync.hs +197/−0
• src/GcpToy.hs +692/−173
• src/Migrator/Ops.hs +13/−4
• src/PatroniRootfs.hs +5/−2
• src/PgPair.hs +110/−11
• src/PgVectorDemo.hs +240/−0
• src/QemuPgHaToy.hs +488/−92
• src/Report.hs +1083/−0
• src/Report/Dns.hs +325/−0
• src/Report/Hairpin.hs +469/−0
• src/Report/Inbound.hs +356/−0
• src/Report/Nmap.hs +216/−0
• src/Report/Stun.hs +329/−0
• src/Tui.hs +19/−4
• test/Main.hs +13/−1
• test/Test/CloudrunSpec.hs +524/−0
• test/Test/GcpToySpec.hs +248/−0
• test/Test/QemuPgHaToySpec.hs +181/−0
• test/Test/ReportHairpinSpec.hs +574/−0
• test/Test/ReportInboundSpec.hs +271/−0
• test/Test/ReportSpec.hs +641/−0
• test/fixtures/natpmpc-no-answer.txt +14/−0

@@ -1,5 +1,19 @@ # Revision history for salmon-apps -## 0.1.0.0 -- unreleased+## 0.2.0.0 -- unreleased++Breaking: exported functions of `GcpToy`, `PgPair` and `QemuPgHaToy` changed. Requires+`salmon-ops ^>=0.2.0.0` and `salmon-ops-recipes ^>=0.2.0.0`.++* New `salmon-cloudrun`: a Cloud Run turnup from one declarative file.+* New `salmon-pgvector-demo`: `SreBox.PgVectorDemo` as a binary, with a read-only `search`.+* New `salmon-report`: read-only capability probes (DNS setup, STUN mapping type, hairpin NAT,+  inbound reachability from a second vantage point, nmap on declared targets).+* New `salmon-docs-sync`: detect `docs/` drift, regenerate, commit and push.+* `salmon-tui`: a live tail of what a node writes.+* `salmon-gcp-toy`: load balancer, Cloud DNS and a quadlet-served tier; instance run limit.+* `salmon-toy-qemu-pg-ha`: a VM harness driven live through `run serve --http`.++## 0.1.0.0 -- 2026-10-01  * First release.

@@ -0,0 +1,6 @@+module Main (main) where++import qualified Cloudrun++main :: IO ()+main = Cloudrun.main

@@ -0,0 +1,6 @@+module Main where++import qualified DocsSync++main :: IO ()+main = DocsSync.main

@@ -0,0 +1,6 @@+module Main where++import qualified PgVectorDemo++main :: IO ()+main = PgVectorDemo.main

@@ -0,0 +1,6 @@+module Main where++import qualified Report++main :: IO ()+main = Report.main

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               salmon-apps-version:            0.1.0.0+version:            0.2.0.0 synopsis:           A set of utilities built with Salmon at their core. description:        Tools useful for operating systems, and which benefit from specialized implementations configured via external files: salmon-migrator, salmon-pgpair, salmon-fleet, salmon-tui and others. homepage:           https://lucasdicioccio.github.io/salmon/@@ -14,6 +14,7 @@ build-type:         Simple tested-with:        GHC == 9.10.3 extra-doc-files:    CHANGELOG.md+extra-source-files: test/fixtures/*.txt  source-repository head     type:     git@@ -30,7 +31,16 @@                     PatroniRootfs                     Initializer                     GcpToy+                    Cloudrun                     PgBackup+                    PgVectorDemo+                    DocsSync+                    Report+                    Report.Dns+                    Report.Hairpin+                    Report.Inbound+                    Report.Nmap+                    Report.Stun     other-modules:                     Migrator.Ops                     Migrator.Seed@@ -38,6 +48,7 @@      build-depends:    base >=4.16.3.0 && <4.22                     , aeson+                    , async                     , brick                     , bytestring                     , http-client@@ -45,12 +56,13 @@                     , directory                     , filepath                     , layoutz-hs+                    , network                     , optparse-applicative                     , optparse-generic                     , process                     , salmon-core ^>=0.1.0.0-                    , salmon-ops ^>=0.1.0.0-                    , salmon-ops-recipes ^>=0.1.0.0+                    , salmon-ops ^>=0.2.0.0+                    , salmon-ops-recipes ^>=0.2.0.0                     , text                     , time                     , vty@@ -128,6 +140,15 @@     ghc-options:      -threaded     default-language: Haskell2010 +executable salmon-pgvector-demo+    main-is:          PgVectorDemoApp.hs++    build-depends:    base >=4.16.3.0 && <4.22+                    , salmon-apps+    hs-source-dirs:   app+    ghc-options:      -threaded+    default-language: Haskell2010+ executable salmon-fleet     main-is:          FleetApp.hs @@ -146,6 +167,15 @@     ghc-options:      -threaded     default-language: Haskell2010 +executable salmon-cloudrun+    main-is:          CloudrunApp.hs++    build-depends:    base >=4.16.3.0 && <4.22+                    , salmon-apps+    hs-source-dirs:   app+    ghc-options:      -threaded+    default-language: Haskell2010+ executable salmon-tui     main-is:          TuiApp.hs @@ -160,16 +190,29 @@     type:             exitcode-stdio-1.0     main-is:          Main.hs     hs-source-dirs:   test-    other-modules:    Test.FleetSpec+    other-modules:    Test.CloudrunSpec+                    , Test.FleetSpec+                    , Test.GcpToySpec+                    , Test.QemuPgHaToySpec+                    , Test.ReportHairpinSpec+                    , Test.ReportInboundSpec+                    , Test.ReportSpec     build-depends:    base >=4.16.3.0 && <4.22+                    , QuickCheck                     , aeson                     , bytestring                     , directory                     , filepath+                    , containers+                    , process+                    , network                     , salmon-apps-                    , salmon-ops ^>=0.1.0.0+                    , salmon-core ^>=0.1.0.0+                    , salmon-ops-recipes ^>=0.2.0.0+                    , salmon-ops ^>=0.2.0.0                     , tasty                     , tasty-hunit+                    , tasty-quickcheck                     , temporary                     , text                     , time@@ -178,3 +221,20 @@     default-extensions: OverloadedStrings                       , OverloadedRecordDot                       , ScopedTypeVariables++executable salmon-report+    main-is:          ReportApp.hs+    build-depends:    base >=4.16.3.0 && <4.22+                    , salmon-apps+    hs-source-dirs:   app+    ghc-options:      -threaded+    default-language: Haskell2010++executable salmon-docs-sync+    main-is:          DocsSyncApp.hs++    build-depends:    base >=4.16.3.0 && <4.22+                    , salmon-apps+    hs-source-dirs:   app+    ghc-options:      -threaded+    default-language: Haskell2010

@@ -0,0 +1,958 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++{- | A Cloud Run turnup from one declarative file: the services, what each+runs as, its plain environment, the Secret Manager secrets bound to it, and+optionally a regional external Application Load Balancer in front.++> salmon-cloudrun config --file turnup.json | salmon-cloudrun run tree+> salmon-cloudrun config --file turnup.json | salmon-cloudrun run up+> salmon-cloudrun config --file turnup.json | salmon-cloudrun run down++The file is JSON (anything that prints JSON will do for writing it):++> {+>   "name": "acme",+>   "project": "acme-prod",+>   "region": "europe-west1",+>   "secrets": [+>     {"name": "acme-db-password", "source_file": "secrets/db-password"}+>   ],+>   "services": [+>     {+>       "name": "acme-api",+>       "image": "europe-west1-docker.pkg.dev/acme-prod/acme/api:1.4.2",+>       "service_account": {"create": "acme-api"},+>       "env": {"LOG_LEVEL": "info"},+>       "bind_secrets": [+>         {"env": "DB_PASSWORD", "secret": "acme-db-password"},+>         {"file": "/secrets/tls/key.pem", "secret": "acme-tls-key", "version": "3"}+>       ],+>       "ingress": "internal-and-cloud-load-balancing",+>       "invoker": "no-iam-check"+>     }+>   ],+>   "load_balancer": {+>     "name": "acme-lb",+>     "proxy_subnet": {"name": "acme-proxy", "range": "192.168.100.0/24"},+>     "default_service": "acme-api"+>   }+> }++The directive @config@ prints is that same declaration, checked and with+every default written out; there is nothing to resolve later, so what+@run up@ reads is what the operator can read.++== What is declared++* __Services__ are deployed from an image that is already in a registry.+  Building and pushing is not this binary's ("SreBox.Gcp.CloudRunDeploy" is+  the recipe for that).+* __Service accounts__: @{"create": ID}@ makes the account in the project,+  @{"email": ADDRESS}@ names one that exists.+* __Secrets__ come in two places. The top-level @secrets@ are the ones this+  turnup /makes/: the secret, and with a @source_file@ its latest version,+  uploaded when the file's bytes differ from it. @bind_secrets@ is what a+  service /sees/, as an environment variable or as a file; the secret it+  names is one of those or one that exists already. A service's account is+  granted @roles\/secretmanager.secretAccessor@ on every secret bound to it+  (@grant_secret_access: false@ when somebody else does the granting).+* The __load balancer__ is a regional external Application Load Balancer+  ("Salmon.Builtin.Nodes.Gcp.LoadBalancing") with one serverless backend per+  service it routes to. HTTPS takes regional @compute ssl-certificates@ that+  exist already, by name.++== Secrets++No secret byte is in the file, in the directive, in a node's text or in a+command line. A @source_file@ is a path on the machine that runs @run up@,+read when the upload node runs or checks. How the file got there is not this+binary's business.++== What @run down@ removes, and what it keeps++It deletes what can be proved to be this turnup's and holds no data: the+Cloud Run services, which carry the label @salmon-turnup=NAME@ from the+deploy that made them (a service of the same name without it is neither+deployed over nor deleted, see 'CloudRun.OwnerLabel'), and the balancer's+resources, which are named after the balancer.++It keeps everything else: the secrets and their versions, the service+accounts, the IAM grants, the proxy-only subnet and the enabled APIs. None+of those carries a mark saying who made it, a secret is data, and the others+may be shared with what this file does not describe. Their nodes say so.++__Layer 0 only.__ Nothing here has been run against a real project; see+@resources\/module-notes.md@ for what was tested and for what a live run+still has to cover.+-}+module Cloudrun (+    main,+    Seed (..),+    configure,+    program,++    -- * The declaration+    Turnup (..),+    ManagedSecret (..),+    Service (..),+    ServiceIdentity (..),+    Invoker (..),+    SecretBinding (..),+    BindingTarget (..),+    LoadBalancer (..),+    ProxySubnet (..),+    HostRoute (..),+    PathRoute (..),+    HttpMode (..),+    parseTurnup,+    loadTurnup,+    turnupProblems,++    -- * What it becomes+    turnupOp,+    cloudRunServiceOf,+    balancerOf,+    accountEmail,+    ownerLabel,+    keptNote,+) where++import Control.Exception (Exception, throwIO)+import Data.Aeson (FromJSON (..), ToJSON (..), Value, eitherDecode, object, withObject, withText, (.!=), (.:), (.:?), (.=))+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import Data.Aeson.Types (Object, Pair, Parser)+import qualified Data.ByteString.Lazy as LByteString+import Data.Char (isAsciiLower, isAsciiUpper, isDigit)+import Data.List (nub, (\\))+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (catMaybes)+import Data.Text (Text)+import qualified Data.Text as Text+import Options.Applicative (execParser, fullDesc, header, help, helper, info, long, metavar, progDesc, strOption, (<**>))+import Options.Generic (ParseRecord (..))+import System.Directory (makeAbsolute)+import System.FilePath (isAbsolute, takeDirectory, (</>))++import Salmon.Actions.UpDown (CheckResult (..))+import qualified Salmon.Actions.Serve as Serve+import qualified Salmon.Builtin.CommandLine as CLI+import Salmon.Builtin.Extension (Extension, Op, Track', amendNode, check, deps, down, nodeps, notes, op, ref, up)+import qualified Salmon.Builtin.Extension as Extension+import qualified Salmon.Builtin.Nodes.Gcp.CloudRun as CloudRun+import qualified Salmon.Builtin.Nodes.Gcp.Compute as Compute+import qualified Salmon.Builtin.Nodes.Gcp.Core as Core+import qualified Salmon.Builtin.Nodes.Gcp.Iam as Iam+import qualified Salmon.Builtin.Nodes.Gcp.LoadBalancing as LoadBalancing+import qualified Salmon.Builtin.Nodes.Gcp.SecretManager as SecretManager+import qualified Salmon.Builtin.Nodes.Gcp.ServiceUsage as ServiceUsage+import Salmon.Op.Configure (Configure (..))+import Salmon.Op.OpGraph (OpGraph (..), inject)+import Salmon.Op.Ref (Ref, mkRef)+import Salmon.Op.Track (Track (..))+import Salmon.Reporter (reportPrint)++-------------------------------------------------------------------------------++main :: IO ()+main = do+    let desc =+            fullDesc+                <> progDesc "Cloud Run services, their secrets and environment, and a load balancer in front, from one declarative file"+                <> header "salmon-cloudrun"+    cmd <- execParser (info parseRecord desc)+    CLI.execCommandOrSeedWith Serve.reportText reportPrint configure program cmd++-- | The directive is the declaration itself: there is nothing to resolve later.+program :: Track' Turnup+program = Track turnupOp++-- | What an operator types: where the declaration is.+newtype Seed = Seed {seedFile :: FilePath}++instance ParseRecord Seed where+    parseRecord = (Seed <$> strOption (long "file" <> metavar "PATH" <> help "the turnup's declaration, as JSON")) <**> helper++{- | Reads the file and refuses a declaration with something wrong in it,+before anything is printed that a @run up@ could act on.+-}+configure :: Configure IO Seed Turnup+configure = Configure $ \seed -> do+    result <- loadTurnup seed.seedFile+    case result of+        Left why -> throwIO (userError ("salmon-cloudrun: " <> why))+        Right turnup -> pure turnup++{- | The declaration in a file, or everything that is wrong with it.++A relative @source_file@ is taken from the declaration's own directory, so+the directive names the same file wherever @run up@ is started from.+-}+loadTurnup :: FilePath -> IO (Either String Turnup)+loadTurnup path = do+    bytes <- LByteString.readFile path+    home <- takeDirectory <$> makeAbsolute path+    pure $ do+        turnup <- anchored home <$> parseTurnup bytes+        case turnupProblems turnup of+            [] -> Right turnup+            problems -> Left (Text.unpack (Text.intercalate "; " problems))+  where+    anchored home t = t{turnupSecrets = map (anchor home) t.turnupSecrets}+    anchor home s = s{msSourceFile = fmap (\f -> if isAbsolute f then f else home </> f) s.msSourceFile}++-- | The declaration in some JSON, with no opinion yet on whether it holds together.+parseTurnup :: LByteString.ByteString -> Either String Turnup+parseTurnup = eitherDecode++-------------------------------------------------------------------------------+-- The declaration++data Turnup = Turnup+    { turnupName :: Text+    -- ^ what the turnup is called: the value of the label its services+    -- carry, so GCP's label rules apply+    , turnupProject :: Text+    , turnupRegion :: Text+    , turnupAccount :: Maybe Text+    -- ^ the account @gcloud@ must be acting as, asserted before anything+    -- else ('Core.declaredAccount'); 'Nothing' asserts nothing+    , turnupEnableApis :: Bool+    -- ^ whether the APIs the declaration needs are enabled by it+    , turnupSecrets :: [ManagedSecret]+    , turnupServices :: [Service]+    , turnupLoadBalancer :: Maybe LoadBalancer+    }+    deriving (Eq, Show)++-- | A secret this turnup makes.+data ManagedSecret = ManagedSecret+    { msName :: Text+    , msReplication :: Text+    -- ^ @automatic@ unless said otherwise+    , msSourceFile :: Maybe FilePath+    -- ^ a file, on the machine running @run up@, whose bytes the secret's+    -- latest version must hold. 'Nothing': the secret is made and its+    -- versions are somebody else's.+    }+    deriving (Eq, Show)++data Service = Service+    { svcName :: Text+    , svcImage :: Text+    , svcAccount :: ServiceIdentity+    , svcEnv :: Map Text Text+    , svcSecrets :: [SecretBinding]+    , svcGrantSecretAccess :: Bool+    , svcIngress :: CloudRun.IngressSetting+    , svcInvoker :: Invoker+    , svcCpu :: Maybe Text+    , svcMemory :: Maybe Text+    , svcConcurrency :: Maybe Int+    , svcTimeoutSeconds :: Maybe Int+    , svcPort :: Maybe Int+    , svcMinInstances :: Maybe Int+    , svcMaxInstances :: Maybe Int+    , svcCpuAlwaysAllocated :: Bool+    }+    deriving (Eq, Show)++-- | Who a service runs as.+data ServiceIdentity+    = -- | an account id; the account is made in the turnup's project+      CreateAccount Text+    | -- | the address of an account that exists+      ExistingAccount Text+    deriving (Eq, Show)++{- | Who may call a service. 'InvokerIam' passes nothing and leaves the+service as Cloud Run makes it (callers need @roles\/run.invoker@); the other+two are 'CloudRun.croAllowUnauthenticated' and+'CloudRun.croInvokerIamCheckDisabled', which see for which one an+organization lets through. A service behind the balancer is called by+anonymous clients, so it wants one of those two.+-}+data Invoker+    = InvokerIam+    | InvokerAllUsers+    | InvokerNoIamCheck+    deriving (Eq, Show)++-- | A secret a service sees, and where.+data SecretBinding = SecretBinding+    { sbTarget :: BindingTarget+    , sbSecret :: Text+    , sbVersion :: Text+    -- ^ @latest@ unless said otherwise+    }+    deriving (Eq, Show)++data BindingTarget+    = EnvVar Text+    | -- | an absolute path in the container+      MountedFile FilePath+    deriving (Eq, Show)++data LoadBalancer = LoadBalancer+    { lbName :: Text+    , lbNetwork :: Maybe Text+    -- ^ the VPC network; 'Nothing' is GCP's @default@+    , lbProxySubnet :: Maybe ProxySubnet+    -- ^ the proxy-only subnet such a balancer needs in its network and+    -- region. 'Nothing' when the network has one already: there can be only+    -- one per network and region.+    , lbDefaultService :: Text+    -- ^ where a request goes that no host rule claims+    , lbHosts :: [HostRoute]+    , lbCertificates :: [Text]+    -- ^ regional @compute ssl-certificates@ that exist; non-empty also+    -- serves HTTPS+    , lbHttp :: Maybe HttpMode+    -- ^ 'Nothing' is the balancer module's own default for port 80+    }+    deriving (Eq, Show)++data ProxySubnet = ProxySubnet+    { psName :: Text+    , psRange :: Text+    }+    deriving (Eq, Show)++data HostRoute = HostRoute+    { hrHosts :: [Text]+    , hrService :: Text+    , hrPaths :: [PathRoute]+    }+    deriving (Eq, Show)++data PathRoute = PathRoute+    { prPaths :: [Text]+    , prService :: Text+    }+    deriving (Eq, Show)++data HttpMode+    = HttpServe+    | HttpRedirectToHttps+    | HttpNone+    deriving (Eq, Show)++-------------------------------------------------------------------------------+-- JSON++{- | An object with these keys and no other. A misspelt key in a file like+this one is a setting silently not applied, so it is refused instead.+-}+objectOf :: String -> [Text] -> (Object -> Parser a) -> Value -> Parser a+objectOf what allowed f = withObject what $ \o ->+    case map Key.toText (KeyMap.keys o) \\ allowed of+        [] -> f o+        unknown -> fail (what <> ": unknown key " <> Text.unpack (Text.intercalate ", " unknown))++-- | The pairs that have a value: an absent setting is an absent key.+objectWith :: [Maybe Pair] -> Value+objectWith = object . catMaybes++always :: (ToJSON v) => Text -> v -> Maybe Pair+always k v = Just (Key.fromText k .= v)++whenSet :: (ToJSON v) => Text -> Maybe v -> Maybe Pair+whenSet k = fmap (Key.fromText k .=)++instance FromJSON Turnup where+    parseJSON =+        objectOf "turnup" ["name", "project", "region", "account", "enable_apis", "secrets", "services", "load_balancer"] $ \o ->+            Turnup+                <$> o .: "name"+                <*> o .: "project"+                <*> o .: "region"+                <*> o .:? "account"+                <*> o .:? "enable_apis" .!= True+                <*> o .:? "secrets" .!= []+                <*> o .: "services"+                <*> o .:? "load_balancer"++instance ToJSON Turnup where+    toJSON t =+        objectWith+            [ always "name" t.turnupName+            , always "project" t.turnupProject+            , always "region" t.turnupRegion+            , whenSet "account" t.turnupAccount+            , always "enable_apis" t.turnupEnableApis+            , always "secrets" t.turnupSecrets+            , always "services" t.turnupServices+            , whenSet "load_balancer" t.turnupLoadBalancer+            ]++instance FromJSON ManagedSecret where+    parseJSON =+        objectOf "secret" ["name", "replication", "source_file"] $ \o ->+            ManagedSecret+                <$> o .: "name"+                <*> o .:? "replication" .!= "automatic"+                <*> o .:? "source_file"++instance ToJSON ManagedSecret where+    toJSON s =+        objectWith+            [ always "name" s.msName+            , always "replication" s.msReplication+            , whenSet "source_file" s.msSourceFile+            ]++instance FromJSON Service where+    parseJSON =+        objectOf+            "service"+            [ "name"+            , "image"+            , "service_account"+            , "env"+            , "bind_secrets"+            , "grant_secret_access"+            , "ingress"+            , "invoker"+            , "cpu"+            , "memory"+            , "concurrency"+            , "timeout_seconds"+            , "port"+            , "min_instances"+            , "max_instances"+            , "cpu_always_allocated"+            ]+            $ \o ->+                Service+                    <$> o .: "name"+                    <*> o .: "image"+                    <*> o .: "service_account"+                    <*> o .:? "env" .!= Map.empty+                    <*> o .:? "bind_secrets" .!= []+                    <*> o .:? "grant_secret_access" .!= True+                    <*> (maybe (pure CloudRun.All) parseIngress =<< o .:? "ingress")+                    <*> o .:? "invoker" .!= InvokerIam+                    <*> o .:? "cpu"+                    <*> o .:? "memory"+                    <*> o .:? "concurrency"+                    <*> o .:? "timeout_seconds"+                    <*> o .:? "port"+                    <*> o .:? "min_instances"+                    <*> o .:? "max_instances"+                    <*> o .:? "cpu_always_allocated" .!= False++instance ToJSON Service where+    toJSON s =+        objectWith+            [ always "name" s.svcName+            , always "image" s.svcImage+            , always "service_account" s.svcAccount+            , always "env" s.svcEnv+            , always "bind_secrets" s.svcSecrets+            , always "grant_secret_access" s.svcGrantSecretAccess+            , always "ingress" (ingressText s.svcIngress)+            , always "invoker" s.svcInvoker+            , whenSet "cpu" s.svcCpu+            , whenSet "memory" s.svcMemory+            , whenSet "concurrency" s.svcConcurrency+            , whenSet "timeout_seconds" s.svcTimeoutSeconds+            , whenSet "port" s.svcPort+            , whenSet "min_instances" s.svcMinInstances+            , whenSet "max_instances" s.svcMaxInstances+            , always "cpu_always_allocated" s.svcCpuAlwaysAllocated+            ]++ingressText :: CloudRun.IngressSetting -> Text+ingressText = \case+    CloudRun.All -> "all"+    CloudRun.Internal -> "internal"+    CloudRun.InternalAndLoadBalancing -> "internal-and-cloud-load-balancing"++parseIngress :: Value -> Parser CloudRun.IngressSetting+parseIngress = withText "ingress" $ \case+    "all" -> pure CloudRun.All+    "internal" -> pure CloudRun.Internal+    "internal-and-cloud-load-balancing" -> pure CloudRun.InternalAndLoadBalancing+    other -> fail ("ingress: all, internal or internal-and-cloud-load-balancing, not " <> Text.unpack other)++instance FromJSON ServiceIdentity where+    parseJSON =+        objectOf "service_account" ["create", "email"] $ \o -> do+            create <- o .:? "create"+            email <- o .:? "email"+            case (create, email) of+                (Just accountId, Nothing) -> pure (CreateAccount accountId)+                (Nothing, Just address) -> pure (ExistingAccount address)+                _ -> fail "service_account: exactly one of create (an account id to make) and email (an account that exists)"++instance ToJSON ServiceIdentity where+    toJSON = \case+        CreateAccount accountId -> object ["create" .= accountId]+        ExistingAccount address -> object ["email" .= address]++instance FromJSON Invoker where+    parseJSON = withText "invoker" $ \case+        "iam" -> pure InvokerIam+        "all-users" -> pure InvokerAllUsers+        "no-iam-check" -> pure InvokerNoIamCheck+        other -> fail ("invoker: iam, all-users or no-iam-check, not " <> Text.unpack other)++instance ToJSON Invoker where+    toJSON = \case+        InvokerIam -> "iam"+        InvokerAllUsers -> "all-users"+        InvokerNoIamCheck -> "no-iam-check"++instance FromJSON SecretBinding where+    parseJSON =+        objectOf "secret binding" ["env", "file", "secret", "version"] $ \o -> do+            var <- o .:? "env"+            file <- o .:? "file"+            target <- case (var, file) of+                (Just v, Nothing) -> pure (EnvVar v)+                (Nothing, Just f) -> pure (MountedFile f)+                _ -> fail "secret binding: exactly one of env (a variable) and file (a path in the container)"+            SecretBinding target <$> o .: "secret" <*> o .:? "version" .!= "latest"++instance ToJSON SecretBinding where+    toJSON b =+        object+            [ case b.sbTarget of+                EnvVar v -> "env" .= v+                MountedFile f -> "file" .= f+            , "secret" .= b.sbSecret+            , "version" .= b.sbVersion+            ]++instance FromJSON LoadBalancer where+    parseJSON =+        objectOf "load_balancer" ["name", "network", "proxy_subnet", "default_service", "hosts", "certificates", "http"] $ \o ->+            LoadBalancer+                <$> o .: "name"+                <*> o .:? "network"+                <*> o .:? "proxy_subnet"+                <*> o .: "default_service"+                <*> o .:? "hosts" .!= []+                <*> o .:? "certificates" .!= []+                <*> o .:? "http"++instance ToJSON LoadBalancer where+    toJSON l =+        objectWith+            [ always "name" l.lbName+            , whenSet "network" l.lbNetwork+            , whenSet "proxy_subnet" l.lbProxySubnet+            , always "default_service" l.lbDefaultService+            , always "hosts" l.lbHosts+            , always "certificates" l.lbCertificates+            , whenSet "http" l.lbHttp+            ]++instance FromJSON ProxySubnet where+    parseJSON = objectOf "proxy_subnet" ["name", "range"] $ \o -> ProxySubnet <$> o .: "name" <*> o .: "range"++instance ToJSON ProxySubnet where+    toJSON s = object ["name" .= s.psName, "range" .= s.psRange]++instance FromJSON HostRoute where+    parseJSON =+        objectOf "host route" ["hosts", "service", "paths"] $ \o ->+            HostRoute <$> o .: "hosts" <*> o .: "service" <*> o .:? "paths" .!= []++instance ToJSON HostRoute where+    toJSON h = object ["hosts" .= h.hrHosts, "service" .= h.hrService, "paths" .= h.hrPaths]++instance FromJSON PathRoute where+    parseJSON = objectOf "path route" ["paths", "service"] $ \o -> PathRoute <$> o .: "paths" <*> o .: "service"++instance ToJSON PathRoute where+    toJSON p = object ["paths" .= p.prPaths, "service" .= p.prService]++instance FromJSON HttpMode where+    parseJSON = withText "http" $ \case+        "serve" -> pure HttpServe+        "redirect-to-https" -> pure HttpRedirectToHttps+        "none" -> pure HttpNone+        other -> fail ("http: serve, redirect-to-https or none, not " <> Text.unpack other)++instance ToJSON HttpMode where+    toJSON = \case+        HttpServe -> "serve"+        HttpRedirectToHttps -> "redirect-to-https"+        HttpNone -> "none"++-------------------------------------------------------------------------------+-- What is wrong with a declaration++{- | Everything wrong with a declaration that no @gcloud@ call could put+right, all of it rather than the first: names GCP would refuse, two things+under one name, a binding or a route naming nothing, two bindings landing on+one variable or in one directory, and whatever the balancer module says of+the balancer ('LoadBalancing.albProblems').++Two refusals are about this binary rather than about GCP:++* a plain environment value holding a comma. @gcloud@ reads+  @--set-env-vars@ as a comma-separated list, so the value would be cut in+  two (or refused) on the way;+* a balancer routing to a service whose ingress is @internal@, which an+  external balancer cannot reach.+-}+turnupProblems :: Turnup -> [Text]+turnupProblems t =+    concat+        [ ["the turnup's name is not usable as a label value (a lowercase letter, then lowercase letters, digits and -, 63 at most): " <> t.turnupName | not (labelLike 63 t.turnupName)]+        , ["no project" | Text.null t.turnupProject]+        , ["no region" | Text.null t.turnupRegion]+        , ["no service declared" | null t.turnupServices]+        , ["service declared twice: " <> n | n <- duplicates (map svcName t.turnupServices)]+        , ["secret declared twice: " <> n | n <- duplicates (map msName t.turnupSecrets)]+        , ["secret with no name" | any (Text.null . msName) t.turnupSecrets]+        , concatMap serviceProblems t.turnupServices+        , maybe [] balancerProblems t.turnupLoadBalancer+        ]+  where+    serviceNames = map svcName t.turnupServices++    serviceProblems :: Service -> [Text]+    serviceProblems s =+        map+            (("service " <> s.svcName <> ": ") <>)+            ( concat+                [ ["not a Cloud Run service name (a lowercase letter, then lowercase letters, digits and -, 49 at most)" | not (labelLike 49 s.svcName)]+                , ["no image" | Text.null s.svcImage]+                , case s.svcAccount of+                    CreateAccount accountId ->+                        ["not a service account id (6 to 30 of lowercase letters, digits and -, starting with a letter): " <> accountId | not (labelLike 30 accountId && Text.length accountId >= 6)]+                    ExistingAccount address ->+                        ["not a service account's address: " <> address | not ("@" `Text.isInfixOf` address)]+                , ["not an environment variable name: " <> k | k <- Map.keys s.svcEnv <> secretVars, not (variableLike k)]+                , -- the name alone: a value is not for a report+                  ["the value of " <> k <> " holds a comma, which gcloud's --set-env-vars would split on" | (k, v) <- Map.toList s.svcEnv, "," `Text.isInfixOf` v]+                , ["variable set twice (as plain environment and as a secret, or by two secrets): " <> k | k <- duplicates (Map.keys s.svcEnv <> secretVars)]+                , ["a secret file's path is not absolute: " <> Text.pack f | f <- secretFiles, not (isAbsolute f)]+                , ["file bound twice: " <> Text.pack f | f <- duplicates secretFiles]+                , [ "two secrets mounted in one directory (a secret volume is the whole directory): " <> Text.pack d+                  | d <- nub (map (takeDirectory . fst) mounts)+                  , length (nub [secret | (f, secret) <- mounts, takeDirectory f == d]) > 1+                  ]+                , ["a binding names no secret" | any (Text.null . sbSecret) s.svcSecrets]+                , ["a binding of " <> b.sbSecret <> " names no version" | b <- s.svcSecrets, Text.null b.sbVersion]+                ]+            )+      where+        secretVars = [v | SecretBinding (EnvVar v) _ _ <- s.svcSecrets]+        mounts = [(f, secret) | SecretBinding (MountedFile f) secret _ <- s.svcSecrets]+        secretFiles = map fst mounts++    balancerProblems :: LoadBalancer -> [Text]+    balancerProblems lb =+        concat+            [ ["the balancer's name is not a resource name: " <> lb.lbName | not (labelLike 63 lb.lbName)]+            , ["the balancer routes to an undeclared service: " <> n | n <- undeclared]+            , [ "the balancer routes to " <> s.svcName <> ", whose ingress is internal: an external balancer cannot reach it"+              | s <- t.turnupServices+              , s.svcName `elem` routed+              , s.svcIngress == CloudRun.Internal+              ]+            , [ "the balancer's resource for " <> n <> " would have a name longer than 63: " <> resource+              | n <- routed+              , let resource = lb.lbName <> "-" <> n <> "-backend"+              , Text.length resource > 63+              ]+            , ["the proxy subnet has no name or no range" | Just ps <- [lb.lbProxySubnet], Text.null ps.psName || Text.null ps.psRange]+            , -- the balancer module's own opinion, once the names it is built from hold+              if null undeclared then LoadBalancing.albProblems (balancerOf t lb) else []+            ]+      where+        routed = routedServices lb+        undeclared = routed \\ serviceNames++duplicates :: (Eq a) => [a] -> [a]+duplicates xs = nub (xs \\ nub xs)++-- | A lowercase letter, then lowercase letters, digits and @-@, not ending in @-@.+labelLike :: Int -> Text -> Bool+labelLike longest name = case Text.uncons name of+    Nothing -> False+    Just (c, rest) ->+        isAsciiLower c+            && Text.all (\x -> isAsciiLower x || isDigit x || x == '-') rest+            && Text.length name <= longest+            && not ("-" `Text.isSuffixOf` name)++variableLike :: Text -> Bool+variableLike name = case Text.uncons name of+    Nothing -> False+    Just (c, rest) -> letter c && Text.all (\x -> letter x || isDigit x) rest+  where+    letter x = isAsciiLower x || isAsciiUpper x || x == '_'++-- | The services a balancer sends to, the default one first, each once.+routedServices :: LoadBalancer -> [Text]+routedServices lb =+    nub (lb.lbDefaultService : concatMap (\h -> h.hrService : map prService h.hrPaths) lb.lbHosts)++-- | A declaration 'turnupOp' was handed with something wrong in it.+newtype InvalidTurnup = InvalidTurnup [Text]+    deriving (Show)++instance Exception InvalidTurnup++-------------------------------------------------------------------------------+-- What it becomes++-- | The label a turnup's services carry: @salmon-turnup=NAME@.+ownerLabel :: Turnup -> CloudRun.OwnerLabel+ownerLabel t = CloudRun.OwnerLabel "salmon-turnup" t.turnupName++-- | What the node of something @run down@ leaves in place says.+keptNote :: Text+keptNote = "kept by `run down`: nothing proves this turnup made it, and it may hold data or be shared"++-- | The address of the account a service runs as.+accountEmail :: Turnup -> ServiceIdentity -> Text+accountEmail t = \case+    CreateAccount accountId -> accountId <> "@" <> t.turnupProject <> ".iam.gserviceaccount.com"+    ExistingAccount address -> address++-- | The service as the Cloud Run node deploys it.+cloudRunServiceOf :: Turnup -> Service -> CloudRun.CloudRunService+cloudRunServiceOf t s =+    CloudRun.CloudRunService+        { CloudRun.crsName = s.svcName+        , CloudRun.crsProject = Core.Project t.turnupProject+        , CloudRun.crsRegion = Core.Region t.turnupRegion+        , CloudRun.crsImage = s.svcImage+        , CloudRun.crsEnv = s.svcEnv+        , CloudRun.crsServiceAccount = accountEmail t s.svcAccount+        , CloudRun.crsIngress = s.svcIngress+        , CloudRun.crsMaxInstances = s.svcMaxInstances+        , CloudRun.crsOptions =+            CloudRun.defaultCloudRunOptions+                { CloudRun.croSecrets = map binding s.svcSecrets+                , CloudRun.croCpu = s.svcCpu+                , CloudRun.croMemory = s.svcMemory+                , CloudRun.croConcurrency = s.svcConcurrency+                , CloudRun.croTimeoutSeconds = s.svcTimeoutSeconds+                , CloudRun.croPort = s.svcPort+                , CloudRun.croAllowUnauthenticated = s.svcInvoker == InvokerAllUsers+                , CloudRun.croInvokerIamCheckDisabled = s.svcInvoker == InvokerNoIamCheck+                , CloudRun.croMinInstances = s.svcMinInstances+                , CloudRun.croCpuAlwaysAllocated = s.svcCpuAlwaysAllocated+                , CloudRun.croOwner = Just (ownerLabel t)+                }+        }+  where+    binding :: SecretBinding -> CloudRun.SecretBinding+    binding b = case b.sbTarget of+        EnvVar v -> CloudRun.SecretEnvVar v b.sbSecret b.sbVersion+        MountedFile f -> CloudRun.SecretFile f b.sbSecret b.sbVersion++{- | The balancer as the balancer module makes it: the default backend+service sends to 'lbDefaultService', and every other service a rule names+has a backend service of its own, under the Cloud Run service's name.+-}+balancerOf :: Turnup -> LoadBalancer -> LoadBalancing.ApplicationLoadBalancer+balancerOf t lb =+    (LoadBalancing.httpLoadBalancer lb.lbName (Core.Project t.turnupProject) (Core.Region t.turnupRegion) [LoadBalancing.CloudRunBackend lb.lbDefaultService] Nothing)+        { LoadBalancing.albNetwork = lb.lbNetwork+        , LoadBalancing.albServices =+            [ LoadBalancing.BackendService n [LoadBalancing.CloudRunBackend n] Nothing Nothing+            | n <- drop 1 (routedServices lb)+            ]+        , LoadBalancing.albHostRules =+            [ LoadBalancing.HostRule+                h.hrHosts+                (target h.hrService)+                [LoadBalancing.PathRule p.prPaths (target p.prService) LoadBalancing.KeepPath | p <- h.hrPaths]+            | h <- lb.lbHosts+            ]+        , LoadBalancing.albCertificates = map LoadBalancing.ComputeCertificate lb.lbCertificates+        , LoadBalancing.albHttp = case lb.lbHttp of+            Nothing -> LoadBalancing.HttpCreatedOnce+            Just HttpServe -> LoadBalancing.ServeHttp+            Just HttpRedirectToHttps -> LoadBalancing.RedirectToHttps LoadBalancing.MovedPermanently+            Just HttpNone -> LoadBalancing.NoHttp+        }+  where+    target n+        | n == lb.lbDefaultService = LoadBalancing.DefaultService+        | otherwise = LoadBalancing.NamedService n++{- | The whole turnup under one node.++A declaration with something wrong in it becomes that one node alone, which+fails saying what: a directive can be written by hand, and half a turnup is+worse than none.+-}+turnupOp :: Turnup -> Op+turnupOp t = case turnupProblems t of+    [] -> turnupGraph t+    problems ->+        op "cloudrun-turnup" nodeps $ \actions ->+            actions+                { Extension.help = Text.unwords ["Cloud Run turnup", t.turnupName, "(refused)"]+                , notes = problems+                , ref = turnupRef t+                , up = throwIO (InvalidTurnup problems)+                , check = pure (Failure (Text.intercalate "; " problems))+                }++turnupRef :: Turnup -> Ref+turnupRef t = mkRef "cloudrun-turnup" (t.turnupProject, t.turnupRegion, t.turnupName)++turnupGraph :: Turnup -> Op+turnupGraph t =+    op "cloudrun-turnup" (deps (maybe [] (pure . balancer) t.turnupLoadBalancer <> map service t.turnupServices <> map managedSecret t.turnupSecrets)) $ \actions ->+        actions+            { Extension.help = Text.unwords ["Cloud Run turnup", t.turnupName, "(" <> Text.intercalate ", " (map svcName t.turnupServices) <> ")"]+            , notes =+                [ "`run down` deletes the services carrying the label "+                    <> CloudRun.renderOwnerLabel (ownerLabel t)+                    <> maybe "" (\lb -> " and the resources of the balancer " <> lb.lbName) t.turnupLoadBalancer+                , "`run down` keeps the secrets and their versions, the service accounts, the IAM grants, the proxy-only subnet and the enabled APIs"+                ]+            , ref = turnupRef t+            }+  where+    project = Core.Project t.turnupProject+    region = Core.Region t.turnupRegion++    -- who gcloud acts as, under everything+    foundation :: [Op]+    foundation = [Core.declaredAccount reportPrint Core.gcloud (Core.Account a) | Just a <- [t.turnupAccount]]++    needing :: Op -> [Op] -> Op+    needing o prerequisites = foldl inject o (prerequisites <> foundation)++    apis :: [Text] -> [Op]+    apis names+        | t.turnupEnableApis = [ServiceUsage.enableService reportPrint Core.gcloud project (ServiceUsage.Api n) `needing` [] | n <- names]+        | otherwise = []++    secretApi, runApi, iamApi, computeApi :: [Op]+    secretApi = apis ["secretmanager.googleapis.com"]+    runApi = apis ["run.googleapis.com"]+    iamApi = apis ["iam.googleapis.com"]+    computeApi = apis ["compute.googleapis.com"]++    -- Service accounts++    account :: ServiceIdentity -> [Op]+    account = \case+        CreateAccount accountId -> [keptNode (Iam.serviceAccount reportPrint Core.gcloud project accountId) `needing` iamApi]+        ExistingAccount _ -> []++    -- Secrets++    secretOf :: ManagedSecret -> SecretManager.Secret+    secretOf s = SecretManager.Secret s.msName project s.msReplication++    secretContainer :: ManagedSecret -> Op+    secretContainer s = keptSecret (SecretManager.secret reportPrint Core.gcloud (secretOf s)) `needing` secretApi++    -- The container is declared beside the version that already depends on+    -- it, for the edge to the API: the version's own copy of that node has+    -- none, and the two are one node once folded.+    managedSecret :: ManagedSecret -> Op+    managedSecret s = case s.msSourceFile of+        Nothing -> secretContainer s+        Just file ->+            keptSecret (SecretManager.secretVersion reportPrint Core.gcloud (SecretManager.SecretVersion (secretOf s) file))+                `needing` (secretContainer s : secretApi)++    managedNamed :: Text -> [Op]+    managedNamed name = [managedSecret s | s <- t.turnupSecrets, s.msName == name]++    grant :: Service -> Text -> Op+    grant s secretName =+        keptNode+            ( noted ["on the secret " <> secretName] $+                Iam.iamBinding+                    reportPrint+                    Core.gcloud+                    ( Iam.IamBinding+                        (Iam.ServiceAccount (accountEmail t s.svcAccount))+                        "roles/secretmanager.secretAccessor"+                        ("projects/" <> t.turnupProject <> "/secrets/" <> secretName)+                    )+            )+            `needing` (account s.svcAccount <> [secretContainer m | m <- t.turnupSecrets, m.msName == secretName] <> secretApi)++    -- Services++    service :: Service -> Op+    service s =+        CloudRun.cloudRunService reportPrint Core.gcloud (cloudRunServiceOf t s)+            `needing` concat+                [ account s.svcAccount+                , [grant s name | s.svcGrantSecretAccess, name <- bound]+                , concatMap managedNamed bound+                , runApi+                ]+      where+        bound = nub (map sbSecret s.svcSecrets)++    -- The balancer++    balancer :: LoadBalancer -> Op+    balancer lb =+        LoadBalancing.applicationLoadBalancerAfter+            (concat [proxySubnet, computeApi, map service routed, foundation])+            reportPrint+            Core.gcloud+            (balancerOf t lb)+      where+        routed = [s | s <- t.turnupServices, s.svcName `elem` routedServices lb]+        proxySubnet =+            [ keptNode+                ( Compute.subnet+                    reportPrint+                    Core.gcloud+                    Compute.Subnet+                        { Compute.subnetName = ps.psName+                        , Compute.subnetProject = project+                        , Compute.subnetRegion = region+                        , Compute.subnetNetwork = maybe "default" id lb.lbNetwork+                        , Compute.subnetRange = ps.psRange+                        , Compute.subnetPurpose = Compute.RegionalManagedProxy+                        }+                )+                `needing` computeApi+            | Just ps <- [lb.lbProxySubnet]+            ]++{- | The node as it was, except that @run down@ leaves its effect in place,+and that it says so. The one node: its dependencies are as they were.+-}+keptNode :: Op -> Op+keptNode = noted [keptNote] . amendNode (\e -> e{down = pure ()})++-- | The node as it was, saying this too. The one node.+noted :: [Text] -> Op -> Op+noted more = amendNode (\e -> e{notes = e.notes <> more})++{- | The same for a secret, which is two nodes when it has a version (the+version's node declares the secret's own beneath it) and whose builtin note+promises a deletion that no longer happens.++This one goes through the whole of what it is given, so that the secret+declared under a version and the secret declared beside it stay one and the+same node. A node with a deletion to lose says it is kept; the others+(@gcloud@ itself) had none and are as they were, which is what keeps them+the same node as every other mention of them.+-}+keptSecret :: Op -> Op+keptSecret = fmap (fmap kept)+  where+    kept :: Extension -> Extension+    kept e+        | secretDeletionNote `elem` e.notes = e{down = pure (), notes = filter (/= secretDeletionNote) e.notes <> [keptNote]}+        | otherwise = e{down = pure ()}++-- | What "Salmon.Builtin.Nodes.Gcp.SecretManager".@secret@ says of its @down@.+secretDeletionNote :: Text+secretDeletionNote = "down destroys every version of the secret"

@@ -0,0 +1,197 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++{- | @salmon-docs-sync@: keep the generated website (@docs/@, what GitHub Pages+serves) in step with the files it is generated from.++The repository's own docs build, @website/scripts/build-site.sh@, is a+manual step; this is that step as a salmon node, so it can be run once+(@run up@), from cron, or tended by @run serve@.++__check__ fingerprints the inputs — every /tracked/ file under @resources/@,+@specs/@, @website/src/@ and @website/scripts/@, plus @README.md@ — and+compares the result with the stamp stored in @docs/.docs-sync-stamp@. The+stamp is committed with @docs/@, so "what was the site built from" travels+with the site. Gitignored files (the mirrored @docs-*.cmark@ pages, which+@sync-repo-docs.sh@ rewrites with a fresh date on every run) are not inputs:+they are derived, and counting them would make the site stale after every+build. Because @git ls-files@ names the inputs, an edit that is not yet+committed still counts (the contents are read from disk): the node+regenerates against what the working tree says.++__up__ runs @build-site.sh@, writes the stamp, @git add docs@, commits with a+fixed headline (@docs: regenerate site@) when something is staged, and+pushes. It touches nothing outside @docs/@.++= Trigger: on demand or tended++The check is a few file reads and one @git ls-files@, so the node is cheap to+ask but the build behind @up@ is not, which rules out @supReapply@ (that is+for an @up@ as cheap as its check). Two fitting triggers:++* @run up@ from a cron entry or a post-merge hook: the simplest, one shot+  per event, nothing resident.+* @run serve@: the check runs on the tending ladder, so a change to the+  working tree is noticed and the site regenerated and pushed without anybody+  typing @converge@. Costs a resident process.++Push uses the repository's ambient authentication; this binary never handles+a credential. @--no-push@ commits only.+-}+module DocsSync (+    main,+    Seed (..),+    Spec (..),+    configure,+    program,+    docsSync,+    inputFingerprint,+    stampPath,+) where++import Control.Monad (when)+import Data.Aeson (FromJSON, ToJSON)+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Char8 as C8+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import GHC.Generics (Generic)+import Options.Applicative (execParser, fullDesc, header, helper, info, long, metavar, progDesc, showDefault, strOption, switch, value, (<**>))+import qualified Options.Applicative as Opt+import Options.Generic (ParseRecord (..))+import System.Directory (doesFileExist)+import System.Exit (ExitCode (..))+import System.FilePath ((</>))+import System.Process (CreateProcess (..), proc, readCreateProcessWithExitCode)+import Control.Exception (Exception, throwIO)++import qualified Salmon.Builtin.CommandLine as CLI+import Salmon.Builtin.Extension+import Salmon.Builtin.Nodes.Filesystem (hashBytes)+import Salmon.Actions.UpDown (CheckResult (..))+import Salmon.Op.Configure (Configure (..))+import Salmon.Op.Ref (mkRef)+import Salmon.Op.Track (Track (..))+import Salmon.Reporter (reportPrint)++main :: IO ()+main = do+    let desc = fullDesc <> progDesc "Regenerate, commit and push docs/ when its sources changed" <> header "salmon-docs-sync"+    cmd <- execParser (info parseRecord desc)+    CLI.execCommandOrSeed reportPrint configure program cmd++-------------------------------------------------------------------------------++data Seed = Seed+    { seedRepo :: FilePath+    , seedRemote :: Text+    , seedNoPush :: Bool+    }+    deriving (Eq, Show, Generic)++instance FromJSON Seed+instance ToJSON Seed++instance ParseRecord Seed where+    parseRecord =+        build <**> helper+      where+        build =+            Seed+                <$> strOption (long "repo" <> metavar "DIR" <> value "." <> showDefault <> Opt.help "root of the salmon checkout")+                <*> strOption (long "remote" <> metavar "REMOTE" <> value "origin" <> showDefault <> Opt.help "git remote to push to")+                <*> switch (long "no-push" <> Opt.help "commit but do not push")++data Spec = Spec+    { specRepo :: FilePath+    , specRemote :: Text+    , specPush :: Bool+    }+    deriving (Eq, Show, Generic)++instance FromJSON Spec+instance ToJSON Spec++configure :: Configure IO Seed Spec+configure = Configure $ \s -> pure (Spec s.seedRepo s.seedRemote (not s.seedNoPush))++program :: Track' Spec+program = Track docsSync++-------------------------------------------------------------------------------++data DocsSyncError = StepFailed String Int String+    deriving (Show)++instance Exception DocsSyncError++stampPath :: FilePath -> FilePath+stampPath repo = repo </> "docs" </> ".docs-sync-stamp"++-- | The tracked files the site is generated from.+inputRoots :: [String]+inputRoots = ["resources", "specs", "README.md", "website/src", "website/scripts"]++step :: FilePath -> String -> [String] -> IO String+step repo cmd args = do+    (code, out, err) <- readCreateProcessWithExitCode (proc cmd args){cwd = Just repo} ""+    case code of+        ExitSuccess -> pure out+        ExitFailure n -> throwIO (StepFailed (unwords (cmd : args)) n err)++-- | A fingerprint of every tracked input, by path and content.+inputFingerprint :: FilePath -> IO Text+inputFingerprint repo = do+    listing <- step repo "git" (["ls-files", "-z", "--"] <> inputRoots)+    let paths = filter (not . null) (splitNul listing)+    contents <- mapM (\p -> readIfThere (repo </> p) >>= \c -> pure (C8.pack p <> "\0" <> c <> "\0")) paths+    pure (hashBytes (ByteString.concat contents))+  where+    splitNul s = case break (== '\0') s of+        (a, []) -> [a]+        (a, _ : rest) -> a : splitNul rest+    -- a tracked file deleted from the working tree is an input that changed+    readIfThere f = do+        there <- doesFileExist f+        if there then ByteString.readFile f else pure "<missing>"++readStamp :: FilePath -> IO (Maybe Text)+readStamp repo = do+    let f = stampPath repo+    there <- doesFileExist f+    if there then Just . Text.strip <$> Text.readFile f else pure Nothing++docsSync :: Spec -> Op+docsSync spec =+    op "docs-sync" nodeps $ \actions ->+        actions+            { help = "regenerates docs/ when its sources changed, then commits and pushes it"+            , notes =+                [ "inputs: tracked files under " <> Text.unwords (map Text.pack inputRoots)+                , "stamp: docs/.docs-sync-stamp"+                , if spec.specPush then "pushes to " <> spec.specRemote else "does not push"+                ]+            , ref = mkRef "docs-sync" (Text.pack repo)+            , check = do+                now <- inputFingerprint repo+                stamp <- readStamp repo+                pure $+                    if stamp == Just now+                        then Success+                        else Failure ("docs/ was built from " <> maybe "nothing recorded" id stamp <> ", sources are " <> now)+            , up = do+                _ <- step repo "bash" ["website/scripts/build-site.sh"]+                fp <- inputFingerprint repo+                Text.writeFile (stampPath repo) (fp <> "\n")+                _ <- step repo "git" ["add", "--all", "docs"]+                (staged, _, _) <- readCreateProcessWithExitCode (proc "git" ["diff", "--cached", "--quiet", "--", "docs"]){cwd = Just repo} ""+                when (staged /= ExitSuccess) $ do+                    _ <- step repo "git" ["commit", "-m", "docs: regenerate site (sources " <> Text.unpack fp <> ")", "--", "docs"]+                    pure ()+                when spec.specPush $ do+                    _ <- step repo "git" ["push", Text.unpack spec.specRemote, "HEAD"]+                    pure ()+            }+  where+    repo = spec.specRepo

@@ -21,16 +21,29 @@ * __tier 3__ (a forwarding rule's hourly rate on top): put a regional   external Application Load Balancer in front of that VM -- a proxy-only   subnet, an unmanaged instance group holding the instance, a health check,-  and the balancer itself. The VM serves the page through a systemd unit the-  /tier-2 hand-off/ installed, so a @200@ from the balancer's address is-  evidence for both halves at once.+  and the balancer itself. The page is in an image the control side builds+  and pushes to the toy's own repository, and the VM serves it from a+  container the /tier-2 hand-off/ declared: a quadlet in system scope, pulled+  with the instance's own service account. A @200@ from the balancer's+  address carrying that page is evidence for the hand-off, the registry+  login and the container at once. -Tier 2 takes __two passes__, which is not a wart but the shape of the-problem: GCP picks the address, so nothing can name the machine until after-the address node's @up@. Pass one declares the infrastructure; the driver-then reads the IP (@Compute.readAddress@) and passes it back in as-@--vm-ip@, and pass two declares the same graph plus the provisioning step.+Tier 2 optionally declares a __peer__ (@--vm-internal-ip@ with+@--peer-internal-ip@): a second instance with no external address at all,+both instances pinned to the internal addresses given, and the VM-side+payload fetching a page from the peer on that address. Unlike the external+address below, these are known when the graph is declared, so the firewall+rule that admits the VM by its @\/32@ and the URL the VM fetches are written+in the same pass that creates the machines. +Tier 2 is __one pass__. GCP picks the address, so nothing can name the+machine until after the address node's @up@, and an 'Op' naming it cannot be+built at declaration: the part that has to (the ssh probe, the secret upload,+the remote call) is therefore built inside a node's @up@, from the address+read then ('VmProvision.provisionedVmReadingHost'). @--vm-ip@ is still+accepted and declares that part as ordinary nodes, which is what the driver+script's second pass does and what shows them in @run tree@.+ When the project is created by this binary (the default), it is the deepest node of the graph, so @run down@ tears every resource down individually first -- which is what is being validated -- and then deletes the project,@@ -48,16 +61,28 @@     Role (..),     VmConfig (..),     LbConfig (..),+    PeerConfig (..),     ImageSource (..),     defaultBaseImage,     configure,     program,++    -- * Tier 3's container, for the tests+    pageImage,+    pageBaseImage,+    pageContainer,+    pageAuthFile,+    pageText,+    gceInstance, ) where +import Control.Exception (throwIO) import Control.Monad (when)+import qualified Data.ByteString as ByteString import qualified Data.Map as Map import Data.Aeson (FromJSON, ToJSON) import Data.Char (isAsciiLower, isDigit)+import Data.Functor.Identity (runIdentity) import Data.Maybe (catMaybes) import Data.Text (Text) import qualified Data.Text as Text@@ -65,13 +90,18 @@ import Options.Applicative (auto, execParser, flag', fullDesc, header, helper, info, long, metavar, option, optional, progDesc, strOption, switch, value, (<**>), (<|>)) import qualified Options.Applicative as Opt import Options.Generic (ParseRecord (..))-import System.Directory (doesFileExist, makeAbsolute)+import System.Directory (createDirectoryIfMissing, doesFileExist, makeAbsolute)+import System.FilePath (takeDirectory)+import System.Exit (ExitCode (..))+import System.Process (readProcessWithExitCode) +import qualified Salmon.Actions.UpDown as UpDown import qualified Salmon.Builtin.CommandLine as CLI import Salmon.Builtin.Extension import qualified Salmon.Builtin.Nodes.Filesystem as FS import qualified Salmon.Builtin.Nodes.Gcp.ArtifactRegistry as ArtifactRegistry import qualified Salmon.Builtin.Nodes.Gcp.Billing as Billing+import qualified Salmon.Builtin.Nodes.Gcp.CloudDns as CloudDns import qualified Salmon.Builtin.Nodes.Gcp.CloudRun as CloudRun import qualified Salmon.Builtin.Nodes.Gcp.Core as Core import qualified Salmon.Builtin.Nodes.Gcp.Iam as Iam@@ -80,19 +110,21 @@ import qualified Salmon.Builtin.Nodes.Gcp.ServiceUsage as ServiceUsage import qualified Salmon.Builtin.Nodes.Gcp.Storage as Storage import qualified Salmon.Builtin.Nodes.Debian.OS as OS-import qualified Salmon.Builtin.Nodes.Debian.Package as Debian import qualified Salmon.Builtin.Nodes.Gcp.Compute as Compute import qualified Salmon.Builtin.Nodes.Gcp.LoadBalancing as LoadBalancing import qualified Salmon.Builtin.Nodes.Gcp.SshAccess as SshAccess-import qualified Salmon.Builtin.Nodes.Systemd as Systemd import qualified Salmon.Builtin.Nodes.Keys as Keys import qualified Salmon.Builtin.Nodes.Podman as Podman+import qualified Salmon.Builtin.Nodes.Podman.Quadlet as Quadlet+import qualified Salmon.Builtin.Nodes.SecretDelivery as SecretDelivery+import qualified Salmon.Builtin.Nodes.Secrets as Secrets import qualified Salmon.Builtin.Nodes.Self as Self+import qualified Salmon.Builtin.Nodes.Ssh as Ssh import Salmon.Op.Configure (Configure (..)) import Salmon.Op.OpGraph (inject) import Salmon.Op.Ref (mkRef) import Salmon.Op.Track (Track (..))-import Salmon.Reporter (reportPrint)+import Salmon.Reporter (reportPrint, silent)  import qualified SreBox.Gcp.CloudRunAlerts as CloudRunAlerts import qualified SreBox.Gcp.CloudRunDeploy as CloudRunDeploy@@ -130,6 +162,11 @@     , seedLbProxyRange :: Text     , seedLbPort :: Int     , seedAlertEmail :: Maybe Text+    , seedVmInternalIp :: Maybe Text+    , seedPeerInternalIp :: Maybe Text+    , seedDnsZone :: Maybe Text+    , seedAccount :: Maybe Text+    , seedLbHttps :: Bool     }     deriving (Eq, Show) @@ -162,6 +199,14 @@                 <*> strOption (long "lb-proxy-range" <> value "192.168.100.0/24" <> Opt.showDefault <> Opt.help "tier 3 proxy-only subnet range (/26 or larger, must not overlap 10.128.0.0/9)")                 <*> option auto (long "lb-port" <> value (8080 :: Int) <> Opt.showDefault <> Opt.help "tier 3 port the VM serves on, behind the balancer")                 <*> optional (strOption (long "alert-email" <> metavar "ADDRESS" <> Opt.help "tier 1: also declare the standard Cloud Monitoring alerts on the service, to this email (SreBox.Gcp.CloudRunAlerts)"))+                -- No default: the range of the `default` network's subnet+                -- differs per region (10.132.0.0/20 in europe-west1), so the+                -- caller has to look it up.+                <*> optional (strOption (long "vm-internal-ip" <> metavar "IP" <> Opt.help "tier 2: pin the VM to this internal address, a free one in the region's `default` subnet; needs --peer-internal-ip"))+                <*> optional (strOption (long "peer-internal-ip" <> metavar "IP" <> Opt.help "tier 2: also boot a peer with no external address, pinned to this internal one, which the VM then fetches a page from; needs --vm-internal-ip"))+                <*> optional (strOption (long "dns-zone" <> metavar "DNS_NAME" <> Opt.help "tier 0: also create a public Cloud DNS zone for this domain and print the name servers it was assigned (cents per month); at tier 3, also point lb.DNS_NAME at the balancer"))+                <*> optional (strOption (long "account" <> metavar "EMAIL" <> Opt.help "the account gcloud must be acting as; any other active account is refused before anything is created (Gcp.Core.declaredAccount)"))+                <*> switch (long "lb-https" <> Opt.help "tier 3, with --dns-zone: also serve lb.DNS_NAME over HTTPS with a Google-managed certificate, through a host rule, a path rule and a second backend service with a longer timeout")         -- xor: once one branch has matched, the other flag is rejected by the parser         imageSourceP =             (FromContainerfile <$> strOption (long "containerfile" <> metavar "PATH" <> Opt.help "tier 1: build this Containerfile, with its directory as build context"))@@ -236,12 +281,29 @@ data LbConfig = LbConfig     { lbProxyRange :: Text     , lbPort :: Int+    , lbHttps :: Maybe Bool+    -- ^ 'Maybe' so a directive written before the field existed still reads     }     deriving (Eq, Show, Generic)  instance FromJSON LbConfig instance ToJSON LbConfig +{- | Tier 2's optional peer: two instances that name each other by internal+addresses declared here, before either exists.+-}+data PeerConfig = PeerConfig+    { peerVmInternalIp :: Text+    -- ^ the tier-2 VM's, which the peer's firewall rule admits as a @\/32@+    , peerInternalIp :: Text+    -- ^ the peer's, which is its only address+    , peerPort :: Int+    }+    deriving (Eq, Show, Generic)++instance FromJSON PeerConfig+instance ToJSON PeerConfig+ data Spec = Spec     { role :: Role     , project :: Text@@ -258,6 +320,11 @@     , lbConfig :: Maybe LbConfig     , alertEmail :: Maybe Text     -- ^ tier 1: the standard alerts on the service go here, if anywhere+    , peerConfig :: Maybe PeerConfig+    , dnsZone :: Maybe Text+    -- ^ tier 0: a Cloud DNS zone for this domain, if any+    , account :: Maybe Text+    -- ^ the account gcloud must be acting as, if declared     }     deriving (Eq, Show, Generic) @@ -305,10 +372,25 @@                             , vmSelfPath = self                             , vmMarkerPath = "/var/lib/salmon-toy/provisioned"                             }+    peer <- case (seed.seedVmInternalIp, seed.seedPeerInternalIp) of+        (Nothing, Nothing) -> pure Nothing+        (Just vmInternal, Just peerInternal) -> do+            when (seed.seedTier < 2) $+                fail "--vm-internal-ip and --peer-internal-ip need --tier 2 or above"+            when (vmInternal == peerInternal) $+                fail "--vm-internal-ip and --peer-internal-ip must differ"+            when (not (validIpv4 vmInternal && validIpv4 peerInternal)) $+                fail "--vm-internal-ip and --peer-internal-ip must be IPv4 literals"+            pure (Just (PeerConfig vmInternal peerInternal 8081))+        _ -> fail "--vm-internal-ip and --peer-internal-ip go together: give both or neither"+    when (maybe False (not . validDnsName) seed.seedDnsZone) $+        fail "--dns-zone must be a domain name: dot-separated labels of [a-z0-9-], at least two"+    when (seed.seedLbHttps && (seed.seedTier < 3 || seed.seedDnsZone == Nothing)) $+        fail "--lb-https needs --tier 3 and --dns-zone: the certificate is for lb.DNS_NAME and is authorized through that zone"     let lb =             if seed.seedTier < 3                 then Nothing-                else Just (LbConfig seed.seedLbProxyRange seed.seedLbPort)+                else Just (LbConfig seed.seedLbProxyRange seed.seedLbPort (if seed.seedLbHttps then Just True else Nothing))     pure $         Spec             { role = Control@@ -328,8 +410,25 @@             , vmConfig = vm             , lbConfig = lb             , alertEmail = if seed.seedTier >= 1 then seed.seedAlertEmail else Nothing+            , peerConfig = peer+            , dnsZone = seed.seedDnsZone+            , account = seed.seedAccount             }   where+    validIpv4 t = case Text.splitOn "." t of+        parts@[_, _, _, _] -> all validOctet parts+        _ -> False+    validOctet o =+        not (Text.null o) && Text.length o <= 3 && Text.all isDigit o && (read (Text.unpack o) :: Int) <= 255+    validDnsName t =+        let labels = Text.splitOn "." (Text.dropWhileEnd (== '.') t)+         in length labels >= 2 && all validLabel labels+    validLabel l =+        not (Text.null l)+            && Text.length l <= 63+            && Text.all (\x -> isAsciiLower x || isDigit x || x == '-') l+            && not ("-" `Text.isPrefixOf` l)+            && not ("-" `Text.isSuffixOf` l)     validProjectId t =         Text.length t >= 6 && Text.length t <= 30 && validPrefix t && not ("-" `Text.isSuffixOf` t)     validPrefix t =@@ -350,7 +449,7 @@ -} onVm :: Spec -> Op onVm spec =-    op "gcp-toy-on-vm" (deps (marker : maybe [] (\lb -> [webServer spec lb]) spec.lbConfig)) $ \actions ->+    op "gcp-toy-on-vm" (deps (marker : secretRead spec : maybe [] (\lb -> [pageServer spec lb]) spec.lbConfig <> maybe [] (\peer -> [peerReached spec peer `inject` marker]) spec.peerConfig)) $ \actions ->         actions             { help = "the tier-2 payload, declared by this binary running on the VM"             , ref = mkRef "gcp-toy-on-vm" spec.project@@ -359,8 +458,85 @@     path = maybe "/var/lib/salmon-toy/provisioned" vmMarkerPath spec.vmConfig     marker = FS.filecontents (FS.FileContents path ("provisioned by salmon-gcp-toy for " <> spec.project <> "\n")) -{- | Tier 3's backend: a page, and a systemd unit serving it.+{- | Where the control side's generated secret lands on the VM, delivered by+"Salmon.Builtin.Nodes.SecretDelivery" before the uploaded binary runs.+-}+secretPlacement :: SecretDelivery.Placement+secretPlacement = SecretDelivery.Placement "/etc/salmon-toy/secret" "root" "root" "0600" +-- | What the control side generates: 32 random bytes, as 64 hex characters.+secretLength :: Int+secretLength = 64++-- | Where the VM records that it read the secret, for the driver to read back.+secretMarkerPath :: FilePath+secretMarkerPath = "/var/lib/salmon-toy/secret-read"++{- | The uploaded binary reading the secret the control side delivered.++The secret is not in this directive -- which is printed in the remote call's+own report -- and that is the point being validated: the VM-side graph knows+a /path/, and the bytes got there by another road. The proof left behind is+a marker saying how many bytes were read, which is a property of the+declaration (see 'secretLength') and not of the secret. A file that is+absent, or is not what the control side generates, fails the node.+-}+secretRead :: Spec -> Op+secretRead spec =+    op "gcp-toy-secret-read" nodeps $ \actions ->+        actions+            { help = Text.unwords ["reads the delivered secret at", Text.pack path]+            , ref = mkRef "gcp-toy-secret-read" (spec.project, path)+            , up = do+                present <- doesFileExist path+                when (not present) $+                    throwIO (userError ("no secret was delivered at " <> path))+                bytes <- ByteString.readFile path+                when (ByteString.length bytes /= secretLength) $+                    throwIO (userError ("the file at " <> path <> " is not the generated secret: " <> show (ByteString.length bytes) <> " bytes"))+                createDirectoryIfMissing True (takeDirectory secretMarkerPath)+                writeFile secretMarkerPath ("read " <> show (ByteString.length bytes) <> " bytes of a delivered secret for " <> Text.unpack spec.project <> "\n")+            }+  where+    path = SecretDelivery.placePath secretPlacement++-- | Where the VM leaves what the peer answered, for the driver to read back.+peerMarkerPath :: FilePath+peerMarkerPath = "/var/lib/salmon-toy/peer-reached"++{- | The VM fetching the peer's page on the peer's /declared/ internal+address, and keeping what came back.++Declared on the VM side because that is the only place the claim can be+tested from: the peer has no external address, so nothing outside the VPC can+ask it anything. The fetch waits (up to about five minutes) since the peer+was created moments before the VM and serves only once its own startup+script has run. No @check@: the question is whether the peer answers /now/,+and asking costs what fetching does.+-}+peerReached :: Spec -> PeerConfig -> Op+peerReached spec peer =+    op "gcp-toy-peer-reached" nodeps $ \actions ->+        actions+            { help = Text.unwords ["fetches", url, "from the peer's internal address"]+            , ref = mkRef "gcp-toy-peer-reached" (spec.project, url)+            , up = do+                (code, out, err) <-+                    readProcessWithExitCode+                        "curl"+                        ["-fsS", "--max-time", "10", "--retry", "30", "--retry-delay", "10", "--retry-all-errors", Text.unpack url]+                        ""+                case code of+                    ExitSuccess+                        | spec.project `Text.isInfixOf` Text.pack out -> writeFile peerMarkerPath out+                        | otherwise -> throwIO (userError ("the peer answered, but not with its page: " <> take 200 out))+                    ExitFailure n -> throwIO (userError ("could not reach the peer at " <> Text.unpack url <> " (curl exit " <> show n <> "): " <> take 400 err))+            }+  where+    url = "http://" <> peer.peerInternalIp <> ":" <> Text.pack (show peer.peerPort) <> "/"++{- | Tier 3's backend: the page, served from a container.+ Declared on the /VM side/ deliberately. A load balancer whose forwarding rule merely exists proves nothing -- a balancer in front of no server answers @502@ just as readily -- so what tier 3 actually checks is a @200@ carrying@@ -368,61 +544,112 @@ running on the machine. It is therefore also a second, independent proof that the tier-2 hand-off worked, this time through the front door. -@python3@ is on every Ubuntu cloud image (cloud-init is written in it), so-the 'Debian.deb' node here is nearly always a 'Skip' -- it is declared-anyway, because "nearly always" is not a dependency.+The page is not on the machine: it is in 'pageImage', which the control side+built and pushed to the toy's own repository ('pagePushed') before the+instance existed. So the body also says three more things happened here, none+of which a file written by salmon would: podman was installed, it was logged+in to the registry /as the instance's service account/+('ArtifactRegistry.instanceLogin': the metadata server's token, no secret+shipped), and a quadlet in system scope pulled that image and runs it+('Quadlet.quadletContainer').++The login is what the quadlet's 'Track'' declares, so it is ahead of the+pull and of the file; podman's package is what the login stands on. -}-webServer :: Spec -> LbConfig -> Op-webServer spec lb =-    Systemd.systemdService reportPrint OS.systemctl trackConfig config+pageServer :: Spec -> LbConfig -> Op+pageServer spec lb =+    Quadlet.quadletContainer reportPrint OS.systemctl (Track (const loggedIn)) (pageContainer spec lb)   where-    root :: FilePath-    root = "/var/www/salmon-toy"+    loggedIn :: Op+    loggedIn = ArtifactRegistry.instanceLogin reportPrint OS.podman pageAuthFile (regionOf spec) -    trackConfig :: Track' Systemd.Config-    trackConfig = Track $ \_ ->-        op "setup-salmon-toy-web" (deps [indexFile, Debian.deb (Debian.Package "python3")]) id+{- | The quadlet: 'pageImage' as @salmon-toy-page.service@, its port 80+published on the port the balancer's backend and health check are configured+for. -    indexFile :: Op-    indexFile =-        FS.filecontents-            ( FS.FileContents-                (root <> "/index.html")-                ("served by salmon-gcp-toy from " <> spec.project <> "\n")-            )+Not named @salmon-toy-web@, which is the unit this tier installed before it+served from a container: a file of that name in @\/etc\/systemd\/system@+takes precedence over a generated unit, so on a machine provisioned by an+older toy the container would never start.+-}+pageContainer :: Spec -> LbConfig -> Quadlet.Container+pageContainer spec lb =+    (Quadlet.container (Podman.ContainerName "salmon-toy-page") (pageImage spec))+        { Quadlet.containerDescription = "salmon-gcp-toy tier-3 backend"+        , Quadlet.containerPorts = [Podman.PortMapping (Text.pack (show lb.lbPort)) "80" Podman.TCPPort]+        , Quadlet.containerAuthFile = Just pageAuthFile+        } -    config :: Systemd.Config-    config =-        Systemd.Config-            Systemd.System-            "/etc/systemd/system"-            "salmon-toy-web.service"-            (Systemd.Unit "salmon-gcp-toy tier-3 backend" "network-online.target")-            ( Systemd.Service-                Systemd.Simple-                "root"-                "root"-                "022"-                start-                Systemd.OnFailure-                Systemd.Process-                root-            )-            (Systemd.Install "multi-user.target")+{- | Where the VM keeps the registry credentials the metadata server's token+is written to: beside the hand-off's markers, and root's alone.+-}+pageAuthFile :: Podman.AuthFile+pageAuthFile = Podman.AuthFile "/var/lib/salmon-toy/registry-auth.json" -    start :: Systemd.Start-    start =-        Systemd.Start-            "/usr/bin/python3"-            [ "-m"-            , "http.server"-            , Text.pack (show lb.lbPort)-            , "--bind"-            , "0.0.0.0"-            , "--directory"-            , Text.pack root-            ]+{- | The one string that means "the page's image": what the control side+tags, builds and pushes, and what the VM pulls and runs.+-}+pageImage :: Spec -> Text+pageImage spec =+    Text.concat [spec.region, "-docker.pkg.dev/", spec.project, "/", (repo spec).repoName, "/page:", spec.imageTag] +{- | What the page's image is built from. It has to serve a directory on port+80 and nothing else; this one is small and is what the quadlet node's own+tests run.+-}+pageBaseImage :: Text+pageBaseImage = "docker.io/library/nginx:alpine"++-- | The page: the project, which the driver looks for, and the image it came in.+pageText :: Spec -> Text+pageText spec =+    "served by salmon-gcp-toy from " <> spec.project <> ", in a container pulled from " <> pageImage spec <> "\n"++{- | 'pageImage', built on the control side and pushed to the toy's+repository.++A second image beside tier 1's, not the same one: Cloud Run's must listen on+@$PORT@ and may be the caller's own @--containerfile@, and this one has to+carry a page naming the project. They share the login (same auth file, same+registry, so one node) and the repository.++The build has no @check@ and neither has the push, so both run at every+pass, as tier 1's do. The tag is @--image-tag@: a page changed under an+unchanged tag is pushed, and not pulled by a VM that already holds that tag+(see 'Quadlet.imageNode').+-}+pagePushed :: Spec -> Op+pagePushed spec =+    Podman.pushLoggingIn reportPrint ignoreTrack authFile registry user Core.printAccessToken (pageImage spec)+        `inject` built+        `inject` loggedIn+  where+    authFile = Podman.AuthFile (spec.workDir <> "/podman-auth.json")+    registry = ArtifactRegistry.dockerRegistry (regionOf spec)+    user = Podman.Username "oauth2accesstoken"+    dir = spec.workDir <> "/page"++    loggedIn :: Op+    loggedIn =+        Podman.login reportPrint ignoreTrack authFile registry user Core.printAccessToken+            `inject` repository spec++    built :: Op+    built =+        Podman.buildImage reportPrint ignoreTrack containerfile (pageImage spec)+            `inject` FS.filecontents (FS.FileContents (dir <> "/index.html") (pageText spec))++    -- built with its own directory as context, which is where the page is+    containerfile :: FS.File "containerfile"+    containerfile =+        FS.generateFileContents+            ( Text.unlines+                [ "FROM " <> pageBaseImage+                , "COPY index.html /usr/share/nginx/html/index.html"+                ]+            )+            (dir <> "/Containerfile")+ control :: Spec -> Op control spec =     op "gcp-toy" (deps (tier0 spec <> (if spec.tier >= 1 then tier1 spec else []) <> (if spec.tier >= 2 then tier2 spec else []) <> (if spec.tier >= 3 then tier3 spec else []))) $ \actions ->@@ -442,8 +669,10 @@  -- | Whatever every project-scoped resource must wait for. foundation :: Spec -> [Op]-foundation spec = adc : catMaybes [projectNode, billingNode]+foundation spec = identity <> catMaybes [projectNode, billingNode]   where+    -- who acts: ADC is usable, and gcloud's active account is the declared one+    identity = adc : [Core.declaredAccount reportPrint Core.gcloud (Core.Account a) | Just a <- [spec.account]]     projectNode =         fmap             ( \parent ->@@ -451,7 +680,7 @@                     reportPrint                     Core.gcloud                     (ResourceManager.ProjectSpec (projectOf spec) (toParent parent) mempty)-                    `inject` adc+                    `injectAll` identity             )             spec.createProjectUnder     billingNode =@@ -460,10 +689,11 @@                 foldl                     inject                     (Billing.linkBillingAccount reportPrint Core.gcloud (projectOf spec) (Billing.BillingAccount acct))-                    (adc : catMaybes [projectNode])+                    (identity <> catMaybes [projectNode])             )             spec.billingAccount +    injectAll = foldl inject     toParent (OrganizationParent org) = ResourceManager.Organization org     toParent (FolderParent folder) = ResourceManager.Folder folder     toParent NoParentRef = ResourceManager.NoParent@@ -505,20 +735,72 @@ tier0 :: Spec -> [Op] tier0 spec =     [ grant spec "roles/storage.objectViewer" ("buckets/" <> bucketName) `inject` bucket-    , grant spec "roles/artifactregistry.reader" repoResource `inject` repository spec+    , registryReader spec     ]+        <> [dnsNameServers spec zone | zone <- maybe [] (pure . dnsZoneOf spec) spec.dnsZone]   where     -- bucket names are global: scoping by project id keeps two sandboxes apart     bucketName = spec.project <> "-" <> spec.prefix     bucket =         Storage.bucket reportPrint Core.gcloud (Storage.Bucket bucketName (projectOf spec) (regionOf spec) True)             `inject` api spec "storage.googleapis.com"++{- | The toy's service account may read the toy's repository. Tier 0 declares+it for its own sake; at tier 3 it is what lets the VM, which runs as that+account, pull its page.+-}+registryReader :: Spec -> Op+registryReader spec =+    grant spec "roles/artifactregistry.reader" repoResource `inject` repository spec+  where     repoResource =         Text.intercalate "/" ["projects", spec.project, "locations", spec.region, "repositories", (repo spec).repoName] +dnsZoneOf :: Spec -> Text -> CloudDns.ManagedZone+dnsZoneOf spec dnsName =+    CloudDns.ManagedZone (spec.prefix <> "-zone") (projectOf spec) dnsName "salmon-gcp-toy validation zone"++{- | The zone, and on top of it a node that reads back the name servers+Cloud DNS assigned and prints them: what an operator would enter at the+registrar to delegate the domain.++Printing is a node rather than something @main@ does because only a node+runs /after/ the zone's @up@. No @check@: it answers nothing about an+effect, so it prints on every pass, which is the point.+-}+dnsNameServers :: Spec -> CloudDns.ManagedZone -> Op+dnsNameServers spec zone =+    op "gcp-toy-dns-name-servers" (deps [dnsZoneNode spec zone]) $ \actions ->+        actions+            { help = Text.unwords ["prints the name servers assigned to", CloudDns.fqdn zone.zoneDnsName]+            , ref = mkRef "gcp-toy-dns-name-servers" (spec.project, zone.zoneName)+            , up = do+                servers <- CloudDns.readNameServers zone+                case servers of+                    Nothing -> throwIO (userError ("no name servers could be read for zone " <> Text.unpack zone.zoneName))+                    Just ns ->+                        putStrLn+                            ( Text.unpack+                                (Text.unwords (["name servers for", CloudDns.fqdn zone.zoneDnsName <> ":"] <> ns))+                            )+            }++dnsZoneNode :: Spec -> CloudDns.ManagedZone -> Op+dnsZoneNode spec zone =+    CloudDns.managedZone reportPrint Core.gcloud zone+        `inject` api spec CloudDns.dnsApi+ tier1 :: Spec -> [Op] tier1 spec =-    [ CloudRunDeploy.buildPushDeploy+    -- The API, the repository and the account go under the deploy (through+    -- 'CloudRunDeploy.buildPushDeployAfter'), and the API under every policy+    -- and channel (through 'CloudRunAlerts.standardAlertsAfter'): the nodes+    -- these return have no effect of their own, and injected onto them alone+    -- those were siblings of the deploy and of the policies. The injections+    -- onto them are kept, they leave those nodes' edges as they were.+    [ CloudRunDeploy.buildPushDeployAfter+        []+        [api spec "run.googleapis.com", repository spec, serviceAccount spec]         reportPrint         Core.gcloud         ignoreTrack@@ -540,7 +822,8 @@         `inject` repository spec         `inject` serviceAccount spec     ]-        <> [ CloudRunAlerts.standardAlerts+        <> [ CloudRunAlerts.standardAlertsAfter+            [api spec Monitoring.monitoringApi]             reportPrint             Core.gcloud             CloudRunAlerts.CloudRunAlertsConfig@@ -576,37 +859,40 @@ -- Tier 2: a VM, provisioned over an SSH CA by this same binary.  tier2 :: Spec -> [Op]-tier2 spec = case spec.vmConfig of-    Nothing -> []-    Just vm -> case vm.vmIp of-        -- First pass: the address does not have an IP yet, so nothing can-        -- name the machine. Declare the infrastructure and stop; the driver-        -- reads the IP and comes back with --vm-ip.-        Nothing -> [infrastructure spec vm]-        Just ip -> [provisioned spec vm ip]+tier2 spec = [provisioned spec vm | vm <- maybe [] pure spec.vmConfig] --- | The address, the firewall opening, the startup script, and the VM.-infrastructure :: Spec -> VmConfig -> Op-infrastructure spec vm =-    op "gcp-toy-vm-infra" (deps [instanceNode spec vm]) $ \actions ->-        actions-            { help = Text.unwords ["reserves an address and boots", vmName spec]-            , ref = mkRef "gcp-toy-vm-infra" (spec.project, vmName spec)-            }+{- | The machine, created and provisioned. -provisioned :: Spec -> VmConfig -> Text -> Op-provisioned spec vm ip =-    VmProvision.provisionedVm-        reportPrint-        Core.gcloud-        OS.sshClient+With @--vm-ip@ the host is declared and every node is an ordinary one.+Without it the host is read from the reserved address once the instance is+up, and what names the machine is a sub-graph walked from inside this node --+one pass instead of two, at the price of that sub-graph being opaque to+@run tree@.+-}+provisioned :: Spec -> VmConfig -> Op+provisioned spec vm = case vm.vmIp of+    Just ip ->+        VmProvision.provisionedVm reportPrint Core.gcloud OS.sshClient (at ip (config ip))+    Nothing ->+        VmProvision.provisionedVmReadingHost+            reportPrint+            Core.gcloud+            OS.sshClient+            (Compute.readAddress (addressSpec spec))+            at+            -- overwritten with the address read+            (config "")+  where+    at ip cfg = cfg{VmProvision.vmp_beforeCall = \opts -> [deliveredSecret spec vm ip opts]}++    config host =         VmProvision.VmProvisionConfig             { VmProvision.vmp_name = vmName spec             , VmProvision.vmp_instance = gceInstance spec vm             , VmProvision.vmp_ca = caKey spec             , VmProvision.vmp_clientIdentity = clientKey spec             , VmProvision.vmp_sshUser = vm.vmUser-            , VmProvision.vmp_sshHost = ip+            , VmProvision.vmp_sshHost = host             , VmProvision.vmp_sshPort = 22             , VmProvision.vmp_prerequisites = vmPrerequisites spec vm             , VmProvision.vmp_beforeCall = const []@@ -616,7 +902,32 @@             , VmProvision.vmp_directive = spec{role = OnVm}             } --- | The instance on its own, for the first pass (which has no IP to ssh to).+{- | A secret generated on the control side and put on the VM before the+uploaded binary runs: 'Secrets.sharedSecretFile' makes it, and+'SecretDelivery.uploadSecretFile' sends it over the connection the+provisioning already uses (the 'Ssh.ClientOpts' handed to @vmp_beforeCall@),+to be owned by root and readable by nobody else. 'secretRead' is the other+end.+-}+deliveredSecret :: Spec -> VmConfig -> Text -> Ssh.ClientOpts -> Op+deliveredSecret spec vm ip opts =+    SecretDelivery.uploadSecretFile+        opts+        reportPrint+        OS.ssh+        SecretDelivery.SecretUpload+            { SecretDelivery.uploadSource = localSecretPath spec+            , SecretDelivery.uploadRemote = Ssh.Remote vm.vmUser ip+            , SecretDelivery.uploadPlacement = secretPlacement+            , SecretDelivery.uploadElevation = SecretDelivery.WithSudo+            }+        `inject` Secrets.sharedSecretFile reportPrint ignoreTrack (Secrets.Secret Secrets.Hex (secretLength `div` 2) (localSecretPath spec))++localSecretPath :: Spec -> FilePath+localSecretPath spec = spec.workDir <> "/secrets/toy-secret"++-- | The instance on its own, for what stands on the machine rather than on+-- its being provisioned (the balancer's instance group). instanceNode :: Spec -> VmConfig -> Op instanceNode spec vm =     foldl inject (Compute.gceInstance reportPrint Core.gcloud (gceInstance spec vm)) (vmPrerequisites spec vm)@@ -630,10 +941,10 @@     [ computeApi     , -- The CA has to be in project metadata before the instance *boots*,       -- not merely before it is provisioned: the startup script reads the key-      -- at boot and nothing re-runs it afterwards. Declared here (rather than-      -- left to 'VmProvision', which only appears in the second pass) so the-      -- first pass -- the one that creates the VM -- carries it. Both-      -- declarations are the same node: same 'Ref', deduped by the fold.+      -- at boot and nothing re-runs it afterwards. Declared here as well as+      -- by 'VmProvision' so that 'instanceNode', which does not go through+      -- that recipe, carries it. Both declarations are the same node: same+      -- 'Ref', deduped by the fold.       sshCaInMetadata spec     , Compute.address reportPrint Core.gcloud (addressSpec spec) `inject` computeApi     , Compute.firewallRule@@ -648,8 +959,17 @@             , Compute.firewallTargetTags = [sshTag spec]             }         `inject` computeApi-    , FS.filecontents (FS.FileContents (startupScriptPath spec) (startupScript vm))+    , VmProvision.caTrustStartupScriptFile (startupScriptPath spec) vm.vmUser     ]+        -- The peer and the VM's own reservation come before the VM: the VM+        -- is pinned to an address that should be reserved first, and what it+        -- is provisioned to do is fetch a page from the peer.+        <> maybe [] (\peer -> [internalAddress (vmInternalAddressSpec spec peer) `inject` computeApi, peerInstance spec vm peer]) spec.peerConfig+        -- Tier 3: the instance is created /as/ the toy's service account, so+        -- the account comes first; and what the hand-off does on the machine+        -- is pull the page's image with that account, so the image is in the+        -- repository and the account may read it before there is a machine.+        <> (if spec.tier >= 3 then [serviceAccount spec, registryReader spec, pagePushed spec] else [])   where     -- every tier-2 resource is a Compute Engine one, and a fresh project has     -- that API off: addresses, firewall rules and instances all answer@@ -666,11 +986,100 @@         `inject` Keys.sshKey reportPrint OS.sshClient (caKey spec)  addressSpec :: Spec -> Compute.Address-addressSpec spec = Compute.Address (spec.prefix <> "-ip") (projectOf spec) (regionOf spec)+addressSpec spec = Compute.Address (spec.prefix <> "-ip") (projectOf spec) (regionOf spec) Compute.ExternalAddress +-- | The reservation behind the VM's pinned internal address.+vmInternalAddressSpec :: Spec -> PeerConfig -> Compute.Address+vmInternalAddressSpec spec peer =+    Compute.Address (spec.prefix <> "-vm-internal") (projectOf spec) (regionOf spec) (Compute.InternalAddress "default" (Just peer.peerVmInternalIp))++-- | The reservation behind the peer's.+peerInternalAddressSpec :: Spec -> PeerConfig -> Compute.Address+peerInternalAddressSpec spec peer =+    Compute.Address (spec.prefix <> "-peer-internal") (projectOf spec) (regionOf spec) (Compute.InternalAddress "default" (Just peer.peerInternalIp))++internalAddress :: Compute.Address -> Op+internalAddress = Compute.address reportPrint Core.gcloud++{- | The peer: an instance with no external address, pinned to a declared+internal one, serving one page to the tier-2 VM and to nothing else.++It is everything the pair of flags on 'Compute.Instance' is for. Its firewall+rule admits the VM by the @\/32@ the VM is pinned to, written before either+machine exists -- the shape of a @pg_hba.conf@ line naming a replication+peer. And with no external address it has no way out (the toy declares no+Cloud NAT), so its startup script may only use what the image ships:+@python3@, which every Ubuntu cloud image has.+-}+peerInstance :: Spec -> VmConfig -> PeerConfig -> Op+peerInstance spec vm peer =+    foldl+        inject+        (Compute.gceInstance reportPrint Core.gcloud inst)+        [ computeApi+        , internalAddress (peerInternalAddressSpec spec peer) `inject` computeApi+        , Compute.firewallRule+            reportPrint+            Core.gcloud+            Compute.FirewallRule+                { Compute.firewallName = spec.prefix <> "-peer"+                , Compute.firewallProject = projectOf spec+                , Compute.firewallNetwork = "default"+                , Compute.firewallAllow = "tcp:" <> Text.pack (show peer.peerPort)+                , Compute.firewallSourceRanges = [peer.peerVmInternalIp <> "/32"]+                , Compute.firewallTargetTags = [peerTag spec]+                }+            `inject` computeApi+        , FS.filecontents (FS.FileContents (peerStartupScriptPath spec) (peerStartupScript spec peer))+        ]+  where+    computeApi = api spec "compute.googleapis.com"+    inst =+        (gceInstance spec vm)+            { Compute.instanceName = peerName spec+            , Compute.instanceMetadataFiles = Map.fromList [("startup-script", peerStartupScriptPath spec)]+            , Compute.instanceExternalAddress = Compute.NoExternalAddress+            , Compute.instanceInternalAddress = Compute.PinnedInternal peer.peerInternalIp+            , Compute.instanceTags = [peerTag spec]+            , -- the peer pulls nothing: it stays the instance it was+              Compute.instanceServiceAccount = Nothing+            , Compute.instanceScopes = Compute.DefaultScopes+            , Compute.instanceMachineTypeChange = Compute.RefuseMachineTypeChange+            , Compute.instanceRunLimit = Compute.NoRunLimit+            }++{- | Serves one page naming the project, under a transient systemd unit so it+outlives the startup script. Idempotent, because a startup script runs on+every boot (and a transient unit does not survive one).+-}+peerStartupScript :: Spec -> PeerConfig -> Text+peerStartupScript spec peer =+    Text.unlines+        [ "#!/bin/bash"+        , "set -eux"+        , "mkdir -p /var/www/salmon-toy-peer"+        , "echo 'served by the salmon-gcp-toy peer of " <> spec.project <> "' > /var/www/salmon-toy-peer/index.html"+        , "systemctl reset-failed salmon-toy-peer 2>/dev/null || true"+        , "systemctl is-active --quiet salmon-toy-peer \\"+        , "  || systemd-run --unit salmon-toy-peer /usr/bin/python3 -m http.server " <> Text.pack (show peer.peerPort) <> " --bind 0.0.0.0 --directory /var/www/salmon-toy-peer"+        ]++{- | The tier-2 instance. At tier 3 it runs as the toy's own service account+with the @cloud-platform@ scope, which is what makes the metadata server's+token one Artifact Registry accepts: the account holds+@roles\/artifactregistry.reader@ on the toy's repository ('registryReader')+and little else, so the scope is wide and the role is what bounds it. Below+tier 3 the instance is declared as it always was (the project's default+account, gcloud's default scopes).++Like the tag below, both are fixed when the instance is created: a tier-2+instance taken to tier 3 keeps its account and its scopes, and+'Compute.gceInstance' fails on the scopes without changing them.+-} gceInstance :: Spec -> VmConfig -> Compute.Instance gceInstance spec vm =-    Compute.Instance+    VmProvision.withStartupScriptFile (startupScriptPath spec) $+      Compute.Instance         { Compute.instanceName = vmName spec         , Compute.instanceProject = projectOf spec         , Compute.instanceZone = Core.Zone vm.vmZone@@ -684,15 +1093,19 @@                 }         , Compute.instanceNetwork = "default"         , Compute.instanceSubnet = "default"-        , Compute.instanceServiceAccount = Nothing+        , Compute.instanceServiceAccount = if spec.tier >= 3 then Just (serviceAccountEmail spec) else Nothing         , Compute.instanceMetadata = Map.fromList [("enable-oslogin", "FALSE")]-        , Compute.instanceMetadataFiles = Map.fromList [("startup-script", startupScriptPath spec)]-        , Compute.instanceAddress = Just (addressSpec spec).addressName+        , Compute.instanceMetadataFiles = Map.empty+        , Compute.instanceExternalAddress = Compute.ReservedExternal (addressSpec spec).addressName+        , Compute.instanceInternalAddress = maybe Compute.EphemeralInternal (Compute.PinnedInternal . peerVmInternalIp) spec.peerConfig         , -- tags are fixed at create time, so the tier-3 one has to be on the           -- instance from the first pass -- there is no adding it later to a           -- machine the balancer has already been pointed at.           Compute.instanceTags = [sshTag spec] <> [lbTag spec | spec.tier >= 3]         , Compute.instancePower = Compute.PoweredOn+        , Compute.instanceScopes = if spec.tier >= 3 then Compute.DeclaredScopes ["cloud-platform"] else Compute.DefaultScopes+        , Compute.instanceMachineTypeChange = Compute.RefuseMachineTypeChange+        , Compute.instanceRunLimit = Compute.NoRunLimit         }  -------------------------------------------------------------------------------@@ -717,37 +1130,176 @@ -} tier3 :: Spec -> [Op] tier3 spec = case (spec.vmConfig, spec.lbConfig) of-    (Just vm, Just lb) -> [balancer spec vm lb]+    (Just vm, Just lb) ->+        balancer spec vm lb+            : concat+                [ balancerRecord spec vm lb zone+                    : [ certificateAuthorizationRecord spec vm lb zone authz+                      | (_domain, authz) <- LoadBalancing.dnsAuthorizations (albSpec spec vm lb)+                      ]+                | zone <- maybe [] (pure . dnsZoneOf spec) spec.dnsZone+                ]     _ -> [] +{- | With @--lb-https@: the @CNAME@ Certificate Manager wants in the zone+before it issues the balancer's certificate.++GCP picks the record's /name/ as well as its data (a per-project+authorization is @_acme-challenge_\<hash\>.lb.DNS_NAME@), so this cannot be+a 'CloudDns.resolvedRecordSet', whose identity is the name. It is a node+that reads the authorization once its node (one of the balancer's) has made+it and runs 'CloudDns.recordSet' for what it read as a nested walk -- checking the+returned 'Bool', since nothing else tells this pass the nested one failed.+No @check@: the nested node has one, so a second pass costs a @describe@.++On the way down the authorization is still there (this node goes before the+authorization's does), so the same read finds the record to delete; if it is+already gone there is no name left to delete by, and nothing is done.+-}+certificateAuthorizationRecord :: Spec -> VmConfig -> LbConfig -> CloudDns.ManagedZone -> Text -> Op+certificateAuthorizationRecord spec vm lb zone authz =+    op "gcp-toy-cert-authorization-record" (deps (dnsZoneNode spec zone : authorization)) $ \actions ->+        actions+            { help = Text.unwords ["publishes the DNS record of certificate authorization", authz]+            , ref = mkRef "gcp-toy-cert-authorization-record" (spec.project, zone.zoneName, authz)+            , up = do+                found <- readRecord+                case found of+                    Nothing -> throwIO (userError ("no DNS record could be read for authorization " <> Text.unpack authz))+                    Just rs -> nested "up" (UpDown.upTree silent (pure . runIdentity) (CloudDns.recordSet reportPrint Core.gcloud rs))+            , down = do+                found <- readRecord+                case found of+                    Nothing -> pure ()+                    Just rs -> nested "down" (UpDown.downTree silent (pure . runIdentity) (CloudDns.recordSet reportPrint Core.gcloud rs))+            }+  where+    -- the authorization alone, not the whole balancer: the record can be+    -- published while the rest of the balancer is still being made, which is+    -- also when the certificate starts waiting for it+    authorization :: [Op]+    authorization =+        maybe [balancer spec vm lb] pure $+            LoadBalancing.applicationLoadBalancerPart+                (balancerPrerequisites spec vm lb)+                reportPrint+                Core.gcloud+                (albSpec spec vm lb)+                (LoadBalancing.DnsAuthorizationPart authz)++    readRecord :: IO (Maybe CloudDns.RecordSet)+    readRecord = (>>= toRecordSet) <$> LoadBalancing.readDnsAuthorizationRecord (albSpec spec vm lb) authz++    -- Certificate Manager only ever asks for a CNAME; anything else is+    -- treated as unreadable rather than published as something it is not.+    toRecordSet :: LoadBalancing.DnsAuthorizationRecord -> Maybe CloudDns.RecordSet+    toRecordSet found+        | found.authorizationRecordType == "CNAME" =+            Just (CloudDns.RecordSet zone found.authorizationRecordName CloudDns.CNAME 300 [found.authorizationRecordData])+        | otherwise = Nothing++    nested :: String -> IO Bool -> IO ()+    nested what act = do+        ok <- act+        when (not ok) $ throwIO (userError ("authorization record " <> what <> " failed for " <> Text.unpack authz))++-- | The name the toy serves over HTTPS, without the trailing dot.+httpsHost :: Spec -> LbConfig -> Maybe Text+httpsHost spec lb = case (lb.lbHttps, spec.dnsZone) of+    (Just True, Just dnsName) -> Just ("lb." <> dnsName)+    _ -> Nothing++{- | With @--dns-zone@: @lb.DNS_NAME@, an @A@ record at the balancer's+address.++GCP picks that address when the forwarding rule is created, so the record's+data is resolved at @up@ ('CloudDns.resolvedRecordSet' over+'LoadBalancing.readAddress') rather than declared -- which is what spares+this a pass of its own, where the VM's address needs one because a /seed/+has to carry it. The zone goes underneath as well as the balancer: Cloud DNS+refuses to delete a zone that still holds the record.+-}+balancerRecord :: Spec -> VmConfig -> LbConfig -> CloudDns.ManagedZone -> Op+balancerRecord spec vm lb zone =+    CloudDns.resolvedRecordSet+        reportPrint+        Core.gcloud+        (CloudDns.RecordSet zone (balancerRecordName zone) CloudDns.A 300 [])+        (fmap pure <$> LoadBalancing.readAddress (albSpec spec vm lb))+        `inject` dnsZoneNode spec zone+        `inject` balancer spec vm lb++-- | The name the toy points at its balancer.+balancerRecordName :: CloudDns.ManagedZone -> Text+balancerRecordName zone = "lb." <> CloudDns.fqdn zone.zoneDnsName++albSpec :: Spec -> VmConfig -> LbConfig -> LoadBalancing.ApplicationLoadBalancer+albSpec spec vm lb =+    LoadBalancing.ApplicationLoadBalancer+        { LoadBalancing.albName = spec.prefix <> "-lb"+        , LoadBalancing.albProject = projectOf spec+        , LoadBalancing.albRegion = regionOf spec+        , -- omitted rather than "default": the forwarding rule falls back+          -- to the default network, which is the one everything else here+          -- is on, and naming it is one more thing to get wrong.+          LoadBalancing.albNetwork = Nothing+        , LoadBalancing.albBackends = [group]+        , LoadBalancing.albHealthCheck = Just healthCheck+        , LoadBalancing.albTimeoutSec = Nothing+        , -- Everything below is --lb-https only, and is there to put each+          -- thing the balancer can express through a real project once: a+          -- second backend service (the same group, a longer timeout), a+          -- host rule, a path rule to that service, a managed certificate.+          -- The VM serves one page, so /slow/* answers 404 through the+          -- balancer -- the rule is to be read back from the URL map.+          LoadBalancing.albServices =+            [ LoadBalancing.BackendService "slow" [group] (Just healthCheck) (Just 120)+            | _ <- hosts+            ]+        , LoadBalancing.albHostRules =+            [ LoadBalancing.HostRule+                [host]+                LoadBalancing.DefaultService+                [LoadBalancing.PathRule ["/slow/*"] (LoadBalancing.NamedService "slow") LoadBalancing.KeepPath]+            | host <- hosts+            ]+        , LoadBalancing.albCertificates =+            [ LoadBalancing.ManagedCertificate (spec.prefix <> "-lb-cert") [host]+            | host <- hosts+            ]+        , -- not exercised by the toy: no backend bucket (a rule routing to+          -- one is refused, see 'LoadBalancing.BucketRoutes'), and port 80 as+          -- it always was (a proxy created once on the balancer's own map)+          LoadBalancing.albBuckets = []+        , LoadBalancing.albBucketRoutes = LoadBalancing.RefuseBucketRoutes+        , LoadBalancing.albHttp = LoadBalancing.HttpCreatedOnce+        }+  where+    hosts = maybe [] pure (httpsHost spec lb)+    healthCheck = LoadBalancing.HealthCheck (spec.prefix <> "-hc") lb.lbPort+    group =+        LoadBalancing.InstanceGroupBackend+            (instanceGroupSpec spec vm).groupName+            (LoadBalancing.InstanceGroupZone vm.vmZone)+            [lb.lbPort]+ balancer :: Spec -> VmConfig -> LbConfig -> Op balancer spec vm lb =-    foldl-        inject-        (LoadBalancing.applicationLoadBalancer reportPrint Core.gcloud alb)-        ([proxySubnet, membership, backendFirewall] <> served)+    LoadBalancing.applicationLoadBalancerAfter (balancerPrerequisites spec vm lb) reportPrint Core.gcloud (albSpec spec vm lb)++{- | What has to be there before any of the balancer's resources is made.+Handed to the balancer rather than @inject@ed into it: the balancer is a+node per resource under a root, and a dependency of the root alone would+order nothing.+-}+balancerPrerequisites :: Spec -> VmConfig -> LbConfig -> [Op]+balancerPrerequisites spec vm lb =+    [proxySubnet, membership, backendFirewall]+        <> [api spec LoadBalancing.certificateManagerApi | _ <- maybe [] pure (httpsHost spec lb)]+        <> served   where     computeApi = api spec "compute.googleapis.com" -    alb :: LoadBalancing.ApplicationLoadBalancer-    alb =-        LoadBalancing.ApplicationLoadBalancer-            { LoadBalancing.albName = spec.prefix <> "-lb"-            , LoadBalancing.albProject = projectOf spec-            , LoadBalancing.albRegion = regionOf spec-            , -- omitted rather than "default": the forwarding rule falls back-              -- to the default network, which is the one everything else here-              -- is on, and naming it is one more thing to get wrong.-              LoadBalancing.albNetwork = Nothing-            , LoadBalancing.albBackends =-                [ LoadBalancing.InstanceGroupBackend-                    (instanceGroupSpec spec vm).groupName-                    (LoadBalancing.InstanceGroupZone vm.vmZone)-                    [lb.lbPort]-                ]-            , LoadBalancing.albHealthCheck = Just (LoadBalancing.HealthCheck (spec.prefix <> "-hc") lb.lbPort)-            }-     proxySubnet :: Op     proxySubnet =         Compute.subnet@@ -793,13 +1345,10 @@                 }             `inject` computeApi -    -- On the pass that knows the IP, the balancer is declared *after* the-    -- machine has been provisioned, so the backend is already serving by the-    -- time the first health check runs. On the first pass there is no such-    -- node and the balancer simply comes up in front of an unhealthy backend,-    -- which is legal and is what the second pass fixes.+    -- The balancer is declared *after* the machine has been provisioned, so+    -- the backend is already serving by the time the first health check runs.     served :: [Op]-    served = maybe [] (\ip -> [provisioned spec vm ip]) vm.vmIp+    served = [provisioned spec vm]  instanceGroupSpec :: Spec -> VmConfig -> Compute.InstanceGroup instanceGroupSpec spec vm =@@ -808,6 +1357,16 @@ vmName :: Spec -> Text vmName spec = spec.prefix <> "-vm" +peerName :: Spec -> Text+peerName spec = spec.prefix <> "-peer"++-- | The tag the peer's firewall rule targets.+peerTag :: Spec -> Text+peerTag spec = spec.prefix <> "-peer"++peerStartupScriptPath :: Spec -> FilePath+peerStartupScriptPath spec = spec.workDir <> "/peer-startup-script.sh"+ sshTag :: Spec -> Text sshTag spec = spec.prefix <> "-ssh" @@ -824,43 +1383,3 @@ clientKey :: Spec -> Keys.SSHKeyPair clientKey spec = Keys.SSHKeyPair Keys.ED25519 (spec.workDir <> "/ssh") "toy-client" -{- | What makes the VM trust the CA at all -- the piece-'Salmon.Builtin.Nodes.Gcp.SshAccess'.@installMetadataCaKey@ deliberately does-not do: it publishes the CA's public key as project metadata, and nothing on-a GCE instance reads that key by itself.--It also creates the login user the certificate names as its principal (with-no OS Login, a principal has to be a local account), gives it passwordless-sudo (@uploadAndCallSelfAsSudo@ runs the uploaded binary under sudo), and-makes sure rsync is there for the upload. Idempotent, because a startup-script runs on every boot.--}-startupScript :: VmConfig -> Text-startupScript vm =-    Text.unlines-        [ "#!/bin/bash"-        , "set -eux"-        , -- The key is published just before the instance is created, and-          -- "just before" is not "already visible from inside the guest": a-          -- 404 here used to abort the whole script under `set -e`, leaving a-          -- VM with no CA, no login user and an sshd that was never-          -- restarted. Waiting is cheap; the alternative is a VM that can-          -- only be fixed by a reset.-          "for attempt in $(seq 1 30); do"-        , "  if curl -fsS -H 'Metadata-Flavor: Google' \\"-        , "      http://metadata.google.internal/computeMetadata/v1/project/attributes/ssh-ca \\"-        , "      > /etc/ssh/salmon_ca.pub; then break; fi"-        , "  echo \"ssh-ca not in metadata yet (attempt $attempt)\"; sleep 2"-        , "done"-        , "test -s /etc/ssh/salmon_ca.pub"-        , "chmod 644 /etc/ssh/salmon_ca.pub"-        , "grep -qxF 'TrustedUserCAKeys /etc/ssh/salmon_ca.pub' /etc/ssh/sshd_config \\"-        , "  || echo 'TrustedUserCAKeys /etc/ssh/salmon_ca.pub' >> /etc/ssh/sshd_config"-        , "id -u " <> user <> " >/dev/null 2>&1 || useradd -m -s /bin/bash " <> user-        , "printf '%s ALL=(ALL) NOPASSWD:ALL\\n' " <> user <> " > /etc/sudoers.d/" <> user-        , "chmod 440 /etc/sudoers.d/" <> user-        , "command -v rsync >/dev/null || { apt-get update -qq && apt-get install -y rsync; }"-        , "systemctl restart ssh || systemctl restart sshd"-        ]-  where-    user = vm.vmUser

@@ -67,13 +67,22 @@   where     initPg = Track (\connstring -> initdb connstring `inject` passfile connstring) +    -- The owner's password file is 'FS.Generated' by the same node as+    -- 'passfile', so the owner's role (created inside 'PGInit.setupPG', and+    -- reading that file) waits for it. Injected onto the 'initdb' node alone,+    -- it was a sibling of that role and nothing ordered the two: 'initdb'+    -- only groups the nodes doing the work. The injection is kept, it+    -- leaves that node's edges as they were.     initdb :: Postgres.ConnString FilePath -> Op     initdb ownerConnstring =-        PGInit.setupMultiUserPG+        PGInit.setupPG             reportPrint-            ownerConnstring-            [(u, p, [], []) | (u, p) <- users]-            []+            ( PGInit.InitSetup+                ownerConnstring.connstring_db+                (ownerConnstring.connstring_user, FS.Generated extrapassfile ownerConnstring.connstring_user_pass)+                [(u, p, [], []) | (u, p) <- users]+                []+            )      users :: [(Postgres.User, FS.File "passfile")]     users = [(u, FS.Generated extrapassfile p) | (u, p) <- arg.setup_extra_users]

@@ -6,7 +6,10 @@  The guests have no network past boot, so every package a scenario needs is baked in here: @postgresql@, @patroni@, @etcd-server@ and @haproxy@ on all-three machines (a scenario decides which member runs which). It is the+three machines (a scenario decides which member runs which), plus+@python3-etcd@ (Debian's @patroni@ does not depend on it, and without it+Patroni has no etcd implementation at all) and @pgbackrest@ for the archive+scenarios. It is the same shape as @salmon-toy-qemu-pg-ha prereqs@ -- 'Debootstrap.rootTree' plus 'Debootstrap.ensureVm9pBoot' -- and is the only part that needs root: @@ -88,7 +91,7 @@ patroniPackages :: Debootstrap.Includes patroniPackages =     Debootstrap.vmEssentials-        <> map Package ["postgresql", "sudo", "patroni", "etcd-server", "etcd-client", "haproxy"]+        <> map Package ["postgresql", "sudo", "patroni", "python3-etcd", "pgbackrest", "etcd-server", "etcd-client", "haproxy"]  configure :: Configure IO Seed Spec configure = Configure $ \(SeedPrereqs root) -> Prereqs root <$> unprivilegedUser

@@ -13,14 +13,17 @@ What it assumes was done before it ever ran, because a recipe that ships secrets has chosen a transport for everybody who uses it: the two machines have a Postgres cluster, the bouncer has pgbouncer and a @userlist.txt@, and-all three have the @.pgpass@ files named below. See @specs\/pg-switchover.md@.+all three have the @.pgpass@ files named below. See @specs\/pg-switchover.md@,+and "SreBox.PostgresPairPrereqs" for that layer as nodes, which a binary+composing the pair as a library can declare (this one does not). -} module PgPair (main) where -import Control.Applicative ((<|>))+import Control.Applicative (many, (<|>)) import Data.Text (Text) import qualified Data.Text as Text-import Options.Applicative (auto, execParser, fullDesc, header, help, helper, info, long, option, optional, progDesc, strOption, value, (<**>))+import Control.Exception (throwIO)+import Options.Applicative (auto, execParser, fullDesc, header, help, helper, info, long, option, optional, progDesc, strOption, switch, value, (<**>)) import Options.Generic (ParseRecord (..))  import qualified Salmon.Actions.Serve as Serve@@ -46,7 +49,10 @@ program = Track (Pair.pairOp reportPrint)  configure :: Configure IO Seed Pair.Pair-configure = Configure (pure . toPair)+configure = Configure $ \seed ->+    case toPair seed of+        Right pair -> pure pair+        Left why -> throwIO (userError ("salmon-pgpair: " <> why))  {- | What an operator types. Everything else about the pair is convention, which is what makes the interesting part -- @--primary@ -- short enough to@@ -61,15 +67,36 @@     , seedReseed :: Maybe Side     , seedHostA :: Text     , seedHostB :: Text+    , seedSshA :: Maybe Text+    , seedSshB :: Maybe Text     , seedBouncer :: Maybe Text     , seedIdentity :: Maybe FilePath     , seedIdentityA :: Maybe FilePath     , seedIdentityB :: Maybe FilePath     , seedIdentityBouncer :: Maybe FilePath     , seedKnownHosts :: Maybe FilePath+    , seedSshUser :: Text     , seedDatabase :: Text+    , seedAlsoDatabases :: [Text]+    , seedConnSecurity :: Security+    , seedTlsCa :: Maybe FilePath+    , seedTlsVerifyFull :: Bool+    , seedTlsServerCert :: Maybe FilePath+    , seedTlsServerKey :: Maybe FilePath     } +{- | @--conn-security@'s three words. The weakest is the default and has the+plain name, because it is what every pair made before the flag existed is.+-}+data Security = Plain | TlsScram | TlsCert++instance Read Security where+    readsPrec _ s = case span (`notElem` (" \t" :: String)) s of+        ("plain", rest) -> [(Plain, rest)]+        ("tls-scram", rest) -> [(TlsScram, rest)]+        ("tls-cert", rest) -> [(TlsCert, rest)]+        _ -> []+ -- | Parsed rather than derived, so that @--primary A@ is what it looks like. newtype Side = Side {unSide :: Pair.Side} @@ -111,6 +138,11 @@                     )                 <*> strOption (long "a" <> help "machine A")                 <*> strOption (long "b" <> help "machine B")+                -- the address the peer and the bouncers use is not always+                -- one the controller can reach: a VPC's internal address+                -- against the external one an operator sees.+                <*> optional (strOption (long "ssh-a" <> help "where to ssh for machine A, when that is not the address its peer reaches it on (--a)"))+                <*> optional (strOption (long "ssh-b" <> help "where to ssh for machine B, when that is not the address its peer reaches it on (--b)"))                 <*> optional (strOption (long "bouncer" <> help "a pgbouncer whose clients should follow the primary"))                 <*> optional (strOption (long "ssh-identity" <> help "a key to reach the machines with"))                 -- a fleet usually has one key; these exist because a test@@ -119,14 +151,74 @@                 <*> optional (strOption (long "ssh-identity-b" <> help "a key for machine B alone"))                 <*> optional (strOption (long "ssh-identity-bouncer" <> help "a key for the bouncer alone"))                 <*> optional (strOption (long "ssh-known-hosts" <> help "a known-hosts file to learn the machines' keys into"))+                -- stock cloud images refuse root logins; anything but root+                -- has every script run under one `sudo -n`.+                <*> strOption (long "ssh-user" <> help "who to ssh as, on the machines and the bouncer: root, or a login with passwordless sudo" <> value "root")                 <*> strOption (long "db" <> help "the database clients connect to" <> value "app")+                <*> many (strOption (long "also-db" <> help "another database of the pair the same bouncer routes, moved in the same pause and reload as --db; repeatable"))+                <*> option+                    auto+                    ( long "conn-security"+                        <> help "what the replication and rewind connections between the two machines must be: plain (host, md5, TLS not required; the default), tls-scram (hostssl, scram-sha-256) or tls-cert (hostssl, client certificates pre-provisioned on both machines as /etc/postgresql/salmon-{replication,rewind}.{crt,key})"+                        <> value Plain+                    )+                <*> optional (strOption (long "tls-ca" <> help "a CA certificate, on both machines, to verify the other machine's certificate against (sslmode=verify-ca); without it a TLS connection is encrypted and the server is not verified"))+                <*> switch (long "tls-verify-full" <> help "with --tls-ca: also require the other machine's certificate to name the address given as --a/--b")+                <*> optional (strOption (long "tls-server-cert" <> help "the certificate each machine serves TLS with, pre-provisioned at this path on both; without it the cluster's TLS settings are left as found"))+                <*> optional (strOption (long "tls-server-key" <> help "its key, readable by postgres alone")) -toPair :: Seed -> Pair.Pair-toPair seed =+toPair :: Seed -> Either String Pair.Pair+toPair seed = do+    security <- connSecurity seed+    let pair = (plainPair seed){Pair.pair_conn_security = security}+    case Pair.securityProblems pair <> Pair.bouncerProblems pair of+        [] -> Right pair+        problems -> Left (Text.unpack (Text.intercalate "; " problems))++{- | The flags as a 'Pair.ConnSecurity', or what is contradictory about them.+'Nothing' for @plain@, so that such a directive is byte for byte what it was+before the flag existed.+-}+connSecurity :: Seed -> Either String (Maybe Pair.ConnSecurity)+connSecurity seed = case seed.seedConnSecurity of+    Plain+        | tlsFlagGiven -> Left "--tls-ca, --tls-verify-full, --tls-server-cert and --tls-server-key mean nothing with --conn-security plain"+        | otherwise -> Right Nothing+    TlsScram -> Just . Pair.TlsScram <$> tls+    TlsCert -> do+        t <- tls+        pure . Just $+            Pair.TlsClientCert+                t+                Pair.ClientCerts+                    { Pair.client_repl_cert = "/etc/postgresql/salmon-replication.crt"+                    , Pair.client_repl_key = "/etc/postgresql/salmon-replication.key"+                    , Pair.client_rewind_cert = "/etc/postgresql/salmon-rewind.crt"+                    , Pair.client_rewind_key = "/etc/postgresql/salmon-rewind.key"+                    }+  where+    tlsFlagGiven =+        seed.seedTlsVerifyFull+            || any (/= Nothing) [seed.seedTlsCa, seed.seedTlsServerCert, seed.seedTlsServerKey]+    tls = Pair.Tls <$> check <*> server+    check = case (seed.seedTlsCa, seed.seedTlsVerifyFull) of+        (Nothing, False) -> Right Pair.Encrypted+        (Nothing, True) -> Left "--tls-verify-full needs --tls-ca: there is nothing to verify a name against"+        (Just ca, False) -> Right (Pair.VerifyCa ca)+        (Just ca, True) -> Right (Pair.VerifyFull ca)+    server = case (seed.seedTlsServerCert, seed.seedTlsServerKey) of+        (Nothing, Nothing) -> Right Nothing+        -- the CA that signs the servers is taken to sign the clients too:+        -- one CA per pair is the convention this binary is made of.+        (Just cert, Just key) -> Right (Just (Pair.ServerFiles cert key seed.seedTlsCa))+        _ -> Left "--tls-server-cert and --tls-server-key go together"++plainPair :: Seed -> Pair.Pair+plainPair seed =     Pair.Pair         { Pair.pair_name = seed.seedName-        , Pair.pair_a = machine (seed.seedIdentityA <|> seed.seedIdentity) seed.seedHostA-        , Pair.pair_b = machine (seed.seedIdentityB <|> seed.seedIdentity) seed.seedHostB+        , Pair.pair_a = machine (seed.seedIdentityA <|> seed.seedIdentity) seed.seedSshA seed.seedHostA+        , Pair.pair_b = machine (seed.seedIdentityB <|> seed.seedIdentity) seed.seedSshB seed.seedHostB         , Pair.pair_primary = unSide seed.seedPrimary         , Pair.pair_repl_role = "replicator"         , Pair.pair_repl_passfile = "/etc/postgresql/salmon-replication.pgpass"@@ -141,11 +233,13 @@         , Pair.pair_bouncers = foldMap (pure . bouncer) seed.seedBouncer         , Pair.pair_may_discard = fmap unSide seed.seedMayDiscard         , Pair.pair_reseed = fmap unSide seed.seedReseed+        , Pair.pair_conn_security = Nothing         }   where-    machine identity host =+    machine identity sshHost host =         Pair.Member-            { Pair.member_ssh_user = "root"+            { Pair.member_ssh_user = seed.seedSshUser+            , Pair.member_ssh_host = sshHost             , Pair.member_host = host             , Pair.member_cluster = "main"             , Pair.member_port = 5432@@ -155,7 +249,7 @@     bouncer host =         Pair.Bouncer             { Pair.bouncer_name = host-            , Pair.bouncer_ssh_user = "root"+            , Pair.bouncer_ssh_user = seed.seedSshUser             , Pair.bouncer_ssh_host = host             , Pair.bouncer_ssh_identity = seed.seedIdentityBouncer <|> seed.seedIdentity             , -- pgbouncer's admin console is an ordinary connection to the@@ -168,4 +262,9 @@             , Pair.bouncer_routing_path = "/etc/pgbouncer/routing.ini"             , Pair.bouncer_config_dir = "/etc/pgbouncer"             , Pair.bouncer_listen_port = 6432+            , -- Nothing rather than an empty list, so that a seed with no+              -- --also-db configures to the directive it always did+              Pair.bouncer_more_databases = case seed.seedAlsoDatabases of+                [] -> Nothing+                more -> Just [Pair.RoutedDatabase db db | db <- more]             }

@@ -0,0 +1,240 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++{- | @salmon-pgvector-demo@: index a directory into pgvector, then search it+by similarity ("SreBox.PgVectorDemo").++@+salmon-pgvector-demo config --dir ~/notes --hash-dimension 64 > demo.json+salmon-pgvector-demo run up < demo.json+salmon-pgvector-demo search --text "salmon swim upstream" < demo.json+salmon-pgvector-demo search --image cat.jpg < demo.json+@++@search@ reads the same directive as @run@, so it embeds the query with the+embedder the rows were made with. It only reads.++The embedder is one of three, chosen by flags: @--hash-dimension N@ (the+stand-in, no model: it shows the plumbing, not meaning), @--llama-*@ (a+llama-server under systemd, text only) or @--clip-*@ (clip.cpp, text and+images). Releases, models and their sha256 are the operator's to pin, and a+model with no @--…-model-url@ must already be at its path. The local cluster+and the database are created when missing; the pgvector package comes from+the PostgreSQL project's repository when @--pgdg-key@ names its (already+provisioned) key, and must otherwise be installable as is.+-}+module PgVectorDemo (+    main,+    Seed (..),+    Spec (..),+    EmbedderSpec (..),+    configure,+    program,+    embedderOf,+) where++import Data.Aeson (FromJSON, ToJSON)+import qualified Data.Aeson as Aeson+import qualified Data.ByteString.Lazy as LByteString+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import GHC.Generics (Generic)+import Options.Applicative (auto, execParser, fullDesc, header, helper, info, long, metavar, option, optional, progDesc, strOption, value, (<**>), (<|>))+import qualified Options.Applicative as Opt+import Options.Generic (ParseRecord (..))+import System.Directory (makeAbsolute)+import System.Environment (getArgs, withArgs)+import System.Exit (exitFailure)+import System.IO (hPutStrLn, stderr)+import Text.Printf (printf)++import qualified Salmon.Builtin.CommandLine as CLI+import Salmon.Builtin.Extension+import qualified Salmon.Builtin.Nodes.ClipCpp as ClipCpp+import Salmon.Builtin.Nodes.Debian.AptRepository (pgdg, viaRepository)+import qualified Salmon.Builtin.Nodes.Debian.OS as Debian+import Salmon.Builtin.Nodes.LlamaServer (LlamaRelease (..), LlamaServer (..), Listen (..), ModelFile (..), Pooling (..), defaultLlamaServer, llamaServerSystemd)+import qualified Salmon.Builtin.Nodes.Postgres as Postgres+import Salmon.Op.Configure (Configure (..))+import Salmon.Op.Track (Track (..))+import Salmon.Reporter (reportPrint)++import SreBox.PgVectorDemo (Demo (..), Embedder, Hit (..), Input (..), clipEmbedder, defaultWalkPolicy, hashEmbedder, llamaEmbedder, pgVectorDemo, search)++main :: IO ()+main = do+    args <- getArgs+    case args of+        ("search" : rest) -> withArgs rest searchMain+        _ -> do+            let desc = fullDesc <> progDesc "Index a directory into pgvector (search it with: search --text T | --image P)" <> header "salmon-pgvector-demo"+            cmd <- execParser (info parseRecord desc)+            CLI.execCommandOrSeed reportPrint configure program cmd++-------------------------------------------------------------------------------+-- Seed++data Seed = Seed+    { seedDir :: FilePath+    , seedDatabase :: Text+    , seedTable :: Text+    , seedPort :: Int+    , seedMajor :: Int+    , seedPgdg :: Maybe (FilePath, Text)+    , seedEmbedder :: EmbedderSpec+    }+    deriving (Eq, Show)++instance ParseRecord Seed where+    parseRecord = build <**> helper+      where+        build =+            Seed+                <$> strOption (long "dir" <> metavar "DIR" <> Opt.help "the directory to index")+                <*> strOption (long "database" <> value "vectors" <> Opt.showDefault)+                <*> strOption (long "table" <> value "items" <> Opt.showDefault <> Opt.help "another width wants another table")+                <*> option auto (long "port" <> value 5432 <> Opt.showDefault)+                <*> option auto (long "major" <> value 17 <> Opt.showDefault <> Opt.help "the cluster's PostgreSQL major version, for the pgvector package")+                <*> optional ((,) <$> strOption (long "pgdg-key" <> metavar "PATH" <> Opt.help "the PostgreSQL apt repository's key, already provisioned") <*> strOption (long "pgdg-fingerprint" <> metavar "FPR"))+                <*> embedderP+        embedderP = hashP <|> llamaP <|> clipP+        hashP = HashSpec <$> option auto (long "hash-dimension" <> metavar "N" <> Opt.help "the sha256 stand-in: no model, no meaning")+        llamaP =+            LlamaSpec+                <$> strOption (long "llama-build" <> metavar "bNNNN")+                <*> strOption (long "llama-archive-url" <> metavar "URL")+                <*> strOption (long "llama-archive-sha256" <> metavar "HEX")+                <*> strOption (long "llama-install-dir" <> value "/opt/salmon/llama" <> Opt.showDefault)+                <*> strOption (long "llama-model" <> metavar "PATH" <> Opt.help "a GGUF embedding model")+                <*> strOption (long "llama-model-sha256" <> metavar "HEX")+                <*> optional (strOption (long "llama-model-url" <> metavar "URL"))+                <*> option auto (long "dimension" <> metavar "N" <> Opt.help "what the model produces")+                <*> strOption (long "llama-pooling" <> value "mean" <> Opt.showDefault <> Opt.help "none|mean|cls|last|rank, as the model wants")+                <*> option auto (long "llama-port" <> value 8080 <> Opt.showDefault <> Opt.help "on loopback")+                <*> optional (strOption (long "llama-api-key-file" <> metavar "PATH" <> Opt.help "keys, one per line, already provisioned"))+        clipP =+            ClipSpec+                <$> strOption (long "clip-dir" <> metavar "DIR" <> Opt.help "where clip.cpp is checked out and built")+                <*> strOption (long "clip-commit" <> value ClipCpp.knownCommit <> Opt.showDefault)+                <*> strOption (long "clip-model" <> metavar "PATH" <> Opt.help "a two-tower GGUF CLIP model")+                <*> strOption (long "clip-model-sha256" <> metavar "HEX")+                <*> optional (strOption (long "clip-model-url" <> metavar "URL"))+                <*> option auto (long "clip-dimension" <> metavar "N" <> Opt.help "what the model produces (512 for ViT-B/32)")++-------------------------------------------------------------------------------+-- Spec++data EmbedderSpec+    = HashSpec {hashDimension :: Int}+    | LlamaSpec+        { llamaBuild :: Text+        , llamaArchiveUrl :: Text+        , llamaArchiveSha256 :: Text+        , llamaInstallDir :: FilePath+        , llamaModel :: FilePath+        , llamaModelSha256 :: Text+        , llamaModelUrl :: Maybe Text+        , llamaDimension :: Int+        , llamaPooling :: Text+        , llamaPort :: Int+        , llamaApiKeyFile :: Maybe FilePath+        }+    | ClipSpec+        { clipDir :: FilePath+        , clipCommit :: Text+        , clipModel :: FilePath+        , clipModelSha256 :: Text+        , clipModelUrl :: Maybe Text+        , clipDimension :: Int+        }+    deriving (Eq, Show, Generic)++instance FromJSON EmbedderSpec+instance ToJSON EmbedderSpec++data Spec = Spec+    { directory :: FilePath+    , database :: Text+    , table :: Text+    , port :: Int+    , major :: Int+    , pgdgKey :: Maybe (FilePath, Text)+    , embedder :: EmbedderSpec+    }+    deriving (Eq, Show, Generic)++instance FromJSON Spec+instance ToJSON Spec++configure :: Configure IO Seed Spec+configure = Configure $ \seed -> do+    case seed.seedEmbedder of+        LlamaSpec{llamaPooling = p} | Nothing <- pooling p -> fail ("--llama-pooling: not one of none|mean|cls|last|rank: " <> Text.unpack p)+        ClipSpec{clipCommit = c} | not (ClipCpp.validCommit c) -> fail "--clip-commit must be a full commit id"+        _ -> pure ()+    dir <- makeAbsolute seed.seedDir+    pure (Spec dir seed.seedDatabase seed.seedTable seed.seedPort seed.seedMajor seed.seedPgdg seed.seedEmbedder)++pooling :: Text -> Maybe Pooling+pooling t = lookup t [("none", PoolNone), ("mean", PoolMean), ("cls", PoolCls), ("last", PoolLast), ("rank", PoolRank)]++-------------------------------------------------------------------------------+-- Program++demoOf :: Spec -> Demo+demoOf spec = Demo spec.directory spec.major spec.port spec.database spec.table defaultWalkPolicy++embedderOf :: EmbedderSpec -> Embedder+embedderOf e = case e of+    HashSpec n -> hashEmbedder n+    LlamaSpec{} ->+        let rel = LlamaRelease e.llamaBuild e.llamaArchiveUrl e.llamaArchiveSha256 e.llamaInstallDir+            model = ModelFile e.llamaModel e.llamaModelSha256 e.llamaModelUrl+            server =+                (defaultLlamaServer "pgvector-demo" rel model e.llamaDimension (maybe PoolMean id (pooling e.llamaPooling)))+                    { lsListen = Loopback e.llamaPort+                    , lsApiKeyFile = e.llamaApiKeyFile+                    }+         in llamaEmbedder (llamaServerSystemd reportPrint Debian.systemctl server) server+    ClipSpec{} ->+        let src = (ClipCpp.clipSourceAt e.clipDir){ClipCpp.clipCommit = e.clipCommit}+            model = ModelFile e.clipModel e.clipModelSha256 e.clipModelUrl+         in clipEmbedder reportPrint ClipCpp.debianTools (ClipCpp.defaultClipCpp src model e.clipDimension)++program :: Track' Spec+program = Track $ \spec ->+    pgVectorDemo+        reportPrint+        reportPrint+        reportPrint+        Debian.psql+        (maybe ignoreTrack (\(key, fpr) -> viaRepository (pgdg key fpr)) spec.pgdgKey)+        (Track $ Postgres.database reportPrint (Track $ Postgres.pgLocalCluster reportPrint Debian.postgres Debian.pg_ctlcluster) Debian.psql spec.port . Postgres.Database)+        (demoOf spec)+        (embedderOf spec.embedder)++-------------------------------------------------------------------------------+-- Search++data SearchArgs = SearchArgs+    { query :: Input+    , limit :: Int+    }++searchMain :: IO ()+searchMain = do+    args <- execParser (info (parser <**> helper) (fullDesc <> progDesc "Search the indexed directory by similarity; the directive is read on stdin"))+    raw <- LByteString.getContents+    spec <- case Aeson.eitherDecode raw of+        Left err -> hPutStrLn stderr ("not a directive: " <> err) >> exitFailure+        Right s -> pure (s :: Spec)+    hits <- search (demoOf spec) (embedderOf spec.embedder) args.query args.limit+    case hits of+        Left why -> Text.hPutStrLn stderr why >> exitFailure+        Right hs -> mapM_ (\h -> printf "%.4f\t%s\t%s\n" h.hitDistance (Text.unpack h.hitKind) h.hitPath) hs+  where+    parser =+        SearchArgs+            <$> ((InputText <$> strOption (long "text" <> metavar "TEXT")) <|> (InputImage <$> strOption (long "image" <> metavar "PATH")))+            <*> option auto (long "limit" <> value 5 <> Opt.showDefault)

@@ -31,6 +31,34 @@ with machine B's guest paused or killed: it is what turns a refusal into a failover. += The same thing, kept up and driven live++Each line above is a process that boots nothing twice but still starts from+nothing: it asks every node again, does its one thing and exits. Under+@run serve@ the guests are booted once and stay, and what is wanted of them+is changed a line at a time, by a person or by a program holding the socket:++> $t run serve --http $XDG_RUNTIME_DIR/salmon-toy.http < /dev/null &+> post() { curl -s --unix-socket $XDG_RUNTIME_DIR/salmon-toy.http -X POST --data-binary "$1" http://x/command; }+> post 'up guests'                       # the bridge and three guests, answering ssh+> post 'up up --primary A --seed B'      # the pair on top of them+> post 'up writer'                       # a client that never stops; its lines are /events?stream=output+> post 'up up --primary B'               # the demo ...+> post 'down up --primary A --seed B'    # ... and the declaration it replaced+> post 'up frozen --machine b'           # a fault: B's guest stops mid-sentence+> post 'down frozen --machine b'         # and carries on++@salmon-apps\/scripts\/qemu-pg-ha-serve.sh@ is those lines with names, and+@resources\/postgres-pair.md@ ("Driving it live") says what to expect of each.+Four seeds exist for this and mean little to a one-shot @run up@:++* @guests@ is the machines without the pair, so that the pair can be+  retired and declared again without a boot in between.+* @writer@ is the client as a process the server /holds/ ('managed'), which+  is the only kind that can keep writing across somebody else's command.+* @frozen@ and @partition@ are faults as declarations: @up@ injects one,+  @down@ heals it, and the loop's own state says which are in force.+ = What this needs of the host  Two capabilities, granted once, and no root after @prereqs@:@@ -59,12 +87,40 @@ point is to be able to read the whole thing: a pair in earnest is handed @.pgpass@ files that somebody else provisioned, which is why "SreBox.PostgresPair" takes paths and never passwords.++The toy therefore plays both parts, and keeps them apart. 'inventSecrets' is+the somebody else: it leaves files in @\/etc\/salmon-toy-secrets@ on each+guest and does nothing more. Everything a deployment would also have to do+with such files -- install them where the pair reads them, restart pgbouncer+when its auth file changed, give the application a role, a database and a+@pg_hba.conf@ line -- is "SreBox.PostgresPairPrereqs", exactly as a+deployment would use it. -}-module QemuPgHaToy (main) where+module QemuPgHaToy (+    main,+    Seed (..),+    Side (..),+    Spec (..),+    Host (..),+    Machine (..),+    program,+    thePair,+    machines,+    machineName,+    machineAddr,+    blackholeScript,+    healScript,+    WriterTally (..),+    emptyTally,+    tallyLine,+) where  import Control.Concurrent (threadDelay)-import Control.Monad (forM_, unless, when)+import Control.Exception (throwIO)+import Control.Monad (forM_, unless, void, when) import Data.Aeson (FromJSON, ToJSON)+import Data.Char (toLower)+import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as Text import GHC.Generics (Generic)@@ -72,7 +128,7 @@ import qualified Options.Applicative as Opt import Options.Generic (ParseRecord (..)) import System.Exit (ExitCode (..))-import Data.Time.Clock (addUTCTime, getCurrentTime)+import Data.Time.Clock (NominalDiffTime, addUTCTime, diffUTCTime, getCurrentTime) import System.Directory (createDirectoryIfMissing, doesFileExist, getXdgDirectory, XdgDirectory (XdgConfig)) import System.FilePath ((</>)) import System.IO (hFlush, stdout)@@ -83,6 +139,7 @@ import qualified Salmon.Builtin.CommandLine as CLI import Salmon.Builtin.Extension import qualified Salmon.Builtin.Nodes.Binary as Binary+import qualified Salmon.Builtin.Nodes.Daemon as Daemon import qualified Salmon.Builtin.Nodes.Debian.Debootstrap as Debootstrap import Salmon.Builtin.Nodes.Debian.Package (Package (..)) import qualified Salmon.Builtin.Nodes.Filesystem as FS@@ -98,6 +155,7 @@ import Salmon.Reporter (reportPrint, silent)  import qualified SreBox.PostgresPair as Pair+import qualified SreBox.PostgresPairPrereqs as Prereqs  main :: IO () main = do@@ -120,6 +178,14 @@         , seedDiscard :: Maybe Side         }     | SeedClient {seedRoot :: FilePath, seedSeconds :: Int}+    | -- | the machines alone: what `up` stands on, declared by itself+      SeedGuests {seedRoot :: FilePath}+    | -- | the client as a process `run serve` holds+      SeedWriter {seedRoot :: FilePath}+    | -- | a guest whose CPUs are stopped, for as long as this is declared+      SeedFrozen {seedRoot :: FilePath, seedMachine :: Machine}+    | -- | a guest that cannot reach another, for as long as this is declared+      SeedPartition {seedRoot :: FilePath, seedMachine :: Machine, seedFrom :: Machine}  -- | @--primary A@ is what it looks like. newtype Side = Side {unSide :: Pair.Side}@@ -146,7 +212,22 @@                             (progDesc "the bridge, the three guests, and the pair -- re-run with a different --primary to move it")                         )                     , command "client" (info (SeedClient <$> rootOpt <*> secondsOpt) (progDesc "write through the bouncer until interrupted, then say what happened"))+                    , command "guests" (info (SeedGuests <$> rootOpt) (progDesc "the bridge and the three guests, without the pair -- under `run serve`, what keeps them booted while the pair is retired and declared again"))+                    , command "writer" (info (SeedWriter <$> rootOpt) (progDesc "(run serve only) a client the server holds: writes through the bouncer for as long as it is declared, and reports on the output stream"))+                    , command+                        "frozen"+                        ( info+                            (SeedFrozen <$> rootOpt <*> machineOpt "machine" "the guest to pause: a, b or bouncer")+                            (progDesc "a fault: this guest's CPUs are stopped (qemu's monitor) -- `down` resumes it")+                        )+                    , command+                        "partition"+                        ( info+                            (SeedPartition <$> rootOpt <*> machineOpt "machine" "the guest that stops answering: a, b or bouncer" <*> machineOpt "from" "the guest it stops answering")+                            (progDesc "a fault: --machine drops everything it would send to --from, which cuts both directions -- `down` heals it")+                        )                     ]+        machineOpt name what = option (Opt.maybeReader readMachine) (long name <> Opt.help what)         rootOpt = strOption (long "root" <> Opt.help "where the guests' root filesystems live" <> value "/var/lib/salmon-toy-pg-ha")         primaryOpt = option auto (long "primary" <> Opt.help "which guest should be the primary: A or B")         cloneOpt = optional (option auto (long "seed" <> Opt.help "build this side's cluster from the other one (the first time, and after a standby falls too far behind)"))@@ -193,20 +274,37 @@         { specPair :: Pair.Pair         , specSeconds :: Int         }+    | Guests {specHost :: Host}+    | Writer {specPair :: Pair.Pair}+    | Frozen {specHost :: Host, specMachine :: Machine}+    | Partition {specHost :: Host, specMachine :: Machine, specFrom :: Machine}     deriving (Generic)  instance FromJSON Spec instance ToJSON Spec +{- | What booting a guest needs to know about /this/ machine: the same facts+'Up' carries, as one value for the seeds that boot guests and declare no+pair.+-}+data Host = Host+    { hostRoot :: FilePath+    , hostUser :: Text+    , hostUnitDir :: FilePath+    , hostRuntimeDir :: FilePath+    , hostBoot :: [(Text, FilePath, FilePath)]+    }+    deriving (Generic)++instance FromJSON Host+instance ToJSON Host+ configure :: Configure IO Seed Spec configure = Configure $ \seed -> case seed of     SeedPrereqs root -> Prereqs root <$> unprivilegedUser     SeedClient root secs -> pure (RunClient (thePair root) secs)     SeedUp root primary clone discard -> do-        user <- Text.pack <$> getEffectiveUserName-        unitDir <- getXdgDirectory XdgConfig "systemd/user"-        runtimeDir <- maybe "/tmp" id <$> lookupEnv "XDG_RUNTIME_DIR"-        boots <- traverse (resolveBoot root) machines+        host <- hostFacts root         pure             ( Up                 { specRoot = root@@ -216,13 +314,27 @@                         , Pair.pair_seed = fmap unSide clone                         , Pair.pair_may_discard = fmap unSide discard                         }-                , specUser = user-                , specUnitDir = unitDir-                , specRuntimeDir = runtimeDir-                , specBoot = boots+                , specUser = host.hostUser+                , specUnitDir = host.hostUnitDir+                , specRuntimeDir = host.hostRuntimeDir+                , specBoot = host.hostBoot                 }             )+    SeedGuests root -> Guests <$> hostFacts root+    SeedWriter root -> pure (Writer (thePair root))+    SeedFrozen root m -> (\h -> Frozen h m) <$> hostFacts root+    SeedPartition root m from -> do+        when (m == from) $+            fail "a partition is between two machines: --machine and --from name the same one"+        (\h -> Partition h m from) <$> hostFacts root   where+    hostFacts root = do+        user <- Text.pack <$> getEffectiveUserName+        unitDir <- getXdgDirectory XdgConfig "systemd/user"+        runtimeDir <- maybe "/tmp" id <$> lookupEnv "XDG_RUNTIME_DIR"+        boots <- traverse (resolveBoot root) machines+        pure (Host root user unitDir runtimeDir boots)+     resolveBoot root m = do         there <- doesFileExist (rootfsOf root m </> "etc/issue")         unless there $@@ -250,15 +362,28 @@ program :: Track' Spec program = Track $ \spec -> case spec of     Prereqs root owner -> prereqs root owner-    Up root pair user unitDir runtimeDir boots -> demo root pair user unitDir runtimeDir boots+    Up root pair user unitDir runtimeDir boots -> demo (Host root user unitDir runtimeDir boots) pair     RunClient pair secs -> clientOp pair secs+    Guests host -> guests host+    Writer pair -> writerOp pair+    Frozen host m -> frozen host m+    Partition host m from -> partition host m from  ------------------------------------------------------------------------------- -- What the toy is made of: three guests on one bridge.  data Machine = MachineA | MachineB | MachineBouncer-    deriving (Eq, Show)+    deriving (Eq, Show, Generic) +instance FromJSON Machine+instance ToJSON Machine++-- | @--machine a@, by the name the guest is known by everywhere else.+readMachine :: String -> Maybe Machine+readMachine s = case [m | m <- machines, Text.unpack (machineName m) == map toLower s] of+    (m : _) -> Just m+    [] -> Nothing+ machines :: [Machine] machines = [MachineA, MachineB, MachineBouncer] @@ -326,6 +451,7 @@         , Pair.pair_seed = Nothing         , Pair.pair_may_discard = Nothing         , Pair.pair_reseed = Nothing+        , Pair.pair_conn_security = Nothing         , Pair.pair_bouncers = [theBouncer root]         }   where@@ -336,6 +462,7 @@             , Pair.member_cluster = "main"             , Pair.member_port = 5432             , Pair.member_ssh_identity = Just (Keys.privateKeyPath (clientKey root))+            , Pair.member_ssh_host = Nothing             }  theBouncer :: FilePath -> Pair.Bouncer@@ -350,6 +477,7 @@         , Pair.bouncer_console_passfile = "/etc/pgbouncer/console.pgpass"         , Pair.bouncer_alias = "app"         , Pair.bouncer_dbname = "app"+        , Pair.bouncer_more_databases = Nothing         , Pair.bouncer_routing_path = "/etc/pgbouncer/routing.ini"         , Pair.bouncer_config_dir = "/etc/pgbouncer"         , Pair.bouncer_listen_port = 6432@@ -404,30 +532,54 @@ ------------------------------------------------------------------------------- -- up: a bridge, three guests, and the pair on top of them. -demo :: FilePath -> Pair.Pair -> Text -> FilePath -> FilePath -> [(Text, FilePath, FilePath)] -> Op-demo root pair user unitDir runtimeDir boots =-    Pair.pairOp reportPrint pair `inject` secrets+demo :: Host -> Pair.Pair -> Op+demo host pair =+    canary root pair `inject` foldl inject (Prereqs.pairWithPrereqs reportPrint pair toyPrereqs) provisioned   where-    secrets =-        op "toy-secrets" (deps (map secretsOn machines)) $ \actions ->-            actions-                { help = "the passwords a deployment would have provisioned"-                , ref = mkRef "toy-secrets" root-                }+    root = host.hostRoot -    secretsOn m = provisionSecrets root m `inject` reachable root m+    {- Each machine's prerequisites wait for that machine's secrets, which+    wait for the machine. Said by naming the recipe's node again with one+    more dependency: it is the same node, so the walk merges the two. -}+    provisioned =+        [ Prereqs.memberPrereqs reportPrint pair toyPrereqs Pair.A `inject` secretsOn MachineA+        , Prereqs.memberPrereqs reportPrint pair toyPrereqs Pair.B `inject` secretsOn MachineB+        ]+            <> [ Prereqs.bouncerPrereqs reportPrint pair toyPrereqs b `inject` secretsOn MachineBouncer+               | b <- pair.pair_bouncers+               ] -    reachable r m = guestUp r m+    secretsOn m = inventSecrets root m `inject` guestUp host m -    guestUp r m =-        awaitSsh r m-            `inject` ( Qemu.setup reportPrint silent systemctlTrack qemuTrack ipTrack (vmConfig r m user unitDir runtimeDir boots)-                        `inject` trustsTheCa r m-                        `inject` LinuxBridge.bridgeAddr silent ipTrack (LinuxBridge.Bridge bridgeName) bridgeCidr-                     )+{- | The machines, and nothing on them: what 'demo' stands on, as a+declaration of its own. -vmConfig :: FilePath -> Machine -> Text -> FilePath -> FilePath -> [(Text, FilePath, FilePath)] -> Qemu.VmConfig-vmConfig root m user unitDir runtimeDir boots =+Every node here is one 'demo' declares too, described the same way, so the+two merge rather than collide. What it buys under @run serve@ is a second+holder: with @guests@ declared, retiring the pair takes the pair down and+leaves three machines booted for the next one.+-}+guests :: Host -> Op+guests host =+    op "toy-guests" (deps [guestUp host m | m <- machines]) $ \actions ->+        actions+            { help = "the toy's three guests, booted and answering"+            , ref = mkRef "toy-guests" host.hostRoot+            }++-- | A guest that answers ssh, on top of 'vmUnit'.+guestUp :: Host -> Machine -> Op+guestUp host m = awaitSsh host m `inject` vmUnit host m++-- | The guest as a unit of the user's systemd: its tap, its bridge, and an sshd that trusts the toy's CA.+vmUnit :: Host -> Machine -> Op+vmUnit host m =+    Qemu.setup reportPrint silent systemctlTrack qemuTrack ipTrack (vmConfig host m)+        `inject` trustsTheCa host.hostRoot m+        `inject` LinuxBridge.bridgeAddr silent ipTrack (LinuxBridge.Bridge bridgeName) bridgeCidr++vmConfig :: Host -> Machine -> Qemu.VmConfig+vmConfig (Host root user unitDir runtimeDir boots) m =     Qemu.VmConfig         { Qemu.vm_name = "salmon-toy-" <> machineName m         , Qemu.vm_memory_mb = 512@@ -487,29 +639,159 @@             `inject` Keys.sshKey silent keygenTrack (clientKey root)             `inject` Keys.sshKey silent keygenTrack (caKey root) --- | A guest is not up when qemu is running; it is up when it answers.-awaitSsh :: FilePath -> Machine -> Op-awaitSsh root m =+{- | A guest is not up when qemu is running; it is up when it answers.++A guest that is /paused/ ('frozen') will not answer however long anyone+waits, and waiting is not free under @run serve@: every command stands the+tending machines down first, and standing down waits for an @up@ in flight.+So a paused guest fails this at once, saying why, rather than holding the+line that would resume it behind two minutes of polling.+-}+awaitSsh :: Host -> Machine -> Op+awaitSsh host m =     op "toy-guest-up" nodeps $ \actions ->         actions             { help = machineName m <> " answers ssh"             , ref = mkRef "toy-guest-up" (machineName m)             , check = do-                (code, _, _) <- sshToGuest root m "true"-                pure (if code == ExitSuccess then Success else Failure (machineName m <> " is not answering yet"))+                paused <- isPaused+                if paused+                    then pure (Failure (machineName m <> " is paused"))+                    else do+                        (code, _, _) <- sshToGuest root m "true"+                        pure (if code == ExitSuccess then Success else Failure (machineName m <> " is not answering yet"))             , up = poll (60 :: Int)             }   where+    root = host.hostRoot+    isPaused = (== Just Qemu.Paused) <$> Qemu.runState (vmConfig host m).vm_monitor_socket     poll 0 = fail (Text.unpack (machineName m) <> " never answered ssh")     poll n = do+        paused <- isPaused+        when paused $+            fail (Text.unpack (machineName m) <> " is paused (see `frozen`): it will not answer until it is resumed")         (code, _, _) <- sshToGuest root m "true"         unless (code == ExitSuccess) (threadDelay 2000000 >> poll (n - 1))  -------------------------------------------------------------------------------+-- Faults, as declarations: `up` injects one, `down` heals it.++{- | This guest's CPUs are stopped, through qemu's monitor.++The machine its peers see is one that went silent without closing anything:+no FIN, no RST, a replication connection that is simply never written to+again. Resumed, it carries on from the instruction it stopped at -- which,+for a primary whose standby was promoted in the meantime, is the only way+this toy has of producing two primaries.++It depends on the unit and not on the guest answering: the monitor is+qemu's, and a guest that is about to be paused does not need to have booted.+-}+frozen :: Host -> Machine -> Op+frozen host m =+    op "toy-frozen" (deps [vmUnit host m]) $ \actions ->+        actions+            { help = machineName m <> " is paused"+            , notes = ["a fault, for as long as it is declared: retiring it resumes the guest"]+            , ref = mkRef "toy-frozen" (machineName m)+            , check = do+                st <- Qemu.runState sock+                pure $ case st of+                    Just Qemu.Paused -> Success+                    Just _ -> Failure (machineName m <> " is running")+                    Nothing -> Unknown+            , up = do+                ok <- Qemu.pause sock+                unless ok (fail ("could not reach the monitor of " <> Text.unpack (machineName m) <> " at " <> sock))+            , -- a monitor nobody answers is a guest that is not running, and+              -- a guest that is not running is not paused: nothing to undo,+              -- and failing here would hold up the unit's own teardown.+              down = void (Qemu.resume sock)+            }+  where+    sock = (vmConfig host m).vm_monitor_socket++{- | @machine@ sends nothing to @from@: a blackhole route for that one+address, which cuts both directions since no answer leaves either.++A route rather than a firewall rule because @ip@ is in every rootfs and+@nft@ is not, and because @ip route replace@ is a set: applying it twice is+applying it once. It is not persistent, so a guest that reboots comes back+healed -- and this node's check is what says so.++The host is not a thing a guest can be cut off from here: the command that+would heal it has to travel the path it cut.+-}+partition :: Host -> Machine -> Machine -> Op+partition host m from =+    op "toy-partition" (deps [guestUp host m]) $ \actions ->+        actions+            { help = machineName m <> " cannot reach " <> machineName from+            , notes = ["a fault, for as long as it is declared: retiring it removes the route"]+            , ref = mkRef "toy-partition" (machineName m, machineName from)+            , check = do+                (code, _, _) <- sshToGuest root m (blackholeProbe from)+                pure $ case code of+                    ExitSuccess -> Success+                    ExitFailure 255 -> Unknown+                    ExitFailure _ -> Failure (machineName m <> " can reach " <> machineName from)+            , up = do+                (code, out, err) <- sshToGuest root m (blackholeScript from)+                unless (code == ExitSuccess) $+                    fail ("cutting " <> Text.unpack (machineName m) <> " off: " <> out <> err)+            , down = do+                (code, out, err) <- sshToGuest root m (healScript from)+                -- 255 is ssh not connecting: a machine that is gone has no+                -- routes left to remove, and must not block its own teardown.+                unless (code == ExitSuccess || code == ExitFailure 255) $+                    fail ("healing " <> Text.unpack (machineName m) <> ": " <> out <> err)+            }+  where+    root = host.hostRoot++blackholeScript, healScript, blackholeProbe :: Machine -> String+blackholeScript from = "ip route replace blackhole " <> Text.unpack (machineAddr from) <> "/32"+healScript from = "ip route del blackhole " <> Text.unpack (machineAddr from) <> "/32 2>/dev/null || true"+blackholeProbe from = "ip -o route show type blackhole | grep -qw " <> Text.unpack (machineAddr from)++------------------------------------------------------------------------------- -- The secrets a deployment would have provisioned, and this toy invents. -provisionSecrets :: FilePath -> Machine -> Op-provisionSecrets root m =+-- | Where the toy's "somebody else" leaves secrets on a guest.+secretsDir :: FilePath+secretsDir = "/etc/salmon-toy-secrets"++{- | What the pair needs first, in a deployment's own terms: every secret is+a file in 'secretsDir' on the machine it is for, and the recipe puts it+where the pair reads it. The packages are baked into the rootfs (these+guests have no route to a mirror), which the recipe finds out for itself and+so never reaches for @apt-get@.+-}+toyPrereqs :: Prereqs.Prereqs+toyPrereqs =+    Prereqs.defaultPrereqs+        { Prereqs.prereq_repl_passfile = Prereqs.postgresOwned (secretsDir </> "replication.pgpass")+        , Prereqs.prereq_rewind_passfile = Prereqs.postgresOwned (secretsDir </> "rewind.pgpass")+        , Prereqs.prereq_console_passfile = Prereqs.postgresOwned (secretsDir </> "console.pgpass")+        , Prereqs.prereq_userlist = (Prereqs.postgresOwned (secretsDir </> "userlist.txt")){Prereqs.secret_mode = "0644"}+        , Prereqs.prereq_applications =+            [ -- the application's own access, which the pair knows nothing+              -- about: it routes a database, it does not own one.+              Prereqs.Application+                { Prereqs.app_role = "app"+                , Prereqs.app_database = "app"+                , Prereqs.app_passfile = secretsDir </> "app.pgpass"+                , Prereqs.app_clients = [machineAddr MachineBouncer]+                , Prereqs.app_hba_method = "md5"+                }+            ]+        }++{- | The toy as the somebody else: files in 'secretsDir', and nothing done+with them. This is the only node that knows a password.+-}+inventSecrets :: FilePath -> Machine -> Op+inventSecrets root m =     op "toy-secret" nodeps $ \actions ->         actions             { help = "passwords on " <> machineName m@@ -522,63 +804,57 @@             }  secretScript :: Machine -> String-secretScript MachineBouncer =-    unlines+secretScript m =+    unlines $         [ "set -e"-        , "mkdir -p /etc/pgbouncer"-        , -- postgres's own scheme: md5, then the hex digest of password and-          -- user run together.-          "md5() { printf 'md5%s' \"$(printf '%s%s' \"$2\" \"$1\" | md5sum | cut -d' ' -f1)\"; }"-        , "{"-        , "  printf '\"router\" \"%s\"\\n' \"$(md5 router " <> Text.unpack consolePassword <> ")\""-        , "  printf '\"app\" \"%s\"\\n' \"$(md5 app " <> Text.unpack appPassword <> ")\""-        , "} > /tmp/toy-userlist.txt"-        , "printf '*:*:*:router:" <> Text.unpack consolePassword <> "\\n' > /etc/pgbouncer/console.pgpass"-        , "chmod 0600 /etc/pgbouncer/console.pgpass"-        , "chown postgres:postgres /etc/pgbouncer/console.pgpass"-        , {- pgbouncer reads its auth file when it starts and not again, so a-          userlist written under a running process is a password that does-          not work yet -- and the symptom is an authentication failure with-          a correct password in a correct file, which is a bad afternoon.-          Restarting is fine here and only here: this runs before there are-          clients, and only when the file actually changed, because on every-          later pass a restart would drop the very clients the bouncer is in-          the way to protect. -}-          "if ! cmp -s /tmp/toy-userlist.txt /etc/pgbouncer/userlist.txt; then"-        , "  install -m 0644 -o postgres -g postgres /tmp/toy-userlist.txt /etc/pgbouncer/userlist.txt"-        , "  systemctl restart pgbouncer"-        , "fi"-        , "rm -f /tmp/toy-userlist.txt"+        , "umask 077"+        , "mkdir -p " <> secretsDir         ]-secretScript _ =-    unlines $+            <> case m of+                MachineBouncer ->+                    [ -- postgres's own scheme: md5, then the hex digest of+                      -- password and user run together.+                      "md5() { printf 'md5%s' \"$(printf '%s%s' \"$2\" \"$1\" | md5sum | cut -d' ' -f1)\"; }"+                    , "{"+                    , "  printf '\"router\" \"%s\"\\n' \"$(md5 router " <> Text.unpack consolePassword <> ")\""+                    , "  printf '\"app\" \"%s\"\\n' \"$(md5 app " <> Text.unpack appPassword <> ")\""+                    , "} > " <> secretsDir </> "userlist.txt"+                    , pgpass "console.pgpass" "router" consolePassword+                    ]+                _ ->+                    [ pgpass "replication.pgpass" "replicator" replPassword+                    , pgpass "rewind.pgpass" "rewinder" rewindPassword+                    , pgpass "app.pgpass" "app" appPassword+                    ]+  where+    pgpass file role pwd =+        "printf '*:*:*:" <> role <> ":" <> Text.unpack pwd <> "\\n' > " <> secretsDir </> file++{- | The table the client writes to. The toy's own, and not a prerequisite+of anything: it is made last, on whichever member is the primary by then.+-}+canary :: FilePath -> Pair.Pair -> Op+canary root pair =+    op "toy-canary" nodeps $ \actions ->+        actions+            { help = "the table the client writes to"+            , ref = mkRef "toy-canary" pair.pair_name+            , up = forM_ [MachineA, MachineB] $ \m -> do+                (code, out, err) <- sshToGuest root m canaryScript+                unless (code == ExitSuccess) $+                    fail ("the canary table on " <> Text.unpack (machineName m) <> ": " <> out <> err)+            }++canaryScript :: String+canaryScript =+    unlines         [ "set -e"         , "export LANG=C LC_ALL=C"-        , "version=$(pg_lsclusters --no-header | awk '{print $1}' | head -n1)"-        , "hba=/etc/postgresql/$version/main/pg_hba.conf"+        , "if [ \"$(sudo -u postgres psql -tAXc 'SELECT pg_is_in_recovery()')\" = f ]; then"+        , "  sudo -u postgres psql -d app -tAXc 'CREATE TABLE IF NOT EXISTS canary (n int primary key, at timestamptz default now())'"+        , "  sudo -u postgres psql -d app -tAXc 'GRANT ALL ON canary TO app'"+        , "fi"         ]-            <> [ "printf '*:*:*:" <> role <> ":" <> pwd <> "\\n' > " <> path <> "; chown postgres:postgres " <> path <> "; chmod 0600 " <> path-               | (path, role, pwd) <--                    [ ("/etc/postgresql/toy-replication.pgpass", "replicator", Text.unpack replPassword)-                    , ("/etc/postgresql/toy-rewind.pgpass", "rewinder", Text.unpack rewindPassword)-                    ]-               ]-            <> [ -- the application's own access, which the pair knows nothing-                 -- about: it routes a database, it does not own one.-                 "line='host all app " <> Text.unpack (machineAddr MachineBouncer) <> "/32 md5'"-               , "grep -qxF \"$line\" \"$hba\" || echo \"$line\" >> \"$hba\""-               , "pg_ctlcluster \"$version\" main reload"-               , "if [ \"$(sudo -u postgres psql -tAXc 'SELECT pg_is_in_recovery()')\" = f ]; then"-               , "  sudo -u postgres psql -tAX -d postgres >/dev/null <<TOY_SQL"-               , "DO \\$do\\$ BEGIN CREATE ROLE app LOGIN; EXCEPTION WHEN duplicate_object THEN NULL; END \\$do\\$;"-               , "ALTER ROLE app LOGIN PASSWORD '" <> Text.unpack appPassword <> "';"-               , "TOY_SQL"-               , "  sudo -u postgres psql -tAXc \"SELECT 1 FROM pg_database WHERE datname='app'\" | grep -q 1 ||"-               , "    sudo -u postgres psql -tAXc 'CREATE DATABASE app OWNER app'"-               , "  sudo -u postgres psql -d app -tAXc 'CREATE TABLE IF NOT EXISTS canary (n int primary key, at timestamptz default now())'"-               , "  sudo -u postgres psql -d app -tAXc 'GRANT ALL ON canary TO app'"-               , "fi"-               ]  ------------------------------------------------------------------------------- -- The client: on the host, through the bouncer, like anybody else's.@@ -640,6 +916,118 @@                     (if acked then failed else i : failed)                     (if acked then firstError else maybe (Just err) Just firstError) +{- | The client as something @run serve@ holds: it writes for as long as it+is declared, and says how it is going on the node's output.++'clientOp' cannot be this. Its @up@ returns when its time is up, and a pass+waits for it -- so under @serve@ the line that would move the primary sits+in the inbox until the client it was meant to move it under has finished. A+'managed' action is the other kind: the loop keeps it running across+commands and across passes, and every line it writes is an @output@ event+(@GET \/events?stream=output@) beside the node's own ring in @\/dag@.++It says something every 'tallyEvery' seconds, and at once when inserts+start failing or stop failing, since those two lines are what a switchover+looks like from a client. There is no final count, because there is no end.+-}+writerOp :: Pair.Pair -> Op+writerOp pair =+    op "toy-writer" nodeps $ \actions ->+        actions+            { help = "keeps writing through the bouncer, and says how it is going"+            , notes = ["held by `run serve`; its lines are the output stream"]+            , ref = mkRef "toy-writer" pair.pair_name+            , managed = Just (runWriter pair)+            , up = throwIO (Daemon.NeedsSupervisor "the toy's writer")+            , -- nothing holds it once its machine is gone+              down = pure ()+            }++-- | What the writer has seen so far.+data WriterTally = WriterTally+    { tallyAcked :: !Int+    , tallyFailed :: !Int+    , tallyMissing :: !(Maybe Int)+    -- ^ acknowledged rows not there at the last audit; 'Nothing' when the audit could not be run+    , tallyLast :: !Int+    -- ^ the last row number tried+    }+    deriving (Eq, Show)++emptyTally :: WriterTally+emptyTally = WriterTally 0 0 (Just 0) 0++-- | The three numbers the one-shot client prints at the end, as one line.+tallyLine :: WriterTally -> Text+tallyLine t =+    Text.pack $+        "acknowledged "+            <> show t.tallyAcked+            <> ", errors "+            <> show t.tallyFailed+            <> ", acknowledged rows missing "+            <> maybe "unknown (the audit could not read the table)" show t.tallyMissing+            <> " (last row "+            <> show t.tallyLast+            <> ")"++-- | Seconds between two tally lines. By the clock and not by the insert: a failing insert can take seconds to fail.+tallyEvery :: NominalDiffTime+tallyEvery = 5++runWriter :: Pair.Pair -> Output -> IO ExitCode+runWriter pair out = do+    start <- highestSoFar bouncer+    out (Text.pack ("writing through " <> Text.unpack bouncer.bouncer_ssh_host <> ":" <> show bouncer.bouncer_listen_port <> ", from row " <> show (start + 1)))+    now <- getCurrentTime+    go start Set.empty emptyTally{tallyLast = start} True now+  where+    bouncer = case pair.pair_bouncers of+        (b : _) -> b+        [] -> error "the toy always declares a bouncer"++    go n acked tally healthy lastLine = do+        let i = n + 1+        (ok, err) <- insertOne bouncer i+        let acked' = if ok then Set.insert i acked else acked+            tally' =+                tally+                    { tallyAcked = tally.tallyAcked + (if ok then 1 else 0)+                    , tallyFailed = tally.tallyFailed + (if ok then 0 else 1)+                    , tallyLast = i+                    }+        when (healthy && not ok) $+            out (Text.pack ("insert " <> show i <> " failed: " <> takeWhile (/= '\n') err))+        when (not healthy && ok) $+            out (Text.pack ("insert " <> show i <> " acknowledged: writing again"))+        -- a table that came back with rows this run never wrote (an earlier+        -- run's, behind a bouncer that was not there when this one started)+        -- would otherwise be one duplicate-key error per such row.+        next <- if ok then pure i else max i <$> highestSoFar bouncer+        now <- getCurrentTime+        (tally'', lastLine') <-+            if diffUTCTime now lastLine >= tallyEvery+                then do+                    audited <- audit acked' tally'+                    out (tallyLine audited)+                    pure (audited, now)+                else pure (tally', lastLine)+        threadDelay 200000+        go next acked' tally'' ok lastLine'++    audit acked tally = do+        present <- rowsAmong bouncer+        pure tally{tallyMissing = fmap (\there -> Set.size (Set.difference acked there)) present}++-- | The rows that are there, or 'Nothing' if nobody could be asked.+rowsAmong :: Pair.Bouncer -> IO (Maybe (Set.Set Int))+rowsAmong b = do+    (code, out, _) <- psqlThroughBouncer b ["-tAXc", "SELECT n FROM canary"]+    pure $+        if code /= ExitSuccess+            then Nothing+            else Just (Set.fromList [n | w <- words out, [(n, _)] <- [reads w]])+ insertOne :: Pair.Bouncer -> Int -> IO (Bool, String) insertOne b i = do     (code, _, err) <-@@ -663,7 +1051,15 @@     environment <- getEnvironment     let cp =             (proc "psql" (connArgs <> args))-                { env = Just (("PGPASSWORD", Text.unpack appPassword) : filter ((/= "PGPASSWORD") . fst) environment)+                { env =+                    Just+                        ( ("PGPASSWORD", Text.unpack appPassword)+                            -- a bouncer whose machine is paused or gone answers+                            -- nothing at all, and libpq would wait out the+                            -- kernel's two minutes of SYN retries per insert.+                            : ("PGCONNECT_TIMEOUT", "3")+                            : filter ((`notElem` ["PGPASSWORD", "PGCONNECT_TIMEOUT"]) . fst) environment+                        )                 }     readCreateProcessWithExitCode cp ""   where

@@ -0,0 +1,1083 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++{- | @salmon-report@: a read-only report of what a network can do, built from+probes (feature 4e859358). Nothing here converges anything.++> salmon-report config --name example.org --tcp example.org:443 | salmon-report run report [--json]++A /probe/ is an ordinary 'Op' whose 'check' gathers one fact. Its @up@ throws+and is never called: the driver ('runReport') expands the graph, evaluates+every probe's @check@ concurrently with a per-probe timeout, and prints one+'Finding' per probe.++Decisions taken for v1:++* The driver is private to this binary, not a generic @run report@ in+  'Salmon.Builtin.CommandLine'.+* Evidence travels through a 'Collector' the probes write to (keyed by the+  probe's 'Ref'), not through a widened 'CheckResult'; the 'CheckResult' a+  probe returns is only the coarse verdict.+* The report states facts, and a short "meaning" for the few facts the tree's+  own designs depend on (UPnP-IGD absence, CGNAT).+* No third-party service is contacted: the external address comes from the+  gateway, or from an echo URL the operator declares with @--echo@.++DNS setup probes (@--domain@, see 'DomainSpec' and "Report.Dns") ask whether+a domain is delegated to the name servers of the zone meant to serve it,+whether those servers agree, and whether declared names resolve to what the+zone says. The expected servers come from @--ns@ or, read with @gcloud@, from+a Cloud DNS zone (@--zone PROJECT\/ZONE@). These probes send DNS queries to+the parent zone's servers, the expected servers and a resolver: that is their+subject, not a third-party service.++Port probes (@--nmap HOST:PORTS@, see "Report.Nmap") run @nmap@ against the+hosts and ports the operator declares and file one finding per port: open,+closed or filtered. There is no default target and no default port list; one+declaration is one host, and one unprivileged TCP connect scan of its ports.++Inbound probes (@--inbound HOST:PORT[\@LISTEN]@ with @--vantage-ssh+[USER\@]HOST@, see "Report.Inbound") ask a declared second machine, over the+operator's own @ssh@, to open a TCP connection to a declared external address+and port, and say whether it arrived. There is no default vantage point.++STUN probes (@--stun HOST:PORT@, see "Report.Stun") send one Binding request+over UDP to each declared server, all from one local socket per address+family, and file the mapped address each server saw plus one finding on+whether the NAT's mapping depends on the destination. There is no default+server; the second address a server advertises is reported, not contacted.++Hairpin probes (@--hairpin [ADDR:]PORT[\@LISTEN]@, see "Report.Hairpin") make+one TCP connection from this host to the gateway's external address and a+port that is already mapped, and say whether it came back in. The probe opens+no mapping and changes nothing on the gateway; what the evidence does not+settle is @unknown@.++Not done (follow-ups in the feature): the filtering half of the NAT type.+The @natpmpc@ parser's no-answer case is pinned by a captured run+(@test/fixtures/natpmpc-no-answer.txt@); its answer case still follows the+tool's source, not a capture.+-}+module Report (+    main,++    -- * Seed and findings+    Spec (..),+    DomainSpec (..),+    Verdict (..),+    Finding (..),+    findingValue,+    renderFinding,++    -- * Driver+    Collector,+    newCollector,+    probeOp,+    reportOp,+    runReport,++    -- * Inbound reachability, from a second vantage point+    AskVantage,+    askSsh,+    askWith,+    inboundProbes,+    inboundFinding,+    withInbound,++    -- * Hairpin, from this host to its own external address+    HairpinIO (..),+    hairpinIO,+    hairpinProbes,+    hairpinFinding,+    withReportListeners,++    -- * Probes+    probesFor,+    probesWith,+    dnsSetupProbes,+    expectedServers,+    parseZoneRef,+    nmapProbes,+    nmapFinding,+    scanNmap,+    stunProbes,+    stunFinding,+    stunMappingFinding,+    scanStun,+    scanStunWith,++    -- * Pure parsers (exposed for tests)+    parseDigAddresses,+    parseNatpmpc,+    NatpmpResult (..),+    parseHostPort,+    describeClass,+    crossCheck,+) where++import Control.Concurrent.Async (forConcurrently)+import Control.Concurrent.MVar (modifyMVar, newMVar)+import Control.Exception (SomeException, bracket, evaluate, throwIO, try)+import Control.Monad (forM, forM_)+import Data.Aeson (FromJSON (..), ToJSON, Value, object, withObject, (.!=), (.:), (.:?), (.=))+import qualified Data.Aeson as Aeson+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Lazy as LByteString+import qualified Data.ByteString.Lazy.Char8 as LChar+import Data.Dynamic (Dynamic, fromDynamic, toDyn)+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)+import Data.List (nub)+import qualified Data.Map.Strict as Map+import Data.Maybe (catMaybes, isJust, mapMaybe)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import GHC.Clock (getMonotonicTimeNSec)+import GHC.Generics (Generic)+import qualified Network.HTTP.Client as Http+import Network.Socket (AddrInfo (..), Family (AF_INET, AF_INET6), SockAddr (..), SocketType (Datagram, Stream), bind, close, connect, defaultHints, defaultProtocol, getAddrInfo, getSocketName, hostAddress6ToTuple, hostAddressToTuple, socket, socketPort)+import Network.Socket.ByteString (recvFrom, sendAllTo)+import qualified Options.Applicative as O+import System.Exit (ExitCode (..))+import System.IO (IOMode (ReadMode), hFlush, stdout, withBinaryFile)+import System.IO.Error (ioeGetErrorString)+import System.Process (readProcessWithExitCode)+import System.Timeout (timeout)+import Text.Read (readMaybe)++import Salmon.Actions.UpDown (CheckResult (Failure, Success), expandDag)+import qualified Salmon.Actions.UpDown as UpDown+import Report.Dns+import Report.Hairpin+import Report.Inbound+import Report.Nmap+import Report.Stun hiding (Family)+import qualified Report.Stun as Stun+import Salmon.Builtin.Extension+import qualified Salmon.Builtin.Nodes.Gcp.CloudDns as CloudDns+import Salmon.Builtin.Nodes.Gcp.Core (Project (..))+import Salmon.Builtin.Nodes.PortMapping.Upnpc+import Salmon.Op.Dag (Dag (..), dagOrder)+import Data.Functor.Identity (runIdentity)+import Salmon.Op.Actions (Act (..))+import Salmon.Op.Ref (Ref, mkRef)+import Salmon.Reporter (reportPrint)++-------------------------------------------------------------------------------++-- | What an operator declares: every target is named, nothing is discovered by scanning.+data Spec = Spec+    { specNames :: [Text]+    -- ^ DNS names to resolve+    , specTcp :: [Text]+    -- ^ outbound @host:port@ pairs+    , specEcho :: Maybe Text+    -- ^ an HTTP(S) URL answering with the caller's address as plain text+    , specGateway :: Maybe Text+    -- ^ gateway address, handed to @natpmpc -g@+    , specUpnp :: Bool+    , specNatpmp :: Bool+    , specDomain :: Maybe DomainSpec+    -- ^ a domain whose DNS setup is reported on+    , specInbound :: InboundSpec+    -- ^ the inbound test from a second vantage point, see "Report.Inbound"+    , specNmap :: [Text]+    -- ^ @HOST:PORTS@ targets handed to @nmap@, see 'parseNmapTarget'+    , specStun :: [Text]+    -- ^ @HOST:PORT@ STUN servers to ask over UDP, see 'parseStunServer'+    , specHairpin :: [Text]+    -- ^ @[ADDR:]PORT[\@LISTEN]@ mapped ports to connect back to, see 'parseHairpinTarget'+    }+    deriving (Eq, Show, Generic)++instance ToJSON Spec++{- | Field for field what the generic instance reads, except that a directive+written before 'specNmap', 'specStun' or 'specHairpin' existed still reads+(as no target and no server).+-}+instance FromJSON Spec where+    parseJSON = withObject "Spec" $ \o ->+        Spec+            <$> o .: "specNames"+            <*> o .: "specTcp"+            <*> o .:? "specEcho"+            <*> o .:? "specGateway"+            <*> o .: "specUpnp"+            <*> o .: "specNatpmp"+            <*> o .:? "specDomain"+            <*> o .:? "specInbound" .!= noInbound+            <*> o .:? "specNmap" .!= []+            <*> o .:? "specStun" .!= []+            <*> o .:? "specHairpin" .!= []++{- | A domain and the hosted zone meant to serve it. The expected name+servers are 'domNameServers' when given, and otherwise read from the Cloud+DNS zone 'domZone' names.+-}+data DomainSpec = DomainSpec+    { domName :: Text+    , domNameServers :: [Text]+    , domZone :: Maybe Text+    -- ^ @PROJECT\/ZONE@, a Cloud DNS managed zone+    , domRecords :: [Text]+    -- ^ @[TYPE:]NAME[=VALUE,...]@, see 'parseRecordQuery'+    , domResolver :: Maybe Text+    -- ^ the resolver asked for what the world sees; the system's when absent+    }+    deriving (Eq, Show, Generic)++instance ToJSON DomainSpec+instance FromJSON DomainSpec++data Verdict = Yes | No | Unknown+    deriving (Eq, Show, Generic)++instance ToJSON Verdict where+    toJSON v = Aeson.String (verdictText v)++verdictText :: Verdict -> Text+verdictText Yes = "yes"+verdictText No = "no"+verdictText Unknown = "unknown"++-- | One capability: a question, a verdict, the evidence and the method.+data Finding = Finding+    { fQuestion :: Text+    , fVerdict :: Verdict+    , fEvidence :: [Text]+    , fMethod :: Text+    , fMeaning :: Maybe Text+    , fAddresses :: [Text]+    -- ^ addresses this finding learnt (external address, resolved names), for 'crossCheck'+    }+    deriving (Eq, Show)++findingValue :: Finding -> Value+findingValue f =+    object $+        [ "question" .= fQuestion f+        , "verdict" .= fVerdict f+        , "evidence" .= fEvidence f+        , "method" .= fMethod f+        ]+            <> maybe [] (\m -> ["meaning" .= m]) (fMeaning f)++renderFinding :: Finding -> Text+renderFinding f =+    Text.unlines $+        [ "[" <> verdictText (fVerdict f) <> "] " <> fQuestion f+        , "    method: " <> fMethod f+        ]+            <> fmap ("    evidence: " <>) (fEvidence f)+            <> maybe [] (\m -> ["    meaning: " <> m]) (fMeaning f)++-------------------------------------------------------------------------------+-- Driver++-- | Evidence written by probes while their @check@ runs, keyed by the probe's ref.+newtype Collector = Collector (IORef (Map.Map Ref Finding))++newCollector :: IO Collector+newCollector = Collector <$> newIORef Map.empty++-- | Marks a node as a probe, so the driver ignores the root and anything else.+data ProbeMark = ProbeMark Text+    deriving (Show)++markOf :: [Dynamic] -> Maybe Text+markOf ds = case mapMaybe fromDynamic ds of+    (ProbeMark q : _) -> Just q+    [] -> Nothing++{- | A read-only probe. The check runs the action, files the 'Finding' and+answers the coarse verdict; @up@ and @down@ throw/refuse: a report never converges.+-}+probeOp :: Collector -> Text -> IO Finding -> Op+probeOp (Collector cell) question action =+    op+        "probe"+        nodeps+        ( \e ->+            e+                { help = question+                , ref = key+                , dynamics = [toDyn (ProbeMark question)]+                , up = throwIO (userError "salmon-report probes are read-only")+                , down = pure ()+                , check = do+                    f <- action+                    atomicModifyIORef' cell (\m -> (Map.insert key f m, ()))+                    pure $ case fVerdict f of+                        Yes -> Success+                        No -> Failure (Text.intercalate "; " (fEvidence f))+                        Unknown -> UpDown.Unknown+                }+        )+  where+    key = mkRef "salmon-report-probe" question++-- | The root that hangs the probes together.+reportOp :: [Op] -> Op+reportOp ps = op "report" (deps ps) id++{- | Evaluate every probe's @check@ concurrently, each within @micros@; a+timeout or an exception becomes an @unknown@ finding naming the cause.+Findings come back in graph order.+-}+runReport :: Int -> Collector -> Op -> IO [Finding]+runReport micros (Collector cell) root = do+    dag <- expandDag reportPrint (pure . runIdentity) root+    let probes =+            [ (r, q, a.extension)+            | r <- dagOrder dag+            , Just a <- [Map.lookup r (dagNodes dag)]+            , Just q <- [markOf a.extension.dynamics]+            ]+    forConcurrently probes $ \(r, q, ext) -> do+        res <- try (timeout micros (ext.check >>= evaluate))+        found <- Map.lookup r <$> readIORef cell+        pure $ case (res, found) of+            (Right (Just _), Just f) -> f+            (Right (Just _), Nothing) -> unknownFor q "the probe filed no finding" "check"+            (Left (e :: SomeException), _) -> unknownFor q ("the probe failed: " <> Text.pack (show e)) "check"+            (Right Nothing, _) -> unknownFor q ("timed out after " <> Text.pack (show (micros `div` 1000000)) <> "s") "check"++unknownFor :: Text -> Text -> Text -> Finding+unknownFor q why method = Finding q Unknown [why] method Nothing []++-------------------------------------------------------------------------------+-- Probes++{- | The probes a 'Spec' asks for. Nothing is shared between them: each port+probe of an @--nmap@ target runs its own scan and each STUN probe its own+exchange, where 'main' runs one per target and one for all the servers.+-}+probesFor :: Collector -> Spec -> [Op]+probesFor c = probesWith c expectedServers scanNmap scanStun++{- | 'probesFor' with the read of a domain's expected name servers, the scan+of an @nmap@ target and the exchange with the STUN servers supplied, so that+a caller can share one of each between the probes (or fake them).+-}+probesWith :: Collector -> (DomainSpec -> IO (Either Text [Text])) -> (NmapTarget -> IO (Either Text NmapScan)) -> ([StunServer] -> IO [Observation]) -> Spec -> [Op]+probesWith c expected scan stun spec =+    concat+        [ [probeOp c "Does the router offer UPnP-IGD port mapping?" upnpProbe | specUpnp spec]+        , [probeOp c "Does the router answer NAT-PMP / PCP?" (natpmpProbe (specGateway spec)) | specNatpmp spec]+        , [probeOp c "What is the external address, and can it be mapped to?" (externalProbe (specEcho spec)) | specUpnp spec || isJust (specEcho spec)]+        , [probeOp c ("Does " <> n <> " resolve?") (dnsProbe n) | n <- specNames spec]+        , [probeOp c ("Can this host open TCP to " <> hp <> "?") (tcpProbe hp) | hp <- specTcp spec]+        , [probeOp c "Does this host have a global IPv6 address?" ipv6Probe]+        , maybe [] (\d -> dnsSetupProbes c (expected d) d) (specDomain spec)+        , concatMap (nmapProbes c scan) (specNmap spec)+        , stunProbes c stun (specStun spec)+        ]++-- | Runs a command, treating a missing binary as a reason rather than a crash.+run :: FilePath -> [String] -> IO (Either Text (ExitCode, Text))+run cmd args = do+    r <- try (readProcessWithExitCode cmd args "")+    pure $ case r of+        Left (e :: IOError) -> Left (Text.pack cmd <> " could not run: " <> Text.pack (ioeGetErrorString e))+        Right (code, out, err) -> Right (code, Text.pack (out <> err))++upnpProbe :: IO Finding+upnpProbe = do+    r <- run "upnpc" ["-s"]+    pure $ case r of+        Left why -> mk Unknown [why] Nothing+        Right (_, out) -> case parseGateway out of+            NoDevice -> mk No ["nothing answered the multicast search"] (Just "No UPnP device on this LAN, so a mapping cannot be requested; configure the port map by hand on the router.")+            NotIgd -> mk No ["a UPnP device answered but it is not an Internet Gateway Device"] (Just "A device answered (often a WPS description) but cannot map ports: enable UPnP in the router's settings, or map by hand.")+            Igd ext loc -> mk Yes (maybe [] (\e -> ["external address " <> e]) ext <> maybe [] (\l -> ["local address " <> l]) loc) Nothing+  where+    mk v ev m = Finding "Does the router offer UPnP-IGD port mapping?" v ev "upnpc -s" m []++data NatpmpResult = NatpmpPublic Text | NatpmpNoGateway | NatpmpNoAnswer+    deriving (Eq, Show)++-- | Reads @natpmpc@ output: a @Public IP address : A@ line is an answer.+parseNatpmpc :: Text -> NatpmpResult+parseNatpmpc out+    | (a : _) <- [Text.strip v | l <- ls, Just v <- [Text.stripPrefix "Public IP address :" l]], not (Text.null a) = NatpmpPublic a+    | any ("Cannot get default gateway" `Text.isInfixOf`) ls || any ("Cannot get gateway" `Text.isInfixOf`) ls = NatpmpNoGateway+    | otherwise = NatpmpNoAnswer+  where+    ls = fmap Text.strip (Text.lines out)++natpmpProbe :: Maybe Text -> IO Finding+natpmpProbe gw = do+    r <- run "natpmpc" (maybe [] (\g -> ["-g", Text.unpack g]) gw)+    pure $ case r of+        Left why -> mk Unknown [why]+        Right (_, out) -> case parseNatpmpc out of+            NatpmpPublic a -> (mk Yes ["public address " <> a]){fAddresses = [a]}+            NatpmpNoGateway -> mk Unknown ["natpmpc found no gateway; declare one with --gateway"]+            NatpmpNoAnswer -> mk No ["no NAT-PMP answer"]+  where+    mk v ev = Finding "Does the router answer NAT-PMP / PCP?" v ev "natpmpc" Nothing []++describeClass :: AddressClass -> Text+describeClass Public = "public"+describeClass Private = "private"+describeClass CGNAT = "carrier-grade NAT (100.64.0.0/10)"+describeClass Unparseable = "unparseable"++externalProbe :: Maybe Text -> IO Finding+externalProbe echo = do+    fromGw <- do+        r <- run "upnpc" ["-s"]+        pure $ case r of+            Right (_, out) | Igd (Just e) _ <- parseGateway out -> Just (e, "upnpc -s (the gateway's own report)")+            _ -> Nothing+    found <- case fromGw of+        Just x -> pure (Just x)+        Nothing -> case echo of+            Nothing -> pure Nothing+            Just url -> do+                r <- try (fetchEcho url) :: IO (Either SomeException Text)+                pure $ case r of+                    Right body | not (Text.null body) -> Just (body, "GET " <> url <> " (declared echo)")+                    _ -> Nothing+    pure $ case found of+        Nothing -> Finding q Unknown ["no gateway reported an address and no working --echo URL was declared"] "upnpc -s, --echo" Nothing []+        Just (addr, how) ->+            let cls = classifyAddress addr+                (v, meaning) = case cls of+                    Public -> (Yes, Nothing)+                    Private -> (No, Just "The address is private: this router is itself behind another NAT, so no mapping on it is reachable from the Internet.")+                    CGNAT -> (No, Just "Carrier-grade NAT: double NAT, no port mapping will be reachable from the Internet.")+                    Unparseable -> (Unknown, Nothing)+             in Finding q v [addr <> " is " <> describeClass cls] how meaning [addr]+  where+    q = "What is the external address, and can it be mapped to?"++-- | The first 64 bytes a declared echo URL answers with, within 5s. Throws when it does not answer.+fetchEcho :: Text -> IO Text+fetchEcho url = do+    mgr <- Http.newManager Http.defaultManagerSettings+    req <- Http.parseRequest (Text.unpack url)+    resp <- Http.httpLbs req{Http.responseTimeout = Http.responseTimeoutMicro 5000000} mgr+    pure (Text.strip (Text.pack (LChar.unpack (LChar.take 64 (Http.responseBody resp)))))++-- | Addresses on the lines of @dig +short@ output (CNAME targets are skipped).+parseDigAddresses :: Text -> [Text]+parseDigAddresses = filter isAddr . fmap Text.strip . Text.lines+  where+    isAddr t = classifyAddress t /= Unparseable || (":" `Text.isInfixOf` t && Text.all (`elem` ("0123456789abcdefABCDEF:." :: String)) t && not (Text.null t))++dnsProbe :: Text -> IO Finding+dnsProbe n = do+    a <- run "dig" ["+short", "+time=3", "+tries=1", "A", Text.unpack n]+    aaaa <- run "dig" ["+short", "+time=3", "+tries=1", "AAAA", Text.unpack n]+    pure $ case (a, aaaa) of+        (Left why, _) -> mk Unknown [why] []+        (Right (_, o1), r2) ->+            let addrs = parseDigAddresses o1 <> either (const []) (parseDigAddresses . snd) r2+             in if null addrs+                    then mk No ["no A or AAAA record"] []+                    else mk Yes ((\x -> n <> " -> " <> x <> " (" <> (if ":" `Text.isInfixOf` x then "IPv6" else describeClass (classifyAddress x)) <> ")") <$> addrs) addrs+  where+    mk v ev as = Finding ("Does " <> n <> " resolve?") v ev "dig +short A/AAAA" Nothing as++-- | Splits @host:port@ (the last colon wins, so a bare IPv6 needs brackets).+parseHostPort :: Text -> Maybe (Text, Int)+parseHostPort t = do+    let (h, p) = Text.breakOnEnd ":" t+    host <- Text.stripSuffix ":" h+    port <- readMaybe (Text.unpack p)+    if Text.null host || port < 1 || port > 65535 then Nothing else Just (Text.dropAround (`elem` ("[]" :: String)) host, port)++tcpProbe :: Text -> IO Finding+tcpProbe hp = case parseHostPort hp of+    Nothing -> pure (mk Unknown ["not of the form host:port"])+    Just (h, p) -> do+        r <- try $ do+            addrs <- getAddrInfo (Just defaultHints{addrSocketType = Stream}) (Just (Text.unpack h)) (Just (show p))+            case addrs of+                [] -> throwIO (userError "no address")+                (ai : _) -> do+                    s <- socket (addrFamily ai) (addrSocketType ai) (addrProtocol ai)+                    (connect s (addrAddress ai) >> pure (addrAddress ai)) `finallyClose` s+        pure $ case r of+            Right sa -> mk Yes ["connected to " <> Text.pack (show sa)]+            Left (e :: SomeException) -> mk No [Text.pack (show e)]+  where+    mk v ev = Finding ("Can this host open TCP to " <> hp <> "?") v ev "TCP connect" Nothing []+    finallyClose act s = do+        x <- try act+        close s+        either (\(e :: SomeException) -> throwIO e) pure x++ipv6Probe :: IO Finding+ipv6Probe = do+    r <- run "ip" ["-6", "addr", "show", "scope", "global"]+    pure $ case r of+        Left why -> mk Unknown [why]+        Right (_, out) ->+            let as = [w | l <- Text.lines out, ("inet6" : w : _) <- [Text.words (Text.strip l)]]+             in if null as then mk No ["no global-scope IPv6 address"] else mk Yes (("address " <>) <$> as)+  where+    mk v ev = Finding "Does this host have a global IPv6 address?" v ev "ip -6 addr show scope global" Nothing []++-------------------------------------------------------------------------------+-- nmap++{- | The probes of one declared @HOST:PORTS@ target: one per port, all+reading the same scan. A declaration that does not parse is one probe+saying why, and scans nothing.+-}+nmapProbes :: Collector -> (NmapTarget -> IO (Either Text NmapScan)) -> Text -> [Op]+nmapProbes c scan raw = case parseNmapTarget raw of+    Left why ->+        let q = "Which ports of the nmap target " <> raw <> " are open, seen from this host?"+         in [probeOp c q (pure (Finding q Unknown [why <> " (expected HOST:PORTS, as in example.org:22,443)"] "nmap, not run" Nothing []))]+    Right t -> [probeOp c (nmapQuestion t p) (nmapFinding t p <$> scan t) | p <- targetPorts t]++nmapQuestion :: NmapTarget -> Int -> Text+nmapQuestion t p = "Is TCP port " <> Text.pack (show p) <> " of " <> targetHost t <> " open, seen from this host?"++{- | One scan of one target: @nmap@ with 'nmapArgs', its output read by+'parseNmapGrepable'. A scan that printed no host is a reason, made of what+nmap said instead.+-}+scanNmap :: NmapTarget -> IO (Either Text NmapScan)+scanNmap t = do+    r <- run "nmap" (nmapArgs t)+    pure $ case r of+        Left why -> Left why+        Right (code, out) -> case parseNmapGrepable out of+            Just s -> Right s+            Nothing ->+                let said = [l | l <- Text.strip <$> Text.lines out, not (Text.null l), not ("#" `Text.isPrefixOf` l)]+                 in Left (Text.intercalate "; " (take 3 said <> ["nmap reported no host" <> exited code]))+  where+    exited ExitSuccess = ""+    exited (ExitFailure n) = " (exit " <> Text.pack (show n) <> ")"++-- | What a scan (or the reason there is none) says about one port of its target.+nmapFinding :: NmapTarget -> Int -> Either Text NmapScan -> Finding+nmapFinding t p res = case res of+    Left why -> mk Unknown [why] Nothing+    Right s -> case portState s p of+        Left why -> mk Unknown [why] Nothing+        Right st ->+            let ev = [Text.pack (show p) <> "/tcp is " <> stateText st <> " on " <> scanAddress s]+             in case st of+                    PortOpen -> mk Yes ev Nothing+                    PortClosed -> mk No ev (Just "Closed: the host answered and refused, so it is reachable and nothing listens on this port.")+                    PortFiltered -> mk Unknown ev (Just "Filtered: nothing answered, so a firewall drops the attempt or the host is away; whether a service listens cannot be told from here.")+                    PortOther _ -> mk Unknown ev Nothing+  where+    mk v ev m = Finding (nmapQuestion t p) v ev (Text.pack (unwords ("nmap" : nmapArgs t))) m []++-------------------------------------------------------------------------------+-- STUN++{- | The probes of the declared @HOST:PORT@ STUN servers: one per server+(the address it saw this host as), and one on what those addresses say of+the NAT's mapping, all reading the same exchange. A declaration that does+not parse is one probe saying why, and is sent nothing. No declaration, no probe.+-}+stunProbes :: Collector -> ([StunServer] -> IO [Observation]) -> [Text] -> [Op]+stunProbes _ _ [] = []+stunProbes c scan raws =+    [either bad (\s -> probeOp c (stunQuestion s) (stunFinding s <$> scan servers)) d | d <- declared]+        <> [probeOp c stunMappingQuestion (stunMappingFinding <$> scan servers)]+  where+    declared = nub [either (\why -> Left (Text.strip r, why)) Right (parseStunServer r) | r <- raws]+    servers = [s | Right s <- declared]+    bad (r, why) =+        let q = "Does the STUN server " <> r <> " tell this host its mapped address?"+         in probeOp c q (pure (Finding q Unknown [why <> " (expected HOST:PORT, as in stun.example.org:3478)"] "STUN, not sent" Nothing []))++stunQuestion :: StunServer -> Text+stunQuestion s = "Does the STUN server " <> renderStunServer s <> " tell this host its mapped address?"++stunMappingQuestion :: Text+stunMappingQuestion = "Does the NAT give this host one mapped address whatever the destination (endpoint-independent mapping)?"++-- | What the exchange says about one declared server.+stunFinding :: StunServer -> [Observation] -> Finding+stunFinding s obs = case [o | o <- obs, obsServer o == s] of+    [] -> mk Unknown ["the exchange holds nothing about this server"] []+    (o : _) -> case obsOutcome o of+        NotAsked why -> mk Unknown [why] []+        Silent why -> mk No (why : asked o) []+        Answered (Stun.Refused code reason) -> mk No (("the server answered with the error " <> Text.pack (show code) <> (if Text.null reason then "" else " " <> reason)) : asked o) []+        Answered (Mapped m other) ->+            mk+                Yes+                ( ["mapped address " <> renderEndpoint m <> " (" <> classOf m <> ")"]+                    <> asked o+                    <> [translation l m | Just l <- [obsLocal o]]+                    <> ["the server advertises a second address, " <> renderEndpoint a <> ": it is not contacted unless declared with --stun" | Just a <- [other]]+                )+                [epHost m]+  where+    mk v ev as = Finding (stunQuestion s) v ev "STUN Binding request over UDP (RFC 8489), without attributes" Nothing as+    asked o = ["asked " <> renderEndpoint d <> maybe "" (\l -> " from " <> renderEndpoint l) (obsLocal o) | Just d <- [obsDestination o]]+    classOf m = case epFamily m of+        V4 -> describeClass (classifyAddress (epHost m))+        V6 -> "IPv6"+    translation l m+        | l == m = "the mapped address is the local one: nothing translates on the path to this server"+        | epHost l == epHost m = "the address is the local one and the port is not: something on the path rewrites the port"+        | otherwise = "the mapped address is not the local one: a NAT is on the path to this server"++-- | What the exchange says about the NAT's mapping, see 'judgeMapping'.+stunMappingFinding :: [Observation] -> Finding+stunMappingFinding obs =+    let j = judgeMapping obs+     in Finding stunMappingQuestion (verdictOf j) (jEvidence j) "STUN Binding requests from one UDP socket to each declared server, comparing the mapped addresses" (jMeaning j) []++-- | How long each request waits for its answer before it is sent again: 3.5s in all.+stunSchedule :: [Int]+stunSchedule = [500000, 1000000, 2000000]++-- | One exchange with the declared servers, see 'scanStunWith'.+scanStun :: [StunServer] -> IO [Observation]+scanStun = scanStunWith stunSchedule++{- | Asks every server once (resent after each wait of the schedule, in+microseconds, while unanswered), from one UDP socket per address family so+that the mapped addresses can be compared. Each name is resolved to one+address, and only that address is sent to. An answer counts when it comes+from the address asked and carries the request's transaction id. Nothing+here throws: what went wrong is the observation's 'Outcome'.+-}+scanStunWith :: [Int] -> [StunServer] -> IO [Observation]+scanStunWith waits declared = do+    let servers = nub declared+    resolved <- traverse (\s -> (,) s <$> resolve s) servers+    let targets = [(s, sa, d) | (s, Right (sa, d)) <- resolved]+        unresolved = [Observation s Nothing Nothing (NotAsked why) | (s, Left why) <- resolved]+    asked <- forM [V4, V6] $ \fam -> case [t | t@(_, _, d) <- targets, epFamily d == fam] of+        [] -> pure []+        ts -> do+            r <- try (exchange fam ts)+            pure $ case r of+                Right os -> os+                Left (e :: SomeException) -> [Observation s (Just d) Nothing (NotAsked ("the UDP exchange failed: " <> Text.pack (show e))) | (s, _, d) <- ts]+    let found = unresolved <> concat asked+    pure [o | s <- servers, o <- found, obsServer o == s]+  where+    resolve s = do+        r <- try (getAddrInfo (Just defaultHints{addrSocketType = Datagram}) (Just (Text.unpack (stunHost s))) (Just (show (stunPort s))))+        pure $ case r of+            Left (e :: SomeException) -> Left (stunHost s <> " could not be resolved: " <> Text.pack (show e))+            Right ais -> case [(addrAddress ai, d) | ai <- ais, Just d <- [sockEndpoint (addrAddress ai)]] of+                (x : _) -> Right x+                [] -> Left (stunHost s <> " resolved to no IPv4 or IPv6 address")+    exchange fam ts = bracket (socket (if fam == V4 then AF_INET else AF_INET6) Datagram defaultProtocol) close $ \sock -> do+        bind sock (if fam == V4 then SockAddrInet 0 0 else SockAddrInet6 0 0 (0, 0, 0, 0) 0)+        port <- fromIntegral <$> socketPort sock+        prepared <- forM ts $ \(s, sa, d) -> do+            tid <- newTransactionId+            local <- localToward sa+            pure (s, sa, d, tid, (\l -> l{epPort = port}) <$> local)+        got <- rounds sock prepared waits Map.empty+        let total = Text.pack (show (fromIntegral (sum waits) / (1000000 :: Double)))+            silence = Silent ("no answer within " <> total <> "s (" <> (if length waits == 1 then "1 request" else Text.pack (show (length waits)) <> " requests") <> " sent)")+        pure [Observation s (Just d) local (Map.findWithDefault silence tid got) | (s, _, d, tid, local) <- prepared]+    rounds _ _ [] got = pure got+    rounds sock ps (w : ws) got = case [p | p@(_, _, _, tid, _) <- ps, Map.notMember tid got] of+        [] -> pure got+        pending -> do+            sent <- forM pending $ \(_, sa, _, tid, _) -> (,) tid <$> try (sendAllTo sock (bindingRequest tid) sa)+            let got' = foldr (\(tid, r) m -> either (\(e :: SomeException) -> Map.insert tid (NotAsked ("the request could not be sent: " <> Text.pack (show e))) m) (const m) r) got sent+            deadline <- (+ fromIntegral w * 1000) <$> getMonotonicTimeNSec+            listen sock ps deadline got' >>= rounds sock ps ws+    listen sock ps deadline got = do+        now <- getMonotonicTimeNSec+        if now >= deadline || all (\(_, _, _, tid, _) -> Map.member tid got) ps+            then pure got+            else do+                m <- timeout (fromIntegral ((deadline - now) `div` 1000) + 1) (recvFrom sock 2048)+                case m of+                    Nothing -> pure got+                    Just (bytes, from) -> listen sock ps deadline (maybe got (\(tid, o) -> Map.insert tid o got) (accept ps bytes from))+    -- the request this datagram answers, if it is the answer of one: right sender, right transaction+    accept ps bytes from = case [tid | Right msg <- [parseStunMessage bytes], (_, _, d, tid, _) <- ps, msgTransaction msg == tid, sockEndpoint from == Just d] of+        (tid : _) -> Just (tid, either (\why -> Silent ("an answer that could not be read: " <> why)) Answered (parseBindingResponse tid bytes))+        [] -> Nothing+    -- this host's address on the route to the server: a connected UDP socket sends nothing+    localToward sa = do+        r <- try (bracket (socket (familyOf sa) Datagram defaultProtocol) close (\s -> connect s sa >> getSocketName s))+        pure (either (\(_ :: SomeException) -> Nothing) sockEndpoint r)+    familyOf (SockAddrInet6{}) = AF_INET6+    familyOf _ = AF_INET+    newTransactionId = do+        bytes <- withBinaryFile "/dev/urandom" ReadMode (`ByteString.hGet` 12)+        maybe (throwIO (userError "could not draw a transaction id from /dev/urandom")) pure (mkTransactionId bytes)++-- | A socket address as the endpoint the pure half compares; 'Nothing' for a non-IP one.+sockEndpoint :: SockAddr -> Maybe Endpoint+sockEndpoint (SockAddrInet p h) = let (a, b, c', d) = hostAddressToTuple h in Just (endpointV4 [a, b, c', d] (fromIntegral p))+sockEndpoint (SockAddrInet6 p _ h _) = let (a, b, c', d, e, f, g, i) = hostAddress6ToTuple h in Just (endpointV6 [a, b, c', d, e, f, g, i] (fromIntegral p))+sockEndpoint _ = Nothing++-------------------------------------------------------------------------------+-- DNS setup++-- | Splits @PROJECT\/ZONE@.+parseZoneRef :: Text -> Maybe (Text, Text)+parseZoneRef t = case Text.splitOn "/" (Text.strip t) of+    [p, z] | not (Text.null p), not (Text.null z) -> Just (p, z)+    _ -> Nothing++{- | The name servers the domain should be delegated to: the declared ones,+else those Cloud DNS assigned to the declared zone (a read-only+@gcloud dns managed-zones describe@), else a reason there are none.+-}+expectedServers :: DomainSpec -> IO (Either Text [Text])+expectedServers d+    | not (null (domNameServers d)) = pure (Right (normalizeName <$> domNameServers d))+    | Just z <- domZone d = case parseZoneRef z of+        Nothing -> pure (Left ("--zone " <> z <> " is not of the form PROJECT/ZONE"))+        Just (p, zn) -> do+            r <- try (CloudDns.readNameServers (CloudDns.ManagedZone zn (Project p) (domName d) ""))+            pure $ case r of+                Right (Just ns) -> Right (normalizeName <$> ns)+                Right Nothing -> Left ("gcloud could not describe the Cloud DNS zone " <> z <> " (absent, or not readable by this account)")+                Left (e :: SomeException) -> Left ("gcloud could not run: " <> Text.pack (show e))+    | otherwise = pure (Left "no expected name servers: declare them with --ns, or a Cloud DNS zone with --zone")++-- | Runs an action at most once, handing every caller the first result.+once :: IO a -> IO (IO a)+once act = do+    cell <- newMVar Nothing+    pure $ modifyMVar cell $ \m -> case m of+        Just x -> pure (m, x)+        Nothing -> act >>= \x -> pure (Just x, x)++-- | @dig@ printing its header and the answer section, plus whatever the flags add.+dig :: [String] -> Text -> Text -> Maybe Text -> IO (Either Text DigAnswer)+dig flags ty name server = do+    r <- run "dig" (["+time=2", "+tries=1", "+noall", "+comments", "+answer"] <> flags <> [Text.unpack ty, Text.unpack name] <> maybe [] (\s -> ["@" <> Text.unpack s]) server)+    pure (parseDig . snd <$> r)++-- | The two DNS setup probes for one domain, plus one per declared record.+dnsSetupProbes :: Collector -> IO (Either Text [Text]) -> DomainSpec -> [Op]+dnsSetupProbes c expected d =+    [ probeOp c delegationQ (delegationProbe delegationQ expected domain)+    , probeOp c zoneQ (zoneProbe zoneQ expected domain)+    ]+        <> [probeOp c (recordQ r) (recordProbe (recordQ r) expected (domResolver d) r) | r <- domRecords d]+  where+    domain = normalizeName (domName d)+    delegationQ = "Is " <> domain <> " delegated to the expected name servers?"+    zoneQ = "Do the expected name servers of " <> domain <> " agree?"+    recordQ r = "Does " <> r <> " resolve to what the zone says?"++-- | The first of these servers that answers at all, with its answer.+firstAnswer :: [Text] -> (Text -> IO (Either Text DigAnswer)) -> IO (Maybe (Text, DigAnswer))+firstAnswer [] _ = pure Nothing+firstAnswer (s : rest) ask = do+    r <- ask s+    case r of+        Right a | isJust (digStatus a) -> pure (Just (s, a))+        _ -> firstAnswer rest ask++delegationProbe :: Text -> IO (Either Text [Text]) -> Text -> IO Finding+delegationProbe q expected domain = do+    parent <- findParent (parentCandidates domain)+    case parent of+        Left why -> pure (mk Unknown [why] Nothing)+        Right (zone, servers) -> do+            answer <- firstAnswer (take 3 servers) (dig ["+authority", "+norecurse"] "NS" domain . Just)+            case answer of+                Nothing -> pure (mk Unknown ["none of the name servers of " <> zone <> " answered"] Nothing)+                Just (server, a) -> do+                    j <- (\e -> judgeDelegation domain e a) <$> expected+                    pure (mk (verdictOf j) (jEvidence j <> ["asked " <> server <> ", a name server of " <> zone]) (jMeaning j))+  where+    mk v ev m = Finding q v ev "dig +norecurse NS, asked of the parent zone's servers" m []+    findParent [] = pure (Left ("no parent zone with name servers was found for " <> domain))+    findParent (z : zs) = do+        r <- run "dig" ["+short", "+time=2", "+tries=1", "NS", Text.unpack z]+        case r of+            Left why -> pure (Left why)+            Right (_, out) -> case parseDigNames out of+                [] -> findParent zs+                ns -> pure (Right (z, ns))++zoneProbe :: Text -> IO (Either Text [Text]) -> Text -> IO Finding+zoneProbe q expected domain = do+    e <- expected+    case e of+        Left why -> pure (mk Unknown [why] Nothing)+        Right servers -> do+            views <- forConcurrently servers $ \s -> do+                ns <- dig ["+norecurse"] "NS" domain (Just s)+                soa <- dig ["+norecurse"] "SOA" domain (Just s)+                pure (s, serverView domain ns soa)+            let j = judgeZone servers views+            pure (mk (verdictOf j) (jEvidence j) (jMeaning j))+  where+    mk v ev m = Finding q v ev "dig +norecurse NS and SOA, asked of each expected server" m []++recordProbe :: Text -> IO (Either Text [Text]) -> Maybe Text -> Text -> IO Finding+recordProbe q expected resolver raw = case parseRecordQuery raw of+    Left why -> pure (mk Unknown [why] Nothing)+    Right rq -> do+        e <- expected+        fromZone <- case e of+            Left _ -> pure Nothing+            Right servers -> firstAnswer servers $ \s -> do+                r <- dig ["+norecurse"] (rqType rq) (rqName rq) (Just s)+                -- a server that does not hold the zone is not the zone speaking+                pure (r >>= \a -> if digAuthoritative a then Right a else Left "not authoritative")+        fromResolver <- dig [] (rqType rq) (rqName rq) resolver+        let seen = either (const Nothing) (\a -> if isJust (digStatus a) then Just a else Nothing) fromResolver+            (zs, rs) = case (fromZone, seen) of+                (Just (_, z), Just r) -> let (a, b) = answerValues rq z r in (Just a, Just b)+                (Just (_, z), Nothing) -> (Just (fst (answerValues rq z z)), Nothing)+                (Nothing, Just r) -> (Nothing, Just (snd (answerValues rq r r)))+                (Nothing, Nothing) -> (Nothing, Nothing)+            j = judgeRecord rq zs rs+            who = maybe [] (\(s, _) -> ["asked " <> s <> " for the zone"]) fromZone <> either (\why -> [why]) (const []) e+        pure (mk (verdictOf j) (jEvidence j <> who) (jMeaning j))+  where+    mk v ev m = Finding q v ev ("dig, asked of the zone's servers and of " <> maybe "the system resolver" ("the resolver " <>) resolver) m []++verdictOf :: Judgement -> Verdict+verdictOf j = case jOk j of+    Just True -> Yes+    Just False -> No+    Nothing -> Unknown++{- | Joins what separate probes learnt: for each resolved name, whether it+points at the external address. Appended to the evidence of the DNS findings.+-}+crossCheck :: [Finding] -> [Finding]+crossCheck fs = fmap annotate fs+  where+    external = case [a | f <- fs, "external address" `Text.isInfixOf` fQuestion f, a <- fAddresses f] of+        (a : _) -> Just a+        [] -> Nothing+    annotate f = case external of+        Just e+            | "resolve?" `Text.isSuffixOf` fQuestion f+            , not (null (fAddresses f)) ->+                f{fEvidence = fEvidence f <> [if e `elem` fAddresses f then "points at the external address " <> e else "does not point at the external address " <> e]}+        _ -> f++-------------------------------------------------------------------------------+-- Inbound reachability, from a second vantage point++-- | Runs @ssh@ with these arguments: its exit code and what it printed, or why it could not run.+type AskVantage = [String] -> IO (Either Text (ExitCode, Text))++{- | The operator's own @ssh@, found on @PATH@. Its stdin is a closed pipe,+never this process's.+-}+askSsh :: AskVantage+askSsh = askWith "ssh"++-- | 'askSsh' through another binary (a stand-in, in the tests).+askWith :: FilePath -> AskVantage+askWith = run++{- | The probes of the inbound test: one per declared target and vantage+point. A declaration that does not parse is one probe saying why, and+targets with no vantage point are one probe each saying so; neither runs+anything. The listeners are those 'withListeners' holds for the targets that+declared a local port. Not part of 'probesFor', which holds no listener.+-}+inboundProbes :: Collector -> AskVantage -> Map.Map Int (Either Text Listener) -> InboundSpec -> [Op]+inboundProbes c ask listeners i =+    [refused q why "HOST:PORT[@LISTEN], as in 192.0.2.7:443 or 192.0.2.7:443@8443" | (raw, Left why) <- targets, let q = "Does a TCP connection to the inbound target " <> raw <> " arrive?"]+        <> [refused q why "[USER@]HOST, as in probe@vantage.example.org" | (raw, Left why) <- vantages, let q = "Can the vantage point " <> raw <> " be asked?"]+        <> case ([t | (_, Right t) <- targets], [v | (_, Right v) <- vantages]) of+            (ts, []) -> [refused q "no second vantage point is declared" "--vantage-ssh [USER@]HOST" | t <- ts, let q = "Does a TCP connection to " <> renderTarget t <> " arrive from outside?"]+            (ts, vs) -> [probeOp c (inboundQuestion v t) (inboundFinding ask listeners (inbSshConfig i) v t) | t <- ts, v <- vs]+  where+    targets = [(raw, parseInboundTarget raw) | raw <- dedup (inbTargets i)]+    vantages = [(raw, parseVantage raw) | raw <- dedup (inbVantageSsh i)]+    dedup = Map.keys . Map.fromList . fmap (\x -> (x, ()))+    refused q why expects = probeOp c q (pure (Finding q Unknown [why <> " (expected " <> expects <> ")"] "inbound test, not run" Nothing []))++{- | Asks one vantage point about one target. A target whose local port+could not be bound is not asked about: the answer would be about something else.+-}+inboundFinding :: AskVantage -> Map.Map Int (Either Text Listener) -> Maybe FilePath -> Vantage -> InboundTarget -> IO Finding+inboundFinding ask listeners cfg v t = case traverse (\p -> maybe (Left ("no listener was opened on local port " <> Text.pack (show p))) id (Map.lookup p listeners)) (inListen t) of+    Left why -> pure (mk (Judgement Nothing [why] Nothing))+    Right listener -> do+        r <- ask (sshArgs cfg v t)+        peers <- maybe (pure []) listenerPeers listener+        pure $ mk $ case r of+            Left why -> Judgement Nothing [why] Nothing+            Right (code, out) ->+                let j = judgeInbound t ((\l -> (listenerToken l, peers)) <$> listener) (parseVantageOutput out)+                 in case (jOk j, code) of+                        (Nothing, ExitFailure n) -> j{jEvidence = jEvidence j <> ["ssh exited " <> Text.pack (show n)]}+                        _ -> j+  where+    mk j = Finding (inboundQuestion v t) (verdictOf j) (jEvidence j) (inboundMethod v t) (jMeaning j) []++{- | The inbound probes of a 'Spec', with the listeners its targets declare+held open while the action runs.+-}+withInbound :: Collector -> AskVantage -> Spec -> ([Op] -> IO a) -> IO a+withInbound c ask spec act =+    withListeners+        [p | Right t <- parseInboundTarget <$> inbTargets i, Just p <- [inListen t]]+        (\listeners -> act (inboundProbes c ask listeners i))+  where+    i = specInbound spec++-------------------------------------------------------------------------------+-- Hairpin, from this host to its own external address++{- | What the hairpin probes do to the outside, as actions a caller can+share between the probes (or fake).+-}+data HairpinIO = HairpinIO+    { hioGateway :: IO (Either Text GatewayView)+    -- ^ the gateway's addresses and mappings, or why they could not be read+    , hioEcho :: IO (Maybe Text)+    -- ^ what the declared echo URL answers with, if one is declared and answers+    , hioLocal :: Text -> Int -> IO (Maybe Text)+    -- ^ this host's address on the route to that address and port+    , hioConnect :: Text -> Int -> Bool -> IO Attempt+    -- ^ the TCP connection to that address and port, reading back when asked+    }++{- | The real actions for a 'Spec': @upnpc -l@ (a read; skipped with+@--no-upnp@), the declared @--echo@ URL, and 'connectAttempt'.+-}+hairpinIO :: Spec -> HairpinIO+hairpinIO spec =+    HairpinIO+        { hioGateway =+            if specUpnp spec+                then (\r -> r >>= readGatewayListing . snd) <$> run "upnpc" ["-l"]+                else pure (Left "UPnP discovery is off (--no-upnp)")+        , hioEcho = case specEcho spec of+            Nothing -> pure Nothing+            Just url -> either (\(_ :: SomeException) -> Nothing) Just <$> try (fetchEcho url)+        , hioLocal = localAddressToward+        , hioConnect = connectAttempt (hairpinConnectSeconds * 1000000) (hairpinReadSeconds * 1000000)+        }++{- | The probes of the hairpin test: one per declared target. A declaration+that does not parse is one probe saying why, and connects to nothing. The+listeners are those 'withReportListeners' holds for the targets that declared+a local port. Not part of 'probesFor', which holds no listener.+-}+hairpinProbes :: Collector -> HairpinIO -> Map.Map Int (Either Text Listener) -> [Text] -> [Op]+hairpinProbes c hio listeners raws =+    [either bad (\t -> probeOp c (hairpinQuestion t) (hairpinFinding hio listeners t)) d | d <- declared]+  where+    declared = nub [either (\why -> Left (Text.strip r, why)) Right (parseHairpinTarget r) | r <- raws]+    bad (r, why) =+        let q = "Does the gateway hairpin a TCP connection to the hairpin target " <> r <> "?"+         in probeOp c q (pure (Finding q Unknown [why <> " (expected [ADDR:]PORT[@LISTEN], as in 8443, 203.0.113.7:443 or 443@8443)"] "hairpin test, not run" Nothing []))++{- | Gathers the evidence for one target and judges it ('judgeHairpin'). The+echo URL is only asked when neither the declaration nor the gateway gives an+address, and the connection is only made when 'hairpinBlocked' has no+objection.+-}+hairpinFinding :: HairpinIO -> Map.Map Int (Either Text Listener) -> HairpinTarget -> IO Finding+hairpinFinding hio listeners t = do+    gw <- hioGateway hio+    let reported = either (const Nothing) gvExternal gw+    external <- case chooseExternal t reported Nothing of+        Right e -> pure (Right e)+        Left _ -> chooseExternal t reported <$> hioEcho hio+    local <- either (const (pure Nothing)) (\e -> hioLocal hio (extAddress e) (hpPort t)) external+    let listener = hpListen t >>= (`Map.lookup` listeners)+        mapping = viewMapping t (catMaybes [local, either (const Nothing) gvLocal gw]) (gvMappings <$> gw)+        evidence peers attempt = Evidence external mapping local (fmap (\l -> (listenerToken l, peers)) <$> listener) attempt+        idle = evidence [] Nothing+    case (hairpinBlocked t idle, external) of+        (Nothing, Right e) -> do+            a <- hioConnect hio (extAddress e) (hpPort t) (isJust (hpListen t))+            peers <- case listener of+                Just (Right l) -> listenerPeers l+                _ -> pure []+            pure (mk (judgeHairpin t (evidence peers (Just a))))+        _ -> pure (mk (judgeHairpin t idle))+  where+    mk j = Finding (hairpinQuestion t) (verdictOf j) (jEvidence j) (hairpinMethod t) (jMeaning j) []++{- | The listeners a 'Spec' declares, for its inbound and its hairpin+targets, held open while the action runs: one per distinct local port, so an+inbound and a hairpin target may name the same one.+-}+withReportListeners :: Spec -> (Map.Map Int (Either Text Listener) -> IO a) -> IO a+withReportListeners spec =+    withListeners+        ( [p | Right t <- parseInboundTarget <$> inbTargets (specInbound spec), Just p <- [inListen t]]+            <> [p | Right t <- parseHairpinTarget <$> specHairpin spec, Just p <- [hpListen t]]+        )++-------------------------------------------------------------------------------+-- Command line++data Command = Config Spec | RunReport Bool Int++main :: IO ()+main = do+    cmd <- O.execParser (O.info (parser O.<**> O.helper) (O.fullDesc <> O.progDesc "A read-only report of what this network can do" <> O.header "salmon-report"))+    case cmd of+        Config spec -> LChar.putStrLn (Aeson.encode spec)+        RunReport asJson secs -> do+            input <- LByteString.getContents+            spec <- either (\e -> ioError (userError ("bad directive: " <> e))) pure (Aeson.eitherDecode input)+            c <- newCollector+            -- one read of the expected name servers, shared by the DNS setup probes+            expected <- traverse (once . expectedServers) (specDomain spec)+            -- one scan per declared nmap target, shared by its port probes+            scans <- Map.fromList <$> traverse (\t -> (\shared -> (t, shared)) <$> once (scanNmap t)) [t | Right t <- parseNmapTarget <$> specNmap spec]+            -- one exchange with the declared STUN servers, shared by their probes+            exchange <- once (scanStun [s | Right s <- parseStunServer <$> specStun spec])+            let probes = probesWith c (\d -> maybe (expectedServers d) id expected) (\t -> Map.findWithDefault (scanNmap t) t scans) (const exchange) spec+            -- one read of the gateway's listing and one of the echo URL, shared by the hairpin probes+            listing <- once (hioGateway (hairpinIO spec))+            echoed <- once (hioEcho (hairpinIO spec))+            let hio = (hairpinIO spec){hioGateway = listing, hioEcho = echoed}+            fs <- fmap crossCheck . withReportListeners spec $ \listeners ->+                runReport (secs * 1000000) c (reportOp (probes <> inboundProbes c askSsh listeners (specInbound spec) <> hairpinProbes c hio listeners (specHairpin spec)))+            forM_ fs $ \f ->+                if asJson+                    then LChar.putStrLn (Aeson.encode (findingValue f))+                    else Text.putStr (renderFinding f)+            hFlush stdout+  where+    parser =+        O.hsubparser+            ( O.command "config" (O.info (Config <$> specParser) (O.progDesc "print the JSON directive for these targets"))+                <> O.command "run" (O.info (O.hsubparser (O.command "report" (O.info (RunReport <$> O.switch (O.long "json" <> O.help "one JSON object per finding") <*> O.option O.auto (O.long "timeout" <> O.value 10 <> O.showDefault <> O.help "seconds allowed per probe")) (O.progDesc "read a directive on stdin and print the report")))) (O.progDesc "run a directive"))+            )+    specParser =+        Spec+            <$> many' (O.strOption (O.long "name" <> O.metavar "DNSNAME" <> O.help "resolve this name (repeatable)"))+            <*> many' (O.strOption (O.long "tcp" <> O.metavar "HOST:PORT" <> O.help "try an outbound TCP connection (repeatable)"))+            <*> O.optional (O.strOption (O.long "echo" <> O.metavar "URL" <> O.help "an HTTP URL that answers with the caller's address; no default is assumed"))+            <*> O.optional (O.strOption (O.long "gateway" <> O.metavar "ADDR" <> O.help "gateway address for NAT-PMP"))+            <*> (not <$> O.switch (O.long "no-upnp" <> O.help "skip UPnP discovery"))+            <*> (not <$> O.switch (O.long "no-natpmp" <> O.help "skip NAT-PMP discovery"))+            <*> O.optional domainParser+            <*> inboundParser+            <*> many' (O.strOption (O.long "nmap" <> O.metavar "HOST:PORTS" <> O.help "scan these TCP ports of this one host with nmap, as in example.org:22,443 or [2001:db8::1]:8000-8010 (repeatable); nothing is scanned unless declared"))+            <*> many' (O.strOption (O.long "stun" <> O.metavar "HOST:PORT" <> O.help "ask this STUN server over UDP for the address it sees this host as, as in stun.example.org:3478; declare two at distinct addresses to learn whether the NAT's mapping depends on the destination (repeatable); no default server is assumed"))+            <*> many' (O.strOption (O.long "hairpin" <> O.metavar "[ADDR:]PORT[@LISTEN]" <> O.help "connect from this host to the gateway's external address and this port, which must already be mapped, to learn whether the gateway hairpins, as in 8443 or 203.0.113.7:443; ADDR defaults to the address the gateway (or --echo) reports; with @LISTEN, listen on that local port during the report and read a one-time token back (repeatable); no mapping is opened"))+    inboundParser =+        InboundSpec+            <$> many' (O.strOption (O.long "inbound" <> O.metavar "HOST:PORT[@LISTEN]" <> O.help "ask each vantage point to open a TCP connection to this external address and port, as in 192.0.2.7:443; with @LISTEN, listen on that local port during the report and have the vantage read a one-time token back (repeatable)"))+            <*> many' (O.strOption (O.long "vantage-ssh" <> O.metavar "[USER@]HOST" <> O.help "a second machine, outside the network, to make the --inbound connections from; reached with ssh in batch mode, needs bash and timeout (repeatable); no default is assumed"))+            <*> O.optional (O.strOption (O.long "vantage-ssh-config" <> O.metavar "FILE" <> O.help "an ssh configuration file for the vantage points (ssh -F); ssh's own when absent"))+    domainParser =+        DomainSpec+            <$> O.strOption (O.long "domain" <> O.metavar "DOMAIN" <> O.help "report on this domain's DNS setup: its delegation, and the servers it should be delegated to")+            <*> many' (O.strOption (O.long "ns" <> O.metavar "SERVER" <> O.help "a name server the domain should be delegated to (repeatable)"))+            <*> O.optional (O.strOption (O.long "zone" <> O.metavar "PROJECT/ZONE" <> O.help "a Cloud DNS zone to read the expected name servers from with gcloud, when no --ns is given"))+            <*> many' (O.strOption (O.long "record" <> O.metavar "[TYPE:]NAME[=VALUE,...]" <> O.help "a name of the domain to compare between the zone's servers and a resolver; TYPE defaults to A (repeatable)"))+            <*> O.optional (O.strOption (O.long "resolver" <> O.metavar "ADDR" <> O.help "the resolver to ask what the world sees; the system's when absent"))+    many' = O.many+

@@ -0,0 +1,325 @@+{-# LANGUAGE OverloadedStrings #-}++{- | The pure half of @salmon-report@'s DNS setup probes: what @dig@ printed,+read into records, and the judgement drawn from them. No IO here; "Report"+holds the shell-outs.++The case these exist for: a domain registered at a registrar, to be served by+a hosted zone. The zone looks perfect from the inside whatever the registrar+says, so each question is asked of whoever actually decides the answer: the+parent's servers for the delegation, the expected servers for what the zone+holds, a resolver for what the world sees.+-}+module Report.Dns (+    -- * dig output+    DigRecord (..),+    DigAnswer (..),+    parseDig,+    parseDigNames,+    normalizeName,+    nsNames,++    -- * Judgements+    Judgement (..),++    -- * Delegation+    parentCandidates,+    Delegation (..),+    classifyDelegation,+    judgeDelegation,++    -- * The zone's own servers+    ServerView (..),+    serverView,+    judgeZone,++    -- * Names+    RecordQuery (..),+    parseRecordQuery,+    answerValues,+    judgeRecord,+) where++import Data.Char (isAlpha, isDigit, toUpper)+import Data.List (nub, sort, (\\))+import Data.Maybe (mapMaybe)+import Data.Text (Text)+import qualified Data.Text as Text++-------------------------------------------------------------------------------+-- dig output++-- | One resource record line; the owner is normalised, the data is as printed.+data DigRecord = DigRecord+    { recOwner :: Text+    , recType :: Text+    , recData :: Text+    }+    deriving (Eq, Show)++{- | What a @dig +noall +comments +answer [+authority]@ printed. 'digStatus'+is 'Nothing' when there was no header at all, i.e. nothing answered.+-}+data DigAnswer = DigAnswer+    { digStatus :: Maybe Text+    , digAuthoritative :: Bool+    -- ^ the @aa@ flag: the server answers for a zone it holds+    , digRecords :: [DigRecord]+    }+    deriving (Eq, Show)++-- | A DNS name for comparison: lower-case, no trailing dot.+normalizeName :: Text -> Text+normalizeName = Text.dropWhileEnd (== '.') . Text.toLower . Text.strip++parseDig :: Text -> DigAnswer+parseDig out =+    DigAnswer+        { digStatus = case mapMaybe status ls of+            (s : _) -> Just s+            [] -> Nothing+        , digAuthoritative = any hasAa ls+        , digRecords = mapMaybe record ls+        }+  where+    ls = fmap Text.strip (Text.lines out)+    status l+        | ";; ->>HEADER<<-" `Text.isPrefixOf` l+        , (_, rest) <- Text.breakOn "status: " l+        , not (Text.null rest) =+            Just (Text.takeWhile (/= ',') (Text.drop 8 rest))+        | otherwise = Nothing+    hasAa l = case Text.stripPrefix ";; flags:" l of+        Just rest -> "aa" `elem` Text.words (Text.takeWhile (/= ';') rest)+        Nothing -> False+    record l+        | ";" `Text.isPrefixOf` l = Nothing+        | (owner : ttl : "IN" : ty : rest@(_ : _)) <- Text.words l+        , Text.all isDigit ttl =+            Just (DigRecord (normalizeName owner) (Text.toUpper ty) (Text.unwords rest))+        | otherwise = Nothing++-- | The names on the lines of a @dig +short NS@, normalised.+parseDigNames :: Text -> [Text]+parseDigNames out =+    [ normalizeName l+    | l <- Text.strip <$> Text.lines out+    , not (Text.null l)+    , not (";" `Text.isPrefixOf` l)+    , length (Text.words l) == 1+    ]++-- | The NS targets an answer holds for this owner, sorted and normalised.+nsNames :: Text -> DigAnswer -> [Text]+nsNames domain ans =+    sort . nub $+        [normalizeName (recData r) | r <- digRecords ans, recType r == "NS", recOwner r == normalizeName domain]++-------------------------------------------------------------------------------++{- | 'jOk' is 'Nothing' when the question could not be answered, as opposed+to answered "no".+-}+data Judgement = Judgement+    { jOk :: Maybe Bool+    , jEvidence :: [Text]+    , jMeaning :: Maybe Text+    }+    deriving (Eq, Show)++-------------------------------------------------------------------------------+-- Delegation++{- | The names that may be the parent zone of a domain, nearest first; the+first one that has name servers is the one whose servers hold the delegation.+The root is left out: a TLD's own delegation is not this report's subject.+-}+parentCandidates :: Text -> [Text]+parentCandidates domain = go (drop 1 (Text.splitOn "." (normalizeName domain)))+  where+    go [] = []+    go ls = Text.intercalate "." ls : go (drop 1 ls)++data Delegation+    = -- | the parent says the name does not exist+      Unregistered+    | -- | the parent answered, with no name servers for the name+      NoDelegation+    | -- | delegated, to none of the expected servers+      NotDelegated [Text]+    | -- | the two sets overlap: expected servers missing, and servers handed out that were not expected+      PartlyDelegated [Text] [Text]+    | Delegated [Text]+    deriving (Eq, Show)++-- | Compares the expected set with what a parent server answered for the domain.+classifyDelegation :: Text -> [Text] -> DigAnswer -> Delegation+classifyDelegation domain expected ans+    | digStatus ans == Just "NXDOMAIN" = Unregistered+    | null observed = NoDelegation+    | observed == want = Delegated observed+    | all (`notElem` want) observed = NotDelegated observed+    | otherwise = PartlyDelegated (want \\ observed) (observed \\ want)+  where+    observed = nsNames domain ans+    want = sort (nub (normalizeName <$> expected))++{- | The delegation finding. With no expected set ('Left', saying why) the+handed-out servers are still reported, with no verdict.+-}+judgeDelegation :: Text -> Either Text [Text] -> DigAnswer -> Judgement+judgeDelegation domain expected ans = case expected of+    Left why+        | digStatus ans == Just "NXDOMAIN" -> unregistered+        | otherwise -> Judgement Nothing ([handedOut observed | not (null observed)] <> [why]) Nothing+    Right want -> case classifyDelegation domain want ans of+        Unregistered -> unregistered+        NoDelegation ->+            Judgement (Just False) ["the parent's server answered with no name servers for " <> domain] Nothing+        NotDelegated obs ->+            Judgement+                (Just False)+                [handedOut obs, "expected: " <> list want]+                (Just "Not delegated: the registrar still hands out other name servers (its own parking ones, usually), so nothing in the zone is visible to the world. Set the expected name servers at the registrar.")+        PartlyDelegated missing extra ->+            Judgement+                (Just False)+                ( [handedOut observed]+                    <> ["expected and not handed out: " <> list missing | not (null missing)]+                    <> ["handed out and not expected: " <> list extra | not (null extra)]+                )+                (Just "Partly delegated: the sets differ, so some queries reach servers that do not hold the zone. Make the registrar's list equal to the zone's.")+        Delegated obs -> Judgement (Just True) [handedOut obs] Nothing+  where+    observed = nsNames domain ans+    handedOut xs = "the parent hands out: " <> list xs+    unregistered =+        Judgement (Just False) ["the parent's server answers NXDOMAIN for " <> domain] (Just "The parent zone does not know this domain: it is not registered, or the registration holds no name servers.")++list :: [Text] -> Text+list [] = "(none)"+list xs = Text.intercalate ", " xs++-------------------------------------------------------------------------------+-- The zone's own servers++data ServerView+    = -- | nothing came back, with the reason+      Unreachable Text+    | -- | it answered, and not as a server holding the zone (the status, or "not authoritative")+      NotServing Text+    | -- | the NS set and the SOA (primary name, serial) it answers with+      Serving [Text] (Maybe (Text, Text))+    deriving (Eq, Show)++{- | What one server says of the domain, from its answers to an NS and an SOA+query asked without recursion. A 'Left' is a command that could not run.+-}+serverView :: Text -> Either Text DigAnswer -> Either Text DigAnswer -> ServerView+serverView _ (Left why) _ = Unreachable why+serverView domain (Right ns) soaAnswer = case digStatus ns of+    Nothing -> Unreachable "no answer"+    Just "NOERROR"+        | digAuthoritative ns -> Serving (nsNames domain ns) (either (const Nothing) soa soaAnswer)+        | otherwise -> NotServing "it answers without authority for the domain"+    Just other -> NotServing ("it answers " <> other)+  where+    soa ans = case [Text.words (recData r) | r <- digRecords ans, recType r == "SOA", recOwner r == normalizeName domain] of+        ((mname : _ : serial : _) : _) -> Just (normalizeName mname, serial)+        _ -> Nothing++-- | Whether the expected servers all serve the zone, and say the same thing about it.+judgeZone :: [Text] -> [(Text, ServerView)] -> Judgement+judgeZone expected views+    | null views = Judgement Nothing ["no expected name server to ask"] Nothing+    | not (null strangers) =+        Judgement (Just False) evidence (Just "An expected server does not hold this zone. A zone that is deleted and created again is assigned new name servers: read them again, then update the seed and the registrar.")+    | not (null otherSets) =+        Judgement (Just False) evidence (Just "The servers hold a zone whose own NS records are not the expected set: the expectation is stale, or the zone's apex NS records were edited.")+    | length (nub soas) > 1 =+        Judgement (Just False) evidence (Just "The servers do not hold the same version of the zone (their SOA records differ); a change may still be spreading between them.")+    | not (null silent) = Judgement Nothing evidence Nothing+    | otherwise = Judgement (Just True) evidence Nothing+  where+    want = sort (nub (normalizeName <$> expected))+    strangers = [s | (s, NotServing _) <- views]+    silent = [s | (s, Unreachable _) <- views]+    otherSets = [s | (s, Serving ns _) <- views, ns /= want]+    soas = [soa | (_, Serving _ soa) <- views]+    evidence = fmap describe views+    describe (s, Unreachable why) = s <> ": unreachable (" <> why <> ")"+    describe (s, NotServing why) = s <> ": " <> why+    describe (s, Serving ns soa) =+        s <> ": NS " <> list ns <> maybe ", no SOA" (\(m, serial) -> ", SOA " <> m <> " serial " <> serial) soa++-------------------------------------------------------------------------------+-- Names++-- | A name to look up, and optionally the values it should have.+data RecordQuery = RecordQuery+    { rqType :: Text+    , rqName :: Text+    , rqExpected :: [Text]+    }+    deriving (Eq, Show)++{- | Reads @[TYPE:]NAME[=VALUE[,VALUE]...]@; the type defaults to @A@. Values+are split on commas, so a TXT value holding one cannot be declared.+-}+parseRecordQuery :: Text -> Either Text RecordQuery+parseRecordQuery t+    | Text.null name = Left ("no name in " <> t)+    | otherwise = Right (RecordQuery ty (normalizeName name) (sort (nub (normalizeValue ty <$> values))))+  where+    (lhs, rhs) = Text.breakOn "=" (Text.strip t)+    values = filter (not . Text.null) (Text.strip <$> Text.splitOn "," (Text.drop 1 rhs))+    (ty, name) = case Text.breakOn ":" lhs of+        (p, rest)+            | not (Text.null rest), not (Text.null p), Text.all isAlpha p -> (Text.map toUpper p, Text.strip (Text.drop 1 rest))+        _ -> ("A", Text.strip lhs)++-- | One record's data for comparison: names without their dot, TXT without its quotes.+normalizeValue :: Text -> Text -> Text+normalizeValue ty v+    | ty `elem` ["NS", "CNAME", "PTR"] = normalizeName v+    | ty == "TXT" = Text.dropAround (== '"') (Text.replace "\" \"" "" (Text.strip v))+    | ty == "AAAA" = Text.toLower (Text.strip v)+    | otherwise = Text.strip v++{- | The values the zone's server and the resolver give for a query, made+comparable: the records of the asked type when the zone holds some, and+otherwise the CNAME at the name itself on both sides, since a zone that+hands out an alias to a name outside itself says nothing more, while a+resolver follows it.+-}+answerValues :: RecordQuery -> DigAnswer -> DigAnswer -> ([Text], [Text])+answerValues q zone resolver = case ofType (rqType q) zone of+    [] -> (alias zone, alias resolver)+    vs -> (vs, ofType (rqType q) resolver)+  where+    ofType ty ans = sort (nub [normalizeValue ty (recData r) | r <- digRecords ans, recType r == ty])+    alias ans = sort (nub [normalizeName (recData r) | r <- digRecords ans, recType r == "CNAME", recOwner r == rqName q])++{- | Tells a wrong record from one that has not propagated. The zone's values+are 'Nothing' when none of its servers answered for it, the resolver's when+it did not answer.+-}+judgeRecord :: RecordQuery -> Maybe [Text] -> Maybe [Text] -> Judgement+judgeRecord q zone resolver = case (zone, resolver) of+    (Nothing, _) -> Judgement Nothing (["none of the zone's servers answered for it"] <> seen) Nothing+    (Just zs, _)+        | null zs ->+            Judgement (Just False) evidence (Just "Wrong record: the zone itself holds no such record, so there is nothing to propagate.")+        | not (null (rqExpected q)) && zs /= rqExpected q ->+            Judgement (Just False) evidence (Just "Wrong record: the zone itself does not hold the declared values, so waiting will not help.")+    (Just _, Nothing) -> Judgement Nothing evidence Nothing+    (Just zs, Just rs)+        | zs == rs -> Judgement (Just True) evidence Nothing+        | otherwise ->+            Judgement (Just False) evidence (Just "Not propagated: the zone holds the record and the resolver does not answer with it. Either an older answer is cached until its TTL runs out, or the domain is not delegated to these servers (see the delegation finding).")+  where+    evidence =+        ["the zone's servers say: " <> maybe "(no answer)" list zone]+            <> ["declared: " <> list (rqExpected q) | not (null (rqExpected q))]+            <> seen+    seen = ["the resolver says: " <> maybe "(no answer)" list resolver]

@@ -0,0 +1,469 @@+{-# LANGUAGE OverloadedStrings #-}++{- | @salmon-report@'s hairpin test: does the gateway /hairpin/, that is, does+a TCP connection made from inside the LAN to the gateway's external address+and a mapped port come back in?++What is declared, and nothing else is contacted:++* @--hairpin [ADDR:]PORT[\@LISTEN]@: the external port of a mapping that+  already exists (made by a salmon declaration, by hand on the router, by+  anything). @ADDR@ is the external IPv4 address; without it the address is+  the one the gateway reports (@upnpc -l@), else the one the declared+  @--echo@ URL answers with. With @\@LISTEN@, @salmon-report@ itself listens+  on that local port for the length of the report (the listener of+  "Report.Inbound") and hands a one-time token to whoever connects: reading+  it back proves the connection came back /to this host/.++The probe makes one TCP connection and reads the gateway's mapping list. It+opens no mapping, removes none, and changes nothing on the gateway: the+mapping under test is the operator's.++What it can know is narrow, and the judgement ('judgeHairpin') says+@unknown@ for everything else:++* /yes/ needs the token read back, or (without a listener) an accepted+  connection on a port the gateway lists as mapped;+* /no/ needs the gateway to list the mapping as leading to this report's+  listener, and the connection to demonstrably not have come back;+* no external address, no mapping to test against, a timeout (which a+  firewall also produces), an address this host holds itself: @unknown@.++This module is the pure half (the declaration, the reading of the gateway's+listing, the judgement) and the one TCP connection; "Report" holds the+shell-out and the probes.+-}+module Report.Hairpin (+    -- * Declarations+    HairpinTarget (..),+    parseHairpinTarget,+    renderHairpinTarget,+    parseIPv4,++    -- * The external address+    ExternalSource (..),+    External (..),+    chooseExternal,++    -- * The gateway's listing+    GatewayView (..),+    readGatewayListing,+    MappingState (..),+    viewMapping,++    -- * Judging+    Attempt (..),+    Evidence (..),+    hairpinQuestion,+    hairpinMethod,+    hairpinBlocked,+    judgeHairpin,++    -- * The connection+    hairpinConnectSeconds,+    hairpinReadSeconds,+    tokenLines,+    connectAttempt,+    localAddressToward,+) where++import Control.Exception (SomeException, bracket, try)+import Control.Monad (unless, when)+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Char8 as Char8+import Data.Char (isAsciiLower, isAsciiUpper, isDigit)+import Data.IORef (modifyIORef', newIORef, readIORef)+import Data.List (nub, partition)+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Text (Text)+import qualified Data.Text as Text+import Foreign.C.Error (Errno (..), eCONNREFUSED, eHOSTUNREACH, eNETUNREACH, eTIMEDOUT)+import GHC.IO.Exception (IOException (ioe_errno))+import Network.Socket (+    Family (AF_INET),+    SockAddr (..),+    SocketType (Datagram, Stream),+    close,+    connect,+    defaultProtocol,+    getSocketName,+    hostAddressToTuple,+    setCloseOnExecIfNeeded,+    socket,+    tupleToHostAddress,+    withFdSocket,+ )+import Network.Socket.ByteString (recv)+import System.Timeout (timeout)+import Text.Read (readMaybe)++import Report.Dns (Judgement (..))+import Salmon.Builtin.Nodes.PortMapping.Upnpc++-------------------------------------------------------------------------------+-- Declarations++-- | An external port to connect to, the external address when declared, and the local port to listen on, if any.+data HairpinTarget = HairpinTarget+    { hpAddress :: Maybe Text+    -- ^ a dotted IPv4 address, as 'parseIPv4' writes it+    , hpPort :: Int+    , hpListen :: Maybe Int+    }+    deriving (Eq, Ord, Show)++-- | The four octets of a dotted IPv4 address: decimal digits only, each at most 255.+ipv4Octets :: Text -> Maybe [Int]+ipv4Octets t = case traverse octet (Text.splitOn "." t) of+    Just os@[_, _, _, _] -> Just os+    _ -> Nothing+  where+    octet x+        | not (Text.null x) && Text.length x <= 3 && Text.all isDigit x+        , Just n <- readMaybe (Text.unpack x)+        , n <= 255 =+            Just n+        | otherwise = Nothing++-- | A dotted IPv4 address, rewritten from its parsed octets (@010.0.0.1@ is @10.0.0.1@); nothing else is one.+parseIPv4 :: Text -> Maybe Text+parseIPv4 t = Text.intercalate "." . fmap (Text.pack . show) <$> ipv4Octets t++{- | Reads @[ADDR:]PORT[\@LISTEN]@. The address is an IPv4 literal, never a+name: hairpinning is a property of an IPv4 NAT, and the address connected to+must be the one the evidence names.+-}+parseHairpinTarget :: Text -> Either Text HairpinTarget+parseHairpinTarget raw = case Text.splitOn "@" (Text.strip raw) of+    [target] -> build target Nothing+    [target, l] -> port "local port" l >>= build target . Just+    _ -> Left "not of the form [ADDR:]PORT[@LISTEN]"+  where+    build target l = case Text.splitOn ":" target of+        [p] -> (\n -> HairpinTarget Nothing n l) <$> port "port" p+        [a, p] -> do+            addr <- maybe (Left ("not a dotted IPv4 address: " <> orEmpty a)) Right (parseIPv4 a)+            n <- port "port" p+            pure (HairpinTarget (Just addr) n l)+        _ -> Left "the address must be a dotted IPv4 address: hairpinning is a property of an IPv4 NAT"+    port what x+        | not (Text.null x) && Text.all isDigit x && Text.length x <= 5+        , Just n <- readMaybe (Text.unpack x)+        , n >= 1 && n <= 65535 =+            Right n+        | otherwise = Left ("not a " <> what <> " between 1 and 65535: " <> orEmpty x)+    orEmpty x = if Text.null x then "(empty)" else x++-- | The declaration a target reads back from.+renderHairpinTarget :: HairpinTarget -> Text+renderHairpinTarget t =+    maybe "" (<> ":") (hpAddress t) <> showT (hpPort t) <> maybe "" (\l -> "@" <> showT l) (hpListen t)++showT :: Int -> Text+showT = Text.pack . show++-------------------------------------------------------------------------------+-- The external address++data ExternalSource = Declared | FromGateway | FromEcho+    deriving (Eq, Show)++-- | The address the connection is made to, and who said it is the external one.+data External = External+    { extAddress :: Text+    , extSource :: ExternalSource+    }+    deriving (Eq, Show)++{- | The external address of a target: the declared one, else what the+gateway reports, else what the echo URL answered. Only a dotted IPv4 address+counts; with none there is a reason instead.+-}+chooseExternal :: HairpinTarget -> Maybe Text -> Maybe Text -> Either Text External+chooseExternal t gateway echo =+    case mapMaybe pick [(hpAddress t, Declared), (gateway, FromGateway), (echo, FromEcho)] of+        (e : _) -> Right e+        [] -> Left "no external IPv4 address is known: none is declared, the gateway reported none, and no declared --echo URL answered with one"+  where+    pick (a, src) = (\x -> External x src) <$> (a >>= parseIPv4 . Text.strip)++-------------------------------------------------------------------------------+-- The gateway's listing++-- | What @upnpc -l@ printed, when a gateway answered.+data GatewayView = GatewayView+    { gvExternal :: Maybe Text+    , gvLocal :: Maybe Text+    -- ^ this host's LAN address, as the gateway's library found it+    , gvMappings :: [Mapping]+    }+    deriving (Eq, Show)++-- | Reads the output of @upnpc -l@: the gateway's addresses and its mappings, or why there are none.+readGatewayListing :: Text -> Either Text GatewayView+readGatewayListing out = case parseGateway out of+    NoDevice -> Left "no UPnP gateway answered"+    NotIgd -> Left "a UPnP device answered but it is not an Internet Gateway Device"+    Igd ext loc -> Right (GatewayView ext loc (parseMappings out))++-- | What the gateway says about the external port under test.+data MappingState+    = -- | the listing could not be read: why+      Unlisted Text+    | -- | the listing holds no TCP mapping of the port+      NotListed+    | -- | a TCP mapping of the port to this host (to the listener's port, when one is declared)+      ListedHere Mapping+    | -- | a TCP mapping of the port to something else+      ListedElsewhere Mapping+    deriving (Eq, Show)++{- | Looks the target's port up in the gateway's mappings. The second+argument is this host's addresses. A mapping is "here" when it leads to one+of them and, if the target declares a listener, to the listener's port.+-}+viewMapping :: HairpinTarget -> [Text] -> Either Text [Mapping] -> MappingState+viewMapping _ _ (Left why) = Unlisted why+viewMapping t locals (Right ms) =+    case partition here [m | m <- ms, mapProto m == TCP, mapExternalPort m == hpPort t] of+        (m : _, _) -> ListedHere m+        ([], m : _) -> ListedElsewhere m+        ([], []) -> NotListed+  where+    mine = mapMaybe parseIPv4 locals+    here m =+        maybe False (`elem` mine) (parseIPv4 (mapInternalAddress m))+            && maybe True (== mapInternalPort m) (hpListen t)++-------------------------------------------------------------------------------+-- Judging++-- | What became of the one TCP connection.+data Attempt+    = -- | the connection was accepted; the lines read from it, when asked to read+      Accepted [Text]+    | AttemptRefused+    | -- | nothing answered within 'hairpinConnectSeconds'+      AttemptTimedOut+    | -- | this host has no way to the address, in the system's words+      AttemptUnreachable Text+    | -- | the connection failed otherwise: why+      AttemptFailed Text+    deriving (Eq, Show)++-- | Everything the judgement reads. Gathered by "Report", or made up by a test.+data Evidence = Evidence+    { evExternal :: Either Text External+    -- ^ the address connected to, or why none is known+    , evMapping :: MappingState+    , evLocal :: Maybe Text+    -- ^ the address of this host its connection to the external address leaves from+    , evListener :: Maybe (Either Text (Text, [Text]))+    -- ^ for a target with a local port: why it could not be bound, or the token served and the peers accepted+    , evAttempt :: Maybe Attempt+    -- ^ 'Nothing' when no connection was made+    }+    deriving (Eq, Show)++hairpinQuestion :: HairpinTarget -> Text+hairpinQuestion t =+    "Does the gateway hairpin a TCP connection from this host to "+        <> maybe ("its external address, port " <> showT (hpPort t)) (\a -> a <> ":" <> showT (hpPort t)) (hpAddress t)+        <> maybe "" (\l -> ", back to this host's port " <> showT l) (hpListen t)+        <> "?"++hairpinMethod :: HairpinTarget -> Text+hairpinMethod t =+    "one TCP connection from this host to the external address"+        <> maybe "" (\l -> ", one-time token served on local port " <> showT l) (hpListen t)+        <> "; upnpc -l for the gateway's mappings"++{- | The reasons not to connect at all, each an @unknown@: no external+address, an address that is this host's own (the connection would never+reach the gateway), a declared local port that is not listened on. 'Nothing'+when the connection is worth making.+-}+hairpinBlocked :: HairpinTarget -> Evidence -> Maybe Judgement+hairpinBlocked t ev = case evExternal ev of+    Left why -> Just (unknown [why] (Just "Without the external address there is nothing to connect to: declare it (--hairpin ADDR:PORT), or an --echo URL."))+    Right ext+        | (127 : _) <- fromMaybe [] (ipv4Octets (extAddress ext)) ->+            Just (unknown [externalLine ext] (Just "A loopback address is this host, not a gateway's external address: nothing would be hairpinned."))+        | evLocal ev == Just (extAddress ext) ->+            Just (unknown [externalLine ext, "this host holds that address itself"] (Just "A connection to one's own address never reaches the gateway: there is no NAT between this host and that address to hairpin through."))+        | otherwise -> case (hpListen t, evListener ev) of+            (Just p, Nothing) -> Just (unknown [externalLine ext, "no listener was opened on local port " <> showT p] Nothing)+            (Just _, Just (Left why)) -> Just (unknown [externalLine ext, why] Nothing)+            _ -> Nothing+  where+    unknown = Judgement Nothing++{- | What the evidence means. The token never shows in the evidence, and a+verdict other than @unknown@ is only given when the evidence settles it: see+the module's header.+-}+judgeHairpin :: HairpinTarget -> Evidence -> Judgement+judgeHairpin t ev = case (hairpinBlocked t ev, evExternal ev) of+    (Just j, _) -> j+    (Nothing, Left why) -> Judgement Nothing [why] Nothing+    (Nothing, Right ext) ->+        let target = extAddress ext <> ":" <> showT (hpPort t)+            listener = hpListen t >> evListener ev >>= either (const Nothing) Just+            before = [externalLine ext] <> ["the connection leaves from " <> l | Just l <- [evLocal ev]] <> [mappingLine t (evMapping ev)]+            after = maybe [] (arrivals . snd) listener+            say ok what meaning = Judgement ok (before <> what <> after) meaning+            listed = case evMapping ev of+                ListedHere _ -> True+                ListedElsewhere _ -> True+                _ -> False+            here = case evMapping ev of+                ListedHere _ -> True+                _ -> False+         in case evAttempt ev of+                Nothing -> say Nothing ["no connection was attempted"] Nothing+                Just (Accepted back) -> case listener of+                    Just (token, peers)+                        | token `elem` back ->+                            say (Just True) ["this host connected to " <> target <> " and read back the token it serves"] Nothing+                        | here && null peers ->+                            say+                                (Just False)+                                ["this host connected to " <> target <> " but did not read its own token"]+                                (Just "The gateway lists the mapping as leading to this report's listener, yet something else answered the connection made from inside: the gateway does not send connections from the LAN to its external address through its mappings (it answers them itself).")+                        | otherwise ->+                            say+                                Nothing+                                ["this host connected to " <> target <> " but did not read its own token"]+                                (Just "Something accepted at that address and port and was not shown to be this report's listener: the gateway itself, or a mapping to another host or port. A missing hairpin and a missing mapping look the same from here.")+                    Nothing+                        | listed ->+                            say+                                (Just True)+                                ["this host connected to " <> target]+                                (Just "Something accepted the connection and the gateway lists a mapping of that port. No token was exchanged (declare PORT@LISTEN, with the mapping leading to LISTEN, for that), so this does not show that the mapped host is what answered.")+                        | otherwise ->+                            say+                                Nothing+                                ["this host connected to " <> target]+                                (Just "Something accepted the connection, but no mapping of that port is known and no token was exchanged: a gateway answering on its own external address (an administration page) looks the same.")+                Just AttemptRefused+                    | here, Just (_, []) <- listener ->+                        say+                            (Just False)+                            ["the connection to " <> target <> " was refused"]+                            (Just "The gateway lists the mapping as leading to this report's listener, the listener saw nothing, and the connection was refused: it did not come back in. A firewall on this host that rejects the port would look the same.")+                    | otherwise ->+                        say+                            Nothing+                            ["the connection to " <> target <> " was refused"]+                            (Just "Refused by the gateway, or by the mapped host if nothing listens there. Without a mapping the gateway lists as leading to a listener of this report (PORT@LISTEN), a missing hairpin cannot be told from a missing mapping or a closed port.")+                Just AttemptTimedOut ->+                    say+                        Nothing+                        ["no answer from " <> target <> " within " <> showT hairpinConnectSeconds <> "s"]+                        (Just "Dropped somewhere: a gateway that does not hairpin, a firewall on the gateway or on this host, or no mapping at all. A timeout does not tell these apart.")+                Just (AttemptUnreachable why) ->+                    say Nothing [why] (Just "This host has no route to the address, which says nothing about hairpinning.")+                Just (AttemptFailed why) -> say Nothing [why] Nothing+  where+    arrivals [] = ["no connection reached the local listener"]+    arrivals peers = ["the local listener accepted a connection from " <> Text.intercalate ", " (take 3 (nub peers))]++externalLine :: External -> Text+externalLine ext =+    "the external address is "+        <> extAddress ext+        <> " ("+        <> cls+        <> "), "+        <> case extSource ext of+            Declared -> "as declared"+            FromGateway -> "as the gateway reports it"+            FromEcho -> "as the declared --echo URL answers"+  where+    cls = case classifyAddress (extAddress ext) of+        _ | (127 : _) <- fromMaybe [] (ipv4Octets (extAddress ext)) -> "loopback"+        Public -> "public"+        Private -> "private: the gateway is itself behind another NAT, and only this gateway is tested"+        CGNAT -> "carrier-grade NAT: the gateway is itself behind another NAT, and only this gateway is tested"+        Unparseable -> "unparseable"++mappingLine :: HairpinTarget -> MappingState -> Text+mappingLine t st = case st of+    Unlisted why -> "the gateway's mappings could not be listed: " <> why+    NotListed -> "the gateway lists no TCP mapping of external port " <> showT (hpPort t) <> " (a forwarding configured by hand on the router may not be listed)"+    ListedHere m -> listing m <> ", " <> maybe "this host" (const "this report's listener") (hpListen t)+    ListedElsewhere m -> listing m <> ", which is not " <> maybe "this host" (const "this report's listener") (hpListen t)+  where+    listing m = "the gateway lists TCP " <> showT (mapExternalPort m) <> " -> " <> fromMaybe "(unreadable address)" (parseIPv4 (mapInternalAddress m)) <> ":" <> showT (mapInternalPort m)++-------------------------------------------------------------------------------+-- The connection++-- | How long the connection may take, and how long the token is waited for once connected.+hairpinConnectSeconds, hairpinReadSeconds :: Int+hairpinConnectSeconds = 3+hairpinReadSeconds = 2++-- | The lines of what was read, cut down to the token's alphabet (as the inbound test's vantage does).+tokenLines :: ByteString.ByteString -> [Text]+tokenLines bytes =+    take 4 [l | l <- Text.filter tokenChar . Text.pack <$> lines (Char8.unpack (ByteString.take 256 bytes)), not (Text.null l)]+  where+    tokenChar c = isAsciiLower c || isAsciiUpper c || isDigit c || c == '_' || c == '-'++{- | One TCP connection to an IPv4 address and port, bounded by the two+waits (microseconds), reading what the other side sends when asked to.+Nothing is written to the connection, and nothing here throws: what went+wrong is the 'Attempt'.+-}+connectAttempt :: Int -> Int -> Text -> Int -> Bool -> IO Attempt+connectAttempt connectMicros readMicros host port readBack = case ipv4Octets host of+    Just [a, b, c, d] -> do+        r <- try $ bracket (socket AF_INET Stream defaultProtocol) close $ \s -> do+            -- no child of this process (the other probes' tools) inherits the connection+            withFdSocket s setCloseOnExecIfNeeded+            connected <- timeout connectMicros (connect s (SockAddrInet (fromIntegral port) (tupleToHostAddress (fromIntegral a, fromIntegral b, fromIntegral c, fromIntegral d))))+            case connected of+                Nothing -> pure AttemptTimedOut+                Just ()+                    | readBack -> Accepted . tokenLines <$> readSome s+                    | otherwise -> pure (Accepted [])+        pure (either classify id r)+    _ -> pure (AttemptFailed ("not a dotted IPv4 address: " <> host))+  where+    -- what arrives until the other side closes, 256 bytes came, or the wait is over+    readSome s = do+        acc <- newIORef ByteString.empty+        let go = do+                chunk <- recv s 256+                unless (ByteString.null chunk) $ do+                    modifyIORef' acc (<> chunk)+                    n <- ByteString.length <$> readIORef acc+                    when (n < 256) go+        _ <- try (timeout readMicros go) :: IO (Either SomeException (Maybe ()))+        readIORef acc+    classify :: IOException -> Attempt+    classify e = case Errno <$> ioe_errno e of+        Just n+            | n == eCONNREFUSED -> AttemptRefused+            | n == eTIMEDOUT -> AttemptTimedOut+            | n == eHOSTUNREACH || n == eNETUNREACH -> AttemptUnreachable (Text.pack (show e))+        _ -> AttemptFailed (Text.pack (show e))++{- | This host's address on the route to an IPv4 address: a connected UDP+socket sends nothing. 'Nothing' when there is no route.+-}+localAddressToward :: Text -> Int -> IO (Maybe Text)+localAddressToward host port = case ipv4Octets host of+    Just [a, b, c, d] -> do+        r <- try $ bracket (socket AF_INET Datagram defaultProtocol) close $ \s -> do+            connect s (SockAddrInet (fromIntegral port) (tupleToHostAddress (fromIntegral a, fromIntegral b, fromIntegral c, fromIntegral d)))+            getSocketName s+        pure $ case r of+            Right (SockAddrInet _ h) ->+                let (w, x, y, z) = hostAddressToTuple h+                 in Just (Text.intercalate "." (Text.pack . show <$> [w, x, y, z]))+            Right _ -> Nothing+            Left (_ :: SomeException) -> Nothing+    _ -> pure Nothing

@@ -0,0 +1,356 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++{- | @salmon-report@'s inbound reachability test: does a TCP connection made+from a /second vantage point/ (a machine outside the network) to a declared+external address and port arrive? The first vantage point cannot tell: from+inside, a connection to one's own external address tests the router's+hairpin, not the way in.++What is declared, and nothing else is contacted:++* @--inbound HOST:PORT[\@LISTEN]@: the external address and port to connect+  to. With @\@LISTEN@, @salmon-report@ itself listens on that local port for+  the length of the report and hands a one-time token to whoever connects; a+  vantage that reads the token back has proven the connection arrived /at+  this host/. Without it, something must already listen, and "connected"+  only says that something accepted at that address.+* @--vantage-ssh [USER\@]HOST@: a machine to ask, reached with the+  operator's own @ssh@. Keys, ports, jump hosts and host keys are @ssh@'s+  business (its configuration, or the file given with+  @--vantage-ssh-config@); nothing here reads key material, and+  @BatchMode=yes@ means a login that would prompt fails instead.++The vantage needs @bash@ (for @\/dev\/tcp@) and coreutils' @timeout@. It runs+one fixed command, 'remoteCommand', in which only the host and the port vary;+both are re-rendered from a strict alphabet and parsed numbers, so nothing a+declaration says reaches the remote shell as syntax or @ssh@ as an option.++This module is the pure half (declarations, the argument vector, reading the+vantage's answer, the judgement) and the token listener; "Report" holds the+shell-out and the probes.+-}+module Report.Inbound (+    -- * Declarations+    InboundSpec (..),+    noInbound,+    InboundTarget (..),+    parseInboundTarget,+    renderTarget,+    Vantage (..),+    parseVantage,++    -- * Asking the vantage+    connectSeconds,+    remoteCommand,+    sshArgs,+    VantageAnswer (..),+    parseVantageOutput,++    -- * Judging+    inboundQuestion,+    inboundMethod,+    judgeInbound,++    -- * The token listener+    Listener (..),+    withListener,+    withListeners,+) where++import Control.Concurrent.Async (withAsync)+import Control.Exception (SomeException, bracket, bracketOnError, finally, try)+import Control.Monad (forever, void)+import Data.Aeson (FromJSON, ToJSON)+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Char8 as Char8+import Data.Char (isAlphaNum, isDigit)+import Data.IORef (atomicModifyIORef', newIORef, readIORef)+import Data.List (nub)+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.Generics (Generic)+import Network.Socket (+    Family (AF_INET, AF_INET6),+    SockAddr (..),+    Socket,+    SocketOption (IPv6Only, ReuseAddr),+    SocketType (Stream),+    accept,+    bind,+    close,+    defaultProtocol,+    listen,+    setCloseOnExecIfNeeded,+    setSocketOption,+    socket,+    socketPort,+    tupleToHostAddress,+    withFdSocket,+ )+import Network.Socket.ByteString (sendAll)+import Numeric (showHex)+import System.IO (IOMode (ReadMode), withBinaryFile)+import Text.Read (readMaybe)++import Report.Dns (Judgement (..))+import Report.Nmap (checkHost)++-------------------------------------------------------------------------------+-- Declarations++-- | What the operator declares for the inbound test. Empty is "no test".+data InboundSpec = InboundSpec+    { inbTargets :: [Text]+    -- ^ @HOST:PORT[\@LISTEN]@, see 'parseInboundTarget'+    , inbVantageSsh :: [Text]+    -- ^ @[USER\@]HOST@ destinations handed to @ssh@, see 'parseVantage'+    , inbSshConfig :: Maybe FilePath+    -- ^ an @ssh@ configuration file (@ssh -F@), the operator's own when absent+    }+    deriving (Eq, Show, Generic)++instance ToJSON InboundSpec+instance FromJSON InboundSpec++noInbound :: InboundSpec+noInbound = InboundSpec [] [] Nothing++-- | An external address and port, and the local port to listen on, if any.+data InboundTarget = InboundTarget+    { inHost :: Text+    , inPort :: Int+    , inListen :: Maybe Int+    }+    deriving (Eq, Ord, Show)++{- | Reads @HOST:PORT[\@LISTEN]@ (an IPv6 address goes in brackets). The host+is one DNS name or one address, as for @--nmap@.+-}+parseInboundTarget :: Text -> Either Text InboundTarget+parseInboundTarget raw = do+    let (target, at) = Text.breakOn "@" (Text.strip raw)+        (h, p) = Text.breakOnEnd ":" target+    lport <- if Text.null at then Right Nothing else Just <$> port "local port" (Text.drop 1 at)+    bracketed <- maybe (Left "not of the form HOST:PORT") Right (Text.stripSuffix ":" h)+    host <- checkHost (Text.dropAround (`elem` ("[]" :: String)) bracketed)+    eport <- port "port" p+    pure (InboundTarget host eport lport)+  where+    port what x+        | not (Text.null x) && Text.all isDigit x && Text.length x <= 5+        , Just n <- readMaybe (Text.unpack x)+        , n >= 1 && n <= 65535 =+            Right n+        | otherwise = Left ("not a " <> what <> " between 1 and 65535: " <> if Text.null x then "(empty)" else x)++-- | @HOST:PORT@, with an IPv6 address back in its brackets.+renderTarget :: InboundTarget -> Text+renderTarget t+    | Text.any (== ':') (inHost t) = "[" <> inHost t <> "]:" <> p+    | otherwise = inHost t <> ":" <> p+  where+    p = Text.pack (show (inPort t))++-- | An @ssh@ destination, checked: @[USER\@]HOST@.+newtype Vantage = Vantage {vantageDest :: Text}+    deriving (Eq, Ord, Show)++{- | Reads @[USER\@]HOST@. Anything @ssh@ could read as an option or the+remote shell as syntax is refused; a port, a jump host or an identity belong+in the @ssh@ configuration.+-}+parseVantage :: Text -> Either Text Vantage+parseVantage raw = case Text.splitOn "@" dest of+    [h] -> Vantage <$> checkHost h+    [u, h]+        | Text.null u || "-" `Text.isPrefixOf` u || not (Text.all userChar u) -> Left "not a user name ssh would take"+        | otherwise -> (\host -> Vantage (u <> "@" <> host)) <$> checkHost h+    _ -> Left "not of the form [USER@]HOST"+  where+    dest = Text.strip raw+    userChar c = (isAlphaNum c && c < '\x80') || c `elem` ("._-" :: String)++-------------------------------------------------------------------------------+-- Asking the vantage++-- | How long the vantage waits for its connection (and for the token), and @ssh@ for its own.+connectSeconds :: Int+connectSeconds = 4++connectedMarker, exitMarker :: Text+connectedMarker = "salmon-inbound:connected"+exitMarker = "salmon-inbound:exit:"++{- | The one command the vantage runs, as a single string for its login+shell: open a TCP connection with @bash@'s @\/dev\/tcp@ under @timeout@, say+so, read the token back when one is expected (filtered down to the token's+alphabet), and always end with the exit status on a line of its own.+-}+remoteCommand :: InboundTarget -> Text+remoteCommand t =+    "bash -c 'r=0; timeout "+        <> Text.pack (show connectSeconds)+        <> " bash -c \"exec 3<>/dev/tcp/"+        <> inHost t+        <> "/"+        <> Text.pack (show (inPort t))+        <> " && echo "+        <> connectedMarker+        <> maybe "" (const " && head -c 128 <&3 | tr -cd a-zA-Z0-9_-") (inListen t)+        <> "\" 2>&1 || r=$?; echo; echo "+        <> exitMarker+        <> "$r'"++{- | The arguments of the one @ssh@ a probe runs. No terminal, no prompt+(@BatchMode@), a bounded connection, and @--@ before the destination.+-}+sshArgs :: Maybe FilePath -> Vantage -> InboundTarget -> [String]+sshArgs cfg v t =+    maybe [] (\f -> ["-F", f]) cfg+        <> ["-o", "BatchMode=yes", "-o", "ConnectTimeout=" <> show connectSeconds, "-T", "--", Text.unpack (vantageDest v), Text.unpack (remoteCommand t)]++-- | What came back from the vantage.+data VantageAnswer+    = -- | the connection was accepted; the lines read from it, when asked to read+      Connected [Text]+    | Refused+    | -- | nothing answered within 'connectSeconds'+      TimedOut+    | -- | the vantage itself has no way to the address, in its words+      Unreachable Text+    | -- | the command ran and failed otherwise, or never ran: what was printed+      VantageFailed [Text]+    deriving (Eq, Show)++-- | Reads the output of 'remoteCommand' (and whatever @ssh@ printed around it).+parseVantageOutput :: Text -> VantageAnswer+parseVantageOutput out+    | connectedMarker `elem` ls = Connected [l | l <- drop 1 (dropWhile (/= connectedMarker) ls), not (exitMarker `Text.isPrefixOf` l)]+    | otherwise = case exitStatus of+        Nothing -> VantageFailed (take 3 ls)+        Just 124 -> TimedOut+        Just n+            | said "Connection refused" -> Refused+            | (l : _) <- [l | l <- said', any (`Text.isInfixOf` l) ["No route to host", "Network is unreachable"]] -> Unreachable l+            | otherwise -> VantageFailed (take 3 said' <> ["the vantage's command exited " <> Text.pack (show n)])+  where+    ls = filter (not . Text.null) (Text.strip <$> Text.lines out)+    said' = filter (not . Text.isPrefixOf exitMarker) ls+    said w = any (w `Text.isInfixOf`) said'+    exitStatus = case [n | l <- ls, Just x <- [Text.stripPrefix exitMarker l], Just n <- [readMaybe (Text.unpack x) :: Maybe Int]] of+        [] -> Nothing+        ns -> Just (last ns)++-------------------------------------------------------------------------------+-- Judging++inboundQuestion :: Vantage -> InboundTarget -> Text+inboundQuestion v t =+    "Does a TCP connection from " <> vantageDest v <> " to " <> renderTarget t <> " arrive" <> maybe "?" (const " at this host?") (inListen t)++inboundMethod :: Vantage -> InboundTarget -> Text+inboundMethod v t =+    "ssh "+        <> vantageDest v+        <> ", bash /dev/tcp connect to "+        <> renderTarget t+        <> maybe "" (\p -> ", one-time token served on local port " <> Text.pack (show p)) (inListen t)++{- | What the answer means. The second argument is the listener's side when+the target declared one: the token it served and the peers it accepted. The+token itself never shows in the evidence.+-}+judgeInbound :: InboundTarget -> Maybe (Text, [Text]) -> VantageAnswer -> Judgement+judgeInbound t local answer = case (answer, local) of+    (Connected _, Nothing) ->+        Judgement+            (Just True)+            ["the vantage connected to " <> target]+            (Just "Something accepted the connection at that address and port. No token was exchanged (declare HOST:PORT@LISTEN for that), so this does not show that it was this host.")+    (Connected back, Just (token, peers))+        | token `elem` back -> Judgement (Just True) (["the vantage connected to " <> target <> " and read back the token this host served"] <> arrivals peers) Nothing+        | otherwise ->+            Judgement+                (Just False)+                (["the vantage connected to " <> target <> " but did not read this host's token"] <> arrivals peers)+                (Just "Something else accepts connections at that address and port: the router itself, another host, or a mapping to another local port.")+    (Refused, _) ->+        no+            ["the connection to " <> target <> " was refused"]+            "The address answered and refused: the packet reached a machine (often the router) on which nothing forwards or listens on this port."+    (TimedOut, _) ->+        no+            ["no answer from " <> target <> " within " <> Text.pack (show connectSeconds) <> "s"]+            "Dropped on the way: no port mapping, a firewall, or an address that is not this network's (double NAT). A vantage whose own outbound traffic is filtered looks the same."+    (Unreachable why, _) -> Judgement Nothing ([why] <> arrivals') (Just "The vantage has no route to the address, which says nothing about this network.")+    (VantageFailed said, _) -> Judgement Nothing ((if null said then ["the vantage printed nothing"] else said) <> arrivals') (Just "The vantage could not be asked: check that ssh reaches it without a prompt and that it has bash and timeout.")+  where+    target = renderTarget t+    no ev meaning = Judgement (Just False) (ev <> arrivals') (Just meaning)+    arrivals' = maybe [] (arrivals . snd) local+    arrivals [] = ["no connection reached the local listener"]+    arrivals peers = ["the local listener accepted a connection from " <> Text.intercalate ", " (take 3 (nub peers))]++-------------------------------------------------------------------------------+-- The token listener++-- | A listener of this process: the token it hands out and who connected so far.+data Listener = Listener+    { listenerToken :: Text+    , listenerPort :: Int+    , listenerPeers :: IO [Text]+    }++{- | Listens on a local TCP port (every address, IPv6 and IPv4; port 0 takes+a free one) while the action runs, sending a fresh token and closing to+whoever connects. The token is random, used once and is not a credential: it+only tells this listener from whatever else may answer at the external+address. A port that cannot be bound is a reason, and the action still runs.+-}+withListener :: Int -> (Either Text Listener -> IO a) -> IO a+withListener port act = do+    opened <- try (bracketOnError open close (\s -> (,) s <$> newToken))+    case opened of+        Left (e :: SomeException) -> act (Left ("could not listen on local port " <> Text.pack (show port) <> ": " <> Text.pack (show e)))+        Right (s, token) -> (`finally` close s) $ do+            peers <- newIORef []+            actual <- fromIntegral <$> socketPort s+            let serve = forever $ do+                    (conn, peer) <- accept s+                    atomicModifyIORef' peers (\ps -> (ps <> [Text.pack (show peer)], ()))+                    void (try (sendAll conn (Char8.pack (Text.unpack token) <> "\n")) :: IO (Either SomeException ()))+                    close conn+            withAsync serve (\_ -> act (Right (Listener token actual (readIORef peers))))+  where+    open = do+        r <- try (listenOn AF_INET6 (SockAddrInet6 (fromIntegral port) 0 (0, 0, 0, 0) 0))+        case r of+            Right s -> pure s+            Left (_ :: SomeException) -> listenOn AF_INET (SockAddrInet (fromIntegral port) (tupleToHostAddress (0, 0, 0, 0)))+    listenOn :: Family -> SockAddr -> IO Socket+    listenOn family addr =+        bracketOnError (socket family Stream defaultProtocol) close $ \s -> do+            -- no child of this process (ssh, the other probes' tools) inherits the listener+            withFdSocket s setCloseOnExecIfNeeded+            setSocketOption s ReuseAddr 1+            if family == AF_INET6 then setSocketOption s IPv6Only 0 else pure ()+            bind s addr+            listen s 8+            pure s++-- | One listener per distinct port, all held while the action runs.+withListeners :: [Int] -> (Map.Map Int (Either Text Listener) -> IO a) -> IO a+withListeners ports act = go (nub ports) Map.empty+  where+    go [] acc = act acc+    go (p : ps) acc = withListener p (\l -> go ps (Map.insert p l acc))++-- | 128 random bits from the kernel, in the alphabet 'remoteCommand' lets through.+newToken :: IO Text+newToken = do+    bytes <- withBinaryFile "/dev/urandom" ReadMode (`ByteString.hGet` 16)+    pure ("salmon-token-" <> Text.pack (concatMap hex (ByteString.unpack bytes)))+  where+    hex b = (if b < 16 then "0" else "") <> showHex b ""

@@ -0,0 +1,216 @@+{-# LANGUAGE OverloadedStrings #-}++{- | The pure half of @salmon-report@'s @nmap@ probe: a declared target read+into a host and a port list, the argument vector handed to @nmap@, and what+its grepable output (@-oG -@) says about each port. No IO here; "Report"+holds the shell-out.++What is scanned is exactly what the operator declared with @--nmap+HOST:PORTS@: one host (a name or one address, never a range, a mask or a+list) and an explicit, bounded port list. There is no default target and no+default port list, and nothing a declaration says reaches @nmap@ as an+option: the host is checked against a strict alphabet and the ports are+re-rendered from the parsed numbers.+-}+module Report.Nmap (+    -- * Declared targets+    NmapTarget (..),+    parseNmapTarget,+    checkHost,+    parsePorts,+    renderPorts,+    maxPorts,+    nmapArgs,++    -- * Grepable output+    PortState (..),+    NmapScan (..),+    parseNmapGrepable,+    portState,+    stateText,+) where++import Data.Char (isAlpha, isAlphaNum, isDigit, isHexDigit)+import Data.List (nub, sort)+import qualified Data.Map.Strict as Map+import Data.Maybe (mapMaybe)+import Data.Text (Text)+import qualified Data.Text as Text+import Text.Read (readMaybe)++-------------------------------------------------------------------------------+-- Declared targets++-- | One host and the TCP ports to look at, sorted and without duplicates.+data NmapTarget = NmapTarget+    { targetHost :: Text+    , targetPorts :: [Int]+    }+    deriving (Eq, Ord, Show)++-- | The most ports one target may declare: a report looks at named ports, it does not sweep.+maxPorts :: Int+maxPorts = 128++{- | Reads @HOST:PORTS@ (the last colon splits, so an IPv6 address goes in+brackets). The host is a DNS name, an IPv4 address or an IPv6 address; the+forms @nmap@ would expand into several hosts (@10.0.0.0\/24@, @10.0.0.1-9@,+@10.0.0.*@, a list) and anything starting with a dash are refused with a+reason.+-}+parseNmapTarget :: Text -> Either Text NmapTarget+parseNmapTarget raw = do+    let (h, p) = Text.breakOnEnd ":" (Text.strip raw)+    bracketed <- maybe (Left "not of the form HOST:PORTS") Right (Text.stripSuffix ":" h)+    host <- checkHost (Text.dropAround (`elem` ("[]" :: String)) bracketed)+    ports <- parsePorts p+    pure (NmapTarget host ports)++-- | One DNS name, IPv4 address or IPv6 address, from a strict alphabet; else the reason.+checkHost :: Text -> Either Text Text+checkHost h+    | Text.null h = Left "no host before the colon"+    | "-" `Text.isPrefixOf` h = Left "a host cannot start with a dash"+    | Text.any (== ':') h =+        if Text.all (\c -> isHexDigit c || c == ':' || c == '.') h+            then Right h+            else Left "not an IPv6 address"+    | not (Text.all (\c -> (isAlphaNum c && c < '\x80') || c `elem` ("._-" :: String)) h) =+        Left "a host is one DNS name or one address: no mask, list or wildcard"+    | Text.any isAlpha h = Right h+    | isIpv4 h = Right h+    | otherwise = Left "a host is one DNS name or one address: no address range"+  where+    isIpv4 t = case Text.splitOn "." t of+        os@[_, _, _, _] -> all octet os+        _ -> False+    octet o = not (Text.null o) && Text.all isDigit o && Text.length o <= 3 && maybe False (<= (255 :: Int)) (readMaybe (Text.unpack o))++{- | Reads a port list such as @22,80,8000-8010@ into sorted, distinct port+numbers; at most 'maxPorts' of them.+-}+parsePorts :: Text -> Either Text [Int]+parsePorts t = do+    parts <- traverse part (Text.splitOn "," (Text.strip t))+    let ports = nub (sort (concat parts))+    if length ports > maxPorts+        then Left ("more than " <> Text.pack (show maxPorts) <> " ports declared for one target")+        else Right ports+  where+    part x = case Text.splitOn "-" (Text.strip x) of+        [a] -> (: []) <$> port a+        [a, b] -> do+            lo <- port a+            hi <- port b+            if lo > hi+                then Left ("the port range " <> x <> " is backwards")+                else -- bounded before it is built: the cap is checked again on the whole list+                    if hi - lo >= maxPorts+                        then Left ("more than " <> Text.pack (show maxPorts) <> " ports declared for one target")+                        else Right [lo .. hi]+        _ -> Left ("not a port or a port range: " <> x)+    port x+        | not (Text.null x) && Text.all isDigit x && Text.length x <= 5+        , Just n <- readMaybe (Text.unpack x)+        , n >= 1 && n <= 65535 =+            Right n+        | otherwise = Left ("not a port between 1 and 65535: " <> if Text.null x then "(empty)" else x)++-- | The port list as @nmap -p@ takes it, with runs folded back into ranges.+renderPorts :: [Int] -> Text+renderPorts = Text.intercalate "," . fmap one . runs+  where+    runs [] = []+    runs (x : xs) = go x x xs+    go lo hi (y : ys) | y == hi + 1 = go lo y ys+    go lo hi rest = (lo, hi) : runs rest+    one (lo, hi)+        | lo == hi = Text.pack (show lo)+        | otherwise = Text.pack (show lo) <> "-" <> Text.pack (show hi)++{- | The arguments of the one scan a target gets: a TCP connect scan (no raw+sockets, so no privilege), no host discovery (@-Pn@: nothing but the declared+ports is touched, and a host that is away shows as filtered ports), no+reverse lookup, grepable output on stdout.+-}+nmapArgs :: NmapTarget -> [String]+nmapArgs t =+    ["-6" | Text.any (== ':') (targetHost t)]+        <> ["-sT", "-Pn", "-n", "-oG", "-", "-p", Text.unpack (renderPorts (targetPorts t)), Text.unpack (targetHost t)]++-------------------------------------------------------------------------------+-- Grepable output++data PortState+    = PortOpen+    | PortClosed+    | -- | nothing answered: a firewall dropped the attempt, or the host is away+      PortFiltered+    | -- | a state a connect scan does not normally give, as printed+      PortOther Text+    deriving (Eq, Show)++stateText :: PortState -> Text+stateText PortOpen = "open"+stateText PortClosed = "closed"+stateText PortFiltered = "filtered"+stateText (PortOther t) = t++readState :: Text -> PortState+readState "open" = PortOpen+readState "closed" = PortClosed+readState "filtered" = PortFiltered+readState t = PortOther t++{- | What one host's @Host:@ lines said. @nmap@ leaves out of the list the+ports of a state shared by many of them and prints the count instead+(@Ignored State: closed (100)@): those are 'scanIgnored'.+-}+data NmapScan = NmapScan+    { scanAddress :: Text+    , scanPorts :: Map.Map Int PortState+    -- ^ the TCP ports listed+    , scanIgnored :: [(PortState, Int)]+    }+    deriving (Eq, Show)++{- | Reads @nmap -oG -@ output for a single host. 'Nothing' when no @Host:@+line was printed (the name did not resolve, or nmap refused to start).+-}+parseNmapGrepable :: Text -> Maybe NmapScan+parseNmapGrepable out = case mapMaybe hostLine (Text.lines out) of+    [] -> Nothing+    ls@((addr, _, _) : _) ->+        -- one target is one host; lines about another address would be a surprise and are left out+        let mine = [(ps, ig) | (a, ps, ig) <- ls, a == addr]+         in Just (NmapScan addr (Map.fromList (concatMap fst mine)) (concatMap snd mine))+  where+    hostLine l = do+        rest <- Text.stripPrefix "Host: " l+        let fields = Text.splitOn "\t" rest+        addr <- case fields of+            (f : _) | (a : _) <- Text.words f -> Just a+            _ -> Nothing+        let ports = concat [mapMaybe portEntry (Text.splitOn "," v) | f <- fields, Just v <- [Text.stripPrefix "Ports:" f]]+            ignored = concat [mapMaybe ignoredEntry (Text.splitOn "," v) | f <- fields, Just v <- [Text.stripPrefix "Ignored State:" f]]+        pure (addr, ports, ignored)+    -- 22/open/tcp//ssh///+    portEntry e = case Text.splitOn "/" (Text.strip e) of+        (p : st : "tcp" : _) | Just n <- readMaybe (Text.unpack p) -> Just (n, readState st)+        _ -> Nothing+    -- closed (100)+    ignoredEntry e = case Text.words (Text.strip e) of+        [st, n] | Just k <- readMaybe (Text.unpack (Text.dropAround (`elem` ("()" :: String)) n)) -> Just (readState st, k)+        _ -> Nothing++{- | The state of one scanned port: as listed, else the one state the+unlisted ports share. With no such single state the output does not say, and+the reason is given.+-}+portState :: NmapScan -> Int -> Either Text PortState+portState scan p = case Map.lookup p (scanPorts scan) of+    Just st -> Right st+    Nothing -> case scanIgnored scan of+        [(st, _)] -> Right st+        [] -> Left "nmap printed no state for this port"+        several -> Left ("nmap did not list this port; the unlisted ones are " <> Text.intercalate ", " [stateText st <> " (" <> Text.pack (show n) <> ")" | (st, n) <- several])

@@ -0,0 +1,329 @@+{-# LANGUAGE OverloadedStrings #-}++{- | The pure half of @salmon-report@'s STUN probe: a declared server read+into a host and a port, the bytes of a Binding request, what the bytes of a+Binding response say (RFC 8489, and the @OTHER-ADDRESS@ of RFC 5780), and+what the mapped addresses seen from one local socket imply about the NAT's+mapping behaviour (RFC 4787). No IO here; "Report" holds the UDP exchange.++Only the servers the operator declared with @--stun HOST:PORT@ are asked:+there is no default server, and the second address a server may advertise is+reported, never contacted.++What is judged is the /mapping/ half of the NAT type: whether the address+and port the NAT gives a local socket stay the same when the destination+changes. The /filtering/ half (what the NAT lets back in) needs a server that+answers from another address on request, and is not looked at.+-}+module Report.Stun (+    -- * Declared servers+    StunServer (..),+    parseStunServer,+    renderStunServer,++    -- * Messages+    TransactionId,+    mkTransactionId,+    bindingRequest,+    StunMessage (..),+    parseStunMessage,+    BindingAnswer (..),+    parseBindingResponse,++    -- * Addresses+    Family (..),+    Endpoint (..),+    endpointV4,+    endpointV6,+    renderEndpoint,++    -- * What the answers imply+    Outcome (..),+    Observation (..),+    Mapping (..),+    classifyMapping,+    judgeMapping,+) where++import Data.Bits (complement, shiftL, xor, (.&.), (.|.))+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.Char (isAlphaNum, isDigit, isHexDigit, isPrint)+import Data.List (nub, sortOn)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.Text.Encoding.Error as Text+import Data.Word (Word16, Word8)+import Numeric (showHex)+import Text.Read (readMaybe)++import Report.Dns (Judgement (..))++-------------------------------------------------------------------------------+-- Declared servers++-- | One STUN server, as declared: a name or an address, and a UDP port.+data StunServer = StunServer+    { stunHost :: Text+    , stunPort :: Int+    }+    deriving (Eq, Ord, Show)++{- | Reads @HOST:PORT@ (the last colon splits, so an IPv6 address goes in+brackets). There is no default port: what is asked is what was written.+-}+parseStunServer :: Text -> Either Text StunServer+parseStunServer raw = do+    let (h, p) = Text.breakOnEnd ":" (Text.strip raw)+    bracketed <- maybe (Left "not of the form HOST:PORT") Right (Text.stripSuffix ":" h)+    let host = Text.dropAround (`elem` ("[]" :: String)) bracketed+    port <-+        if not (Text.null p) && Text.all isDigit p && Text.length p <= 5+            then maybe (Left "not a port") Right (readMaybe (Text.unpack p))+            else Left ("not a port between 1 and 65535: " <> if Text.null p then "(empty)" else p)+    if port < 1 || port > (65535 :: Int)+        then Left ("not a port between 1 and 65535: " <> p)+        else StunServer <$> checkHost host <*> pure port+  where+    checkHost h+        | Text.null h = Left "no host before the colon"+        | Text.any (== ':') h =+            if Text.all (\c -> isHexDigit c || c == ':' || c == '.') h then Right h else Left "not an IPv6 address"+        | Text.all (\c -> (isAlphaNum c && c < '\x80') || c `elem` ("._-" :: String)) h = Right h+        | otherwise = Left "a host is one DNS name or one address"++renderStunServer :: StunServer -> Text+renderStunServer (StunServer h p)+    | Text.any (== ':') h = "[" <> h <> "]:" <> Text.pack (show p)+    | otherwise = h <> ":" <> Text.pack (show p)++-------------------------------------------------------------------------------+-- Messages++-- | The 96 bits naming one request; a response is matched to its request by them.+newtype TransactionId = TransactionId ByteString+    deriving (Eq, Ord, Show)++-- | Twelve bytes, which the caller draws at random.+mkTransactionId :: ByteString -> Maybe TransactionId+mkTransactionId b+    | BS.length b == 12 = Just (TransactionId b)+    | otherwise = Nothing++magicCookie :: ByteString+magicCookie = BS.pack [0x21, 0x12, 0xa4, 0x42]++{- | A Binding request with no attribute: the twenty bytes of the header.+Nothing about this host is in it (no @SOFTWARE@, no credentials).+-}+bindingRequest :: TransactionId -> ByteString+bindingRequest (TransactionId t) = BS.pack [0x00, 0x01, 0x00, 0x00] <> magicCookie <> t++data StunMessage = StunMessage+    { msgType :: Word16+    , msgTransaction :: TransactionId+    , msgAttributes :: [(Word16, ByteString)]+    -- ^ type and value, padding removed, in the order sent+    }+    deriving (Eq, Show)++word16 :: ByteString -> Int -> Word16+word16 b i = (fromIntegral (BS.index b i) `shiftL` 8) .|. fromIntegral (BS.index b (i + 1))++{- | Reads one datagram as a STUN message, or says why it is not one. The+attributes are split, not interpreted; integrity and fingerprint attributes+are not verified (no credential is used, and the transaction id is what ties+an answer to its request).+-}+parseStunMessage :: ByteString -> Either Text StunMessage+parseStunMessage b+    | BS.length b < 20 = Left "shorter than a STUN header"+    | BS.index b 0 .&. 0xc0 /= 0 = Left "the first two bits are set: not a STUN message"+    | BS.take 4 (BS.drop 4 b) /= magicCookie = Left "no STUN magic cookie"+    | len `mod` 4 /= 0 = Left "a message length that is not a multiple of four"+    | BS.length b - 20 /= len = Left "the message length does not match the datagram"+    | otherwise = StunMessage (word16 b 0) (TransactionId (BS.take 12 (BS.drop 8 b))) <$> attributes (BS.drop 20 b)+  where+    len = fromIntegral (word16 b 2) :: Int+    attributes bs+        | BS.null bs = Right []+        | BS.length bs < 4 = Left "a truncated attribute header"+        | BS.length body < padded = Left "a truncated attribute"+        | otherwise = ((word16 bs 0, BS.take l body) :) <$> attributes (BS.drop padded body)+      where+        l = fromIntegral (word16 bs 2) :: Int+        padded = (l + 3) .&. complement 3+        body = BS.drop 4 bs++-- | What a server answered a Binding request with.+data BindingAnswer+    = {- | the address and port the request arrived from, and the second+      address the server advertises when it has one (@OTHER-ADDRESS@)+      -}+      Mapped Endpoint (Maybe Endpoint)+    | -- | an error response: its code and reason phrase+      Refused Int Text+    deriving (Eq, Show)++{- | Reads the response to the request of this transaction.+@XOR-MAPPED-ADDRESS@ is preferred and the plain @MAPPED-ADDRESS@ of older+servers accepted. A message of another transaction, or of another type, is a+reason.+-}+parseBindingResponse :: TransactionId -> ByteString -> Either Text BindingAnswer+parseBindingResponse tid@(TransactionId t) b = do+    msg <- parseStunMessage b+    if msgTransaction msg /= tid+        then Left "a message of another transaction"+        else case msgType msg of+            0x0101 -> do+                let attr k = lookup k (msgAttributes msg)+                    key = magicCookie <> t+                mapped <- case (attr 0x0020, attr 0x0001) of+                    (Just v, _) -> address (Just key) v+                    (Nothing, Just v) -> address Nothing v+                    (Nothing, Nothing) -> Left "a success response without a mapped address"+                -- OTHER-ADDRESS (RFC 5780), or the CHANGED-ADDRESS of RFC 3489 servers+                let other = case (attr 0x802c, attr 0x0005) of+                        (Just v, _) -> either (const Nothing) Just (address Nothing v)+                        (Nothing, Just v) -> either (const Nothing) Just (address Nothing v)+                        (Nothing, Nothing) -> Nothing+                pure (Mapped mapped other)+            0x0111 -> pure $ case lookup 0x0009 (msgAttributes msg) of+                Just v+                    | BS.length v >= 4 ->+                        Refused+                            (fromIntegral (BS.index v 2 .&. 7) * 100 + fromIntegral (BS.index v 3))+                            (Text.take 80 (Text.filter isPrint (Text.decodeUtf8With Text.lenientDecode (BS.drop 4 v))))+                _ -> Refused 0 ""+            ty -> Left ("not a Binding response (type 0x" <> Text.pack (showHex ty "") <> ")")++-- | An address attribute's value; with the key, one whose port and address are XORed with it.+address :: Maybe ByteString -> ByteString -> Either Text Endpoint+address key v+    | BS.length v < 4 = Left "a truncated address attribute"+    | otherwise = case (BS.index v 1, BS.length raw) of+        (1, 4) -> Right (endpointV4 addr port)+        (2, 16) -> Right (endpointV6 [(fromIntegral hi `shiftL` 8) .|. fromIntegral lo | (hi, lo) <- pairs addr] port)+        _ -> Left "an address attribute of an unknown family or length"+  where+    raw = BS.drop 4 v+    addr = maybe (BS.unpack raw) (\k -> BS.zipWith xor k raw) key+    port = fromIntegral (maybe id (const (xor 0x2112)) key (word16 v 2)) :: Int+    pairs (a : c : rest) = (a, c) : pairs rest+    pairs _ = []++-------------------------------------------------------------------------------+-- Addresses++data Family = V4 | V6+    deriving (Eq, Ord, Show)++-- | An address as text (an IPv6 one compressed, without brackets) and a port.+data Endpoint = Endpoint+    { epFamily :: Family+    , epHost :: Text+    , epPort :: Int+    }+    deriving (Eq, Ord, Show)++-- | From the four bytes of an IPv4 address.+endpointV4 :: [Word8] -> Int -> Endpoint+endpointV4 bytes = Endpoint V4 (Text.intercalate "." (Text.pack . show <$> bytes))++-- | From the eight groups of an IPv6 address; the longest run of zero groups is written @::@.+endpointV6 :: [Word16] -> Int -> Endpoint+endpointV6 gs = Endpoint V6 rendered+  where+    hexs = Text.intercalate ":" . fmap (\g -> Text.pack (showHex g ""))+    runs = [(i, length (takeWhile (== 0) (drop i gs))) | i <- [0 .. length gs - 1], gs !! i == 0, i == 0 || gs !! (i - 1) /= 0]+    rendered = case sortOn (negate . snd) (filter ((>= 2) . snd) runs) of+        ((i, n) : _) -> hexs (take i gs) <> "::" <> hexs (drop (i + n) gs)+        [] -> hexs gs++renderEndpoint :: Endpoint -> Text+renderEndpoint (Endpoint V4 h p) = h <> ":" <> Text.pack (show p)+renderEndpoint (Endpoint V6 h p) = "[" <> h <> "]:" <> Text.pack (show p)++-------------------------------------------------------------------------------+-- What the answers imply++data Outcome+    = Answered BindingAnswer+    | -- | the request was sent and nothing usable came back+      Silent Text+    | -- | the request could not be sent at all+      NotAsked Text+    deriving (Eq, Show)++-- | One declared server, asked from the one local socket of its address family.+data Observation = Observation+    { obsServer :: StunServer+    , obsDestination :: Maybe Endpoint+    -- ^ the address the name resolved to, which the request went to+    , obsLocal :: Maybe Endpoint+    -- ^ this host's own address toward it, and the socket's port+    , obsOutcome :: Outcome+    }+    deriving (Eq, Show)++-- | The mapping behaviour the answers of one address family show.+data Mapping+    = -- | every server saw the local address and port: nothing translates+      NoTranslation+    | -- | servers at distinct addresses saw one mapped address and port+      EndpointIndependent+    | -- | the mapped address or port changed with the destination+      DestinationDependent+    | -- | one destination answered: there is nothing to compare+      OneDestination+    | -- | the destinations differ by port only, and saw one mapping+      OneAddress+    deriving (Eq, Show)++{- | From @(destination, local, mapped)@ samples taken on one socket.+Differing mappings settle the question whatever the destinations are; equal+ones only do when the destinations are distinct addresses, since a NAT may+key its mappings on the destination address and not on its port.+-}+classifyMapping :: [(Endpoint, Maybe Endpoint, Endpoint)] -> Mapping+classifyMapping samples+    | length (nub [m | (_, _, m) <- samples]) > 1 = DestinationDependent+    | not (null samples) && all (\(_, l, m) -> l == Just m) samples = NoTranslation+    | length destinations < 2 = OneDestination+    | length (nub (epHost <$> destinations)) < 2 = OneAddress+    | otherwise = EndpointIndependent+  where+    destinations = nub [d | (d, _, _) <- samples]++{- | Whether the NAT keeps one mapping whatever the destination, from every+observation that learnt a mapped address. Each address family has its own+socket and is judged apart: a dependent mapping in either is a "no", and a+"yes" needs every family that answered to say so (an IPv6 path without+translation says nothing of the IPv4 NAT).+-}+judgeMapping :: [Observation] -> Judgement+judgeMapping obs = case [judgeFamily [s | s@(d, _, _) <- samples, epFamily d == fam] | fam <- nub [epFamily d | (d, _, _) <- samples]] of+    [] -> Judgement Nothing ["no declared STUN server gave a mapped address"] Nothing+    js@(first : _) ->+        let pick ok = [j | j <- js, jOk j == ok]+            decided = case (pick (Just False), pick Nothing) of+                (j : _, _) -> j+                ([], j : _) -> j+                ([], []) -> first+         in Judgement (jOk decided) (concatMap jEvidence js) (jMeaning decided)+  where+    samples = nub [(d, obsLocal o, m) | o <- obs, Just d <- [obsDestination o], Answered (Mapped m _) <- [obsOutcome o]]+    saw ss = [renderEndpoint d <> " sees " <> renderEndpoint m <> maybe "" (\l -> " for the local " <> renderEndpoint l) l' | (d, l', m) <- ss]+    judgeFamily ss = case classifyMapping ss of+        NoTranslation ->+            Judgement (Just True) (saw ss) (Just "No address translation on the path: the server sees this host's own address and port, so there is no mapping to keep. Whether a firewall lets inbound UDP through is not tested.")+        EndpointIndependent ->+            Judgement (Just True) (saw ss) (Just "Endpoint-independent mapping: the address a STUN server sees is the one any peer sees, so it can be handed to a peer for UDP hole punching. What the NAT lets back in (its filtering) is not tested.")+        DestinationDependent ->+            Judgement (Just False) (saw ss) (Just "The mapping depends on the destination (a \"symmetric\" NAT): the address a STUN server sees is not the one a peer will see, so exchanging STUN-learnt addresses does not punch a hole; plan for a relay or an explicitly mapped port.")+        OneDestination ->+            Judgement Nothing (saw ss <> ["one server address answered: a second --stun server at another address is needed to compare mappings"]) Nothing+        OneAddress ->+            Judgement Nothing (saw ss <> ["the answers come from one address on several ports: the mapping does not depend on the destination port, and a second --stun server at another address is needed to tell whether it depends on the destination address"]) Nothing

@@ -32,7 +32,10 @@    * @j@\/@k@ (or the arrows): move the cursor over the node table   * @enter@: expand the selected node — its help, notes, paths, edges,-    last check and output ring — and collapse it again+    last check and output ring — and collapse it again. Under it, a live+    tail of what the node is writing: the lines of its one-shot @up@ (a+    streamed command, its own progress messages) or of its held action,+    as the @output@ stream carries them   * @:@: type a serve command; @enter@ sends it asynchronously, @esc@     drops it   * @r@: re-read @\/dag@@@ -319,7 +322,7 @@ -- drawing  draw :: St -> [Widget Name]-draw st = [vBox [header, table, detail, footer]]+draw st = [vBox [header, table, detail, tailPane, footer]]   where     m = st.stModel     nodes = Model.nodesInOrder m@@ -357,6 +360,18 @@             (n : _) -> vLimit 14 (viewport Detail Vertical (vBox (fmap txtWrap (detailLines n))))             [] -> emptyWidget +    -- the live tail of the expanded node; nothing until it has written+    tailPane+        | not st.stExpanded = emptyWidget+        | otherwise = case drop st.stCursor nodes of+            (n : _)+                | ls@(_ : _) <- Model.tailLines 8 n ->+                    vBox (withAttr (attrName "header") (padRight Max (txt ("  tail of " <> n.nodeRef.refShort <> " (live)"))) : fmap (txt . ("  " <>) . printable) ls)+            _ -> emptyWidget++    -- someone else's output: no control character reaches the terminal+    printable = Text.map (\c -> if c < ' ' || c == '\DEL' then ' ' else c)+     footer =         vBox             [ withAttr (attrName "notice") (padRight Max (txt (Text.take 200 st.stNotice)))@@ -382,8 +397,8 @@         ++ ["error: " <> e | Just e <- [n.nodeError]]         ++ ["last event: " <> k <> maybe "" (\s -> " #" <> tshow s) n.nodeLastSeq | Just k <- [n.nodeLastKind]]         ++ case n.nodeOutput of-            [] -> ["output: (none in the last snapshot)"]-            ls -> "output (last snapshot):" : fmap ("  " <>) (lastN 10 ls)+            [] -> ["output: (nothing in the node's ring)"]+            ls -> "output (the node's ring):" : fmap ("  " <>) (lastN 10 ls)   where     lastN k xs = drop (max 0 (length xs - k)) xs 

@@ -2,12 +2,24 @@  import Test.Tasty (defaultMain, testGroup) +import qualified Test.CloudrunSpec as CloudrunSpec import qualified Test.FleetSpec as FleetSpec+import qualified Test.GcpToySpec as GcpToySpec+import qualified Test.QemuPgHaToySpec as QemuPgHaToySpec+import qualified Test.ReportHairpinSpec as ReportHairpinSpec+import qualified Test.ReportInboundSpec as ReportInboundSpec+import qualified Test.ReportSpec as ReportSpec  main :: IO () main =     defaultMain $         testGroup             "salmon-apps"-            [ FleetSpec.tests+            [ CloudrunSpec.tests+            , FleetSpec.tests+            , GcpToySpec.tests+            , QemuPgHaToySpec.tests+            , ReportHairpinSpec.tests+            , ReportInboundSpec.tests+            , ReportSpec.tests             ]

@@ -0,0 +1,524 @@+{- | Layer 0: what @salmon-cloudrun@ reads, refuses and declares. No gcloud+is run, and no node's @up@, @check@ or @down@: these are the parser, the+refusals, the folded graph and the argv of the deploy.+-}+module Test.CloudrunSpec (tests) where++import Data.Aeson (decode, encode)+import qualified Data.ByteString.Lazy.Char8 as LChar8+import Data.Either (isLeft)+import Data.List (isInfixOf)+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as Text+import System.Directory (createDirectory)+import System.FilePath ((</>))+import System.IO.Temp (withSystemTempDirectory)+import System.Process (CmdSpec (..), cmdspec)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase)++-- GHC only solves a `HasField` constraint when the selector is in scope, and+-- `Dag.sameRepresentative` needs these whether or not this module says them.+import Salmon.Builtin.Extension (Extension, dynamics, evalDeps, help, notes, ref)+import Salmon.Builtin.Nodes.Binary (prepare)+import qualified Salmon.Builtin.Nodes.Gcp.CloudRun as CloudRun+import qualified Salmon.Builtin.Nodes.Gcp.LoadBalancing as LoadBalancing+import Salmon.Op.Actions (Act (..))+import qualified Salmon.Op.Dag as Dag+import Salmon.Op.Ref (Ref)++import Cloudrun++tests :: TestTree+tests =+    testGroup+        "salmon-cloudrun (Layer 0)"+        [ testGroup+            "the declaration"+            [ testCase "the documented example reads, with its defaults" exampleReads+            , testCase "the directive reads back as the declaration it was printed from" roundTrips+            , testCase "a key nobody knows is refused, not dropped" unknownKeys+            , testCase "a binding is a variable or a file, never both or neither" bindingTargets+            , testCase "a relative source file is taken from the declaration's directory" sourceFileAnchored+            , testCase "a file with something wrong in it configures to nothing" refusedAtConfig+            ]+        , testGroup+            "refusals"+            [ testCase "the examples have nothing wrong" (mapM_ (\t -> assertEqual (show t) [] (turnupProblems t)) [example, fuller])+            , testCase "each mistake is named" mistakes+            , testCase "a comma in a value is refused by the variable's name, without the value" commaNamesNoValue+            , testCase "a refused declaration is one failing node and no resource" refusedGraph+            ]+        , testGroup+            "the graph"+            [ testCase "no declaration collides with another" noConflicts+            , testCase "a service waits for its account, its grants, its secrets and the API" serviceOrder+            , testCase "the balancer's resources wait for the services and the subnet" balancerOrder+            , testCase "the declared account is under everything that calls gcloud" accountUnderAll+            , testCase "enable_apis false declares no API" noApis+            , testCase "what run down keeps says so, and nothing promises to destroy a secret" keptNodes+            , testCase "no node's text holds the bytes of a source file" noSecretBytes+            ]+        , testGroup+            "what is deployed"+            [ testCase "the deploy's argv" deployArgv+            , testCase "every service carries the turnup's label" ownerLabels+            , testCase "the balancer has a backend per routed service" balancerShape+            ]+        ]++-------------------------------------------------------------------------------++exampleJson :: String+exampleJson =+    unlines+        [ "{"+        , "  \"name\": \"acme\","+        , "  \"project\": \"acme-prod\","+        , "  \"region\": \"europe-west1\","+        , "  \"secrets\": ["+        , "    {\"name\": \"acme-db-password\", \"source_file\": \"/run/acme/db-password\"}"+        , "  ],"+        , "  \"services\": ["+        , "    {"+        , "      \"name\": \"acme-api\","+        , "      \"image\": \"europe-west1-docker.pkg.dev/acme-prod/acme/api:1.4.2\","+        , "      \"service_account\": {\"create\": \"acme-api\"},"+        , "      \"env\": {\"LOG_LEVEL\": \"info\"},"+        , "      \"bind_secrets\": ["+        , "        {\"env\": \"DB_PASSWORD\", \"secret\": \"acme-db-password\"},"+        , "        {\"file\": \"/secrets/tls/key.pem\", \"secret\": \"acme-tls-key\", \"version\": \"3\"}"+        , "      ],"+        , "      \"ingress\": \"internal-and-cloud-load-balancing\","+        , "      \"invoker\": \"no-iam-check\""+        , "    }"+        , "  ],"+        , "  \"load_balancer\": {"+        , "    \"name\": \"acme-lb\","+        , "    \"proxy_subnet\": {\"name\": \"acme-proxy\", \"range\": \"192.168.100.0/24\"},"+        , "    \"default_service\": \"acme-api\""+        , "  }"+        , "}"+        ]++example :: Turnup+example = either (error . ("the example does not read: " <>)) id (parseTurnup (LChar8.pack exampleJson))++api :: Service+api = case example.turnupServices of+    [s] -> s+    _ -> error "the example has one service"++exampleBalancer :: LoadBalancer+exampleBalancer = maybe (error "the example has a balancer") id example.turnupLoadBalancer++-- | Two services, an account that exists, routes, a certificate, an asserted account.+fuller :: Turnup+fuller =+    example+        { turnupAccount = Just "deployer@example.com"+        , turnupServices = [api, web]+        , turnupLoadBalancer =+            Just+                exampleBalancer+                    { lbNetwork = Just "acme-net"+                    , lbDefaultService = "acme-web"+                    , lbHosts = [HostRoute ["app.example.com"] "acme-web" [PathRoute ["/api/*"] "acme-api"]]+                    , lbCertificates = ["acme-cert"]+                    , lbHttp = Just HttpRedirectToHttps+                    }+        }+  where+    web =+        api+            { svcName = "acme-web"+            , svcImage = "europe-west1-docker.pkg.dev/acme-prod/acme/web:7"+            , svcAccount = ExistingAccount "web@acme-prod.iam.gserviceaccount.com"+            , svcEnv = Map.empty+            , svcSecrets = []+            , svcInvoker = InvokerAllUsers+            , svcMinInstances = Just 1+            , svcMaxInstances = Just 4+            , svcCpuAlwaysAllocated = True+            }++dagOf :: Turnup -> Dag.Dag Extension+dagOf = Dag.foldDag Dag.sameRepresentative . evalDeps . turnupOp++texts :: Dag.Dag Extension -> [(Ref, [Text])]+texts dag = [(rf, a.extension.help : a.extension.notes) | (rf, a) <- Map.toList (Dag.dagNodes dag)]++-- | The refs of the nodes whose @help@ holds these words.+named :: Text -> Dag.Dag Extension -> [Ref]+named words' dag = [rf | (rf, a) <- Map.toList (Dag.dagNodes dag), words' `Text.isInfixOf` a.extension.help]++theOne :: Text -> Dag.Dag Extension -> IO Ref+theOne words' dag = case named words' dag of+    [rf] -> pure rf+    others -> assertFailure ("expected one node saying " <> show words' <> ", found " <> show (length others))++notesOf :: Dag.Dag Extension -> Ref -> [Text]+notesOf dag rf = maybe [] (\a -> a.extension.notes) (Map.lookup rf (Dag.dagNodes dag))++-- | Everything a node waits for, however far down.+below :: Dag.Dag Extension -> Ref -> Set.Set Ref+below dag = go Set.empty . Dag.dependenciesOf dag+  where+    go seen [] = seen+    go seen (r : rest)+        | r `Set.member` seen = go seen rest+        | otherwise = go (Set.insert r seen) (Dag.dependenciesOf dag r <> rest)++-------------------------------------------------------------------------------+-- The declaration++exampleReads :: IO ()+exampleReads = do+    assertEqual "name" "acme" example.turnupName+    assertEqual "no account asserted" Nothing example.turnupAccount+    assertEqual "APIs are enabled unless said otherwise" True example.turnupEnableApis+    assertEqual "the secret" [ManagedSecret "acme-db-password" "automatic" (Just "/run/acme/db-password")] example.turnupSecrets+    assertEqual "the account" (CreateAccount "acme-api") api.svcAccount+    assertEqual+        "the bindings, a version being latest unless said"+        [ SecretBinding (EnvVar "DB_PASSWORD") "acme-db-password" "latest"+        , SecretBinding (MountedFile "/secrets/tls/key.pem") "acme-tls-key" "3"+        ]+        api.svcSecrets+    assertEqual "the grants are made unless said otherwise" True api.svcGrantSecretAccess+    assertEqual "ingress" CloudRun.InternalAndLoadBalancing api.svcIngress+    assertEqual "invoker" InvokerNoIamCheck api.svcInvoker+    assertEqual "no knob is set that the file does not set" (Nothing, Nothing, False) (api.svcCpu, api.svcMinInstances, api.svcCpuAlwaysAllocated)+    assertEqual "the balancer" (LoadBalancer "acme-lb" Nothing (Just (ProxySubnet "acme-proxy" "192.168.100.0/24")) "acme-api" [] [] Nothing) exampleBalancer+    -- what a file that says nothing about them gets+    let bare = parseTurnup "{\"name\":\"a\",\"project\":\"p\",\"region\":\"r\",\"services\":[{\"name\":\"s\",\"image\":\"i\",\"service_account\":{\"email\":\"x@y\"}}]}"+    case bare of+        Right t | [s] <- t.turnupServices -> do+            assertEqual "ingress" CloudRun.All s.svcIngress+            assertEqual "invoker" InvokerIam s.svcInvoker+            assertEqual "no balancer" Nothing t.turnupLoadBalancer+            assertEqual "no secret" [] t.turnupSecrets+        other -> assertFailure (show other)++roundTrips :: IO ()+roundTrips =+    mapM_+        (\t -> assertEqual (show t) (Just t) (decode (encode t)))+        [example, fuller, fuller{turnupLoadBalancer = Nothing, turnupEnableApis = False}]++unknownKeys :: IO ()+unknownKeys = do+    refusedNaming "secert" (replace "\"secrets\": [" "\"secert\": [")+    refusedNaming "bind_secret" (replace "\"bind_secrets\"" "\"bind_secret\"")+    refusedNaming "defaultservice" (replace "\"default_service\"" "\"defaultservice\"")+    refusedNaming "ingress" (replace "internal-and-cloud-load-balancing" "internal-and-lb")+  where+    refusedNaming word edit = case parseTurnup (LChar8.pack (edit exampleJson)) of+        Left why -> assertBool why (word `isInfixOf` why)+        Right _ -> assertFailure ("read in spite of " <> word)++replace :: Text -> Text -> String -> String+replace old new = Text.unpack . Text.replace old new . Text.pack++bindingTargets :: IO ()+bindingTargets = do+    assertBool "both" (isLeft (parseTurnup (LChar8.pack (replace "{\"env\": \"DB_PASSWORD\"," "{\"env\": \"DB_PASSWORD\", \"file\": \"/x/y\"," exampleJson))))+    assertBool "neither" (isLeft (parseTurnup (LChar8.pack (replace "{\"env\": \"DB_PASSWORD\"," "{" exampleJson))))+    assertBool "an account both made and named" (isLeft (parseTurnup (LChar8.pack (replace "{\"create\": \"acme-api\"}" "{\"create\": \"acme-api\", \"email\": \"a@b\"}" exampleJson))))++sourceFileAnchored :: IO ()+sourceFileAnchored =+    withSystemTempDirectory "salmon-cloudrun" $ \dir -> do+        createDirectory (dir </> "conf")+        let file = dir </> "conf" </> "turnup.json"+        writeFile file (replace "/run/acme/db-password" "secrets/db-password" exampleJson)+        result <- loadTurnup file+        case result of+            Right t -> assertEqual "" [Just (dir </> "conf" </> "secrets/db-password")] (map msSourceFile t.turnupSecrets)+            Left why -> assertFailure why+        -- an absolute one is the operator's word+        writeFile file exampleJson+        absolute <- loadTurnup file+        assertEqual "" (Right example) absolute++refusedAtConfig :: IO ()+refusedAtConfig =+    withSystemTempDirectory "salmon-cloudrun" $ \dir -> do+        let file = dir </> "turnup.json"+        writeFile file (replace "\"default_service\": \"acme-api\"" "\"default_service\": \"acme-apy\"" exampleJson)+        result <- loadTurnup file+        case result of+            Left why -> assertBool why ("acme-apy" `isInfixOf` why)+            Right _ -> assertFailure "a balancer routing to nothing was configured"++-------------------------------------------------------------------------------+-- Refusals++withService :: (Service -> Service) -> Turnup+withService f = example{turnupServices = [f api]}++withBalancer :: (LoadBalancer -> LoadBalancer) -> Turnup+withBalancer f = example{turnupLoadBalancer = Just (f exampleBalancer)}++mistakes :: IO ()+mistakes =+    mapM_+        ( \(what, turnup, said) -> do+            let problems = turnupProblems turnup+            assertBool (what <> ": " <> show problems) (any (said `Text.isInfixOf`) problems)+        )+        [ ("a name that is no label", example{turnupName = "Acme_Prod"}, "not usable as a label value")+        , ("no project", example{turnupProject = ""}, "no project")+        , ("no service", example{turnupServices = [], turnupLoadBalancer = Nothing}, "no service declared")+        , ("a service twice", example{turnupServices = [api, api]}, "service declared twice: acme-api")+        , ("a secret twice", example{turnupSecrets = example.turnupSecrets <> example.turnupSecrets}, "secret declared twice: acme-db-password")+        , ("a service name GCP refuses", withService (\s -> s{svcName = "Acme"}), "not a Cloud Run service name")+        , ("an account id too short", withService (\s -> s{svcAccount = CreateAccount "api"}), "not a service account id")+        , ("an address that is none", withService (\s -> s{svcAccount = ExistingAccount "acme-api"}), "not a service account's address")+        , ("a variable name", withService (\s -> s{svcEnv = Map.fromList [("LOG-LEVEL", "info")]}), "not an environment variable name: LOG-LEVEL")+        , ("a variable set plainly and from a secret", withService (\s -> s{svcEnv = Map.fromList [("DB_PASSWORD", "x")]}), "variable set twice")+        , ("a relative secret file", withService (\s -> s{svcSecrets = [SecretBinding (MountedFile "tls/key.pem") "k" "latest"]}), "not absolute")+        ,+            ( "two secrets in one directory"+            , withService (\s -> s{svcSecrets = [SecretBinding (MountedFile "/tls/key.pem") "k" "latest", SecretBinding (MountedFile "/tls/cert.pem") "c" "latest"]})+            , "two secrets mounted in one directory"+            )+        , ("a balancer routing to nothing", withBalancer (\l -> l{lbDefaultService = "acme-web"}), "undeclared service: acme-web")+        , ("a route to nothing", withBalancer (\l -> l{lbHosts = [HostRoute ["a.example.com"] "acme-api" [PathRoute ["/x/*"] "nope"]]}), "undeclared service: nope")+        , ("a balancer in front of an internal service", withService (\s -> s{svcIngress = CloudRun.Internal}), "an external balancer cannot reach it")+        , ("the balancer module's own refusals", withBalancer (\l -> l{lbHosts = [HostRoute [] "acme-api" []]}), "a host rule names no host")+        , ("a resource name too long", withBalancer (\l -> l{lbName = Text.replicate 50 "a"}), "longer than 63")+        ]++commaNamesNoValue :: IO ()+commaNamesNoValue = do+    let problems = turnupProblems (withService (\s -> s{svcEnv = Map.fromList [("ORIGINS", "https://a.example.com,https://b.example.com")]}))+    assertBool (show problems) (any ("ORIGINS" `Text.isInfixOf`) problems)+    assertBool (show problems) (not (any ("a.example.com" `Text.isInfixOf`) problems))++refusedGraph :: IO ()+refusedGraph = do+    let dag = dagOf (withBalancer (\l -> l{lbDefaultService = "acme-web"}))+    case texts dag of+        [(_, said)] -> do+            assertBool (show said) (any ("(refused)" `Text.isInfixOf`) said)+            assertBool (show said) (any ("undeclared service: acme-web" `Text.isInfixOf`) said)+        others -> assertFailure ("expected the one refusing node, found " <> show (length others))++-------------------------------------------------------------------------------+-- The graph++noConflicts :: IO ()+noConflicts =+    mapM_+        (\(what, t) -> assertEqual what 0 (length (Dag.dagConflicts (dagOf t))))+        [ ("the example", example)+        , ("two services, one balancer", fuller)+        , ("two services sharing an account and a secret", example{turnupServices = [api, api{svcName = "acme-worker"}], turnupLoadBalancer = Nothing})+        ]++serviceOrder :: IO ()+serviceOrder = do+    let dag = dagOf example+    service <- theOne "deploys CloudRun service acme-api" dag+    account <- theOne "creates service account acme-api" dag+    version <- theOne "to secret acme-db-password" dag+    secret <- theOne "creates secret acme-db-password" dag+    runApi <- theOne "enables the run.googleapis.com API" dag+    secretApi <- theOne "enables the secretmanager.googleapis.com API" dag+    iamApi <- theOne "enables the iam.googleapis.com API" dag+    let under = below dag service+        grants = named "grants roles/secretmanager.secretAccessor to serviceAccount:acme-api@acme-prod.iam.gserviceaccount.com" dag+    mapM_+        (\(what, rf) -> assertBool what (rf `Set.member` under))+        [("the account", account), ("the uploaded version", version), ("the secret", secret), ("the Cloud Run API", runApi)]+    assertEqual "a grant per bound secret" 2 (length grants)+    assertBool "the grants are made before the deploy" (all (`Set.member` under) grants)+    assertEqual+        "one on each secret"+        [["on the secret acme-db-password"], ["on the secret acme-tls-key"]]+        (Set.toList (Set.fromList [filter ("on the secret" `Text.isPrefixOf`) (notesOf dag g) | g <- grants]))+    assertBool "a grant waits for the account it names" (all ((account `Set.member`) . below dag) grants)+    assertBool "the account waits for the IAM API" (iamApi `Set.member` below dag account)+    -- the secret is declared twice, under its version and beside it: the+    -- edge to the API is the second one's+    assertBool "the secret waits for its API" (secretApi `Set.member` below dag secret)+    assertBool "the version waits for the secret" (secret `Set.member` below dag version)+    -- a secret the file does not make is bound and granted on, not created+    assertEqual "" [] (named "creates secret acme-tls-key" dag)+    -- and with the grants left to somebody else there is none+    let ungranted = dagOf (withService (\s -> s{svcGrantSecretAccess = False}))+    assertEqual "" [] (named "grants roles/secretmanager.secretAccessor" ungranted)+    -- an account that exists is not made+    assertEqual "" [] (named "creates service account" (dagOf (withService (\s -> s{svcAccount = ExistingAccount "api@acme-prod.iam.gserviceaccount.com"}))))++balancerOrder :: IO ()+balancerOrder = do+    let dag = dagOf fuller+    root <- theOne "Cloud Run turnup acme (acme-api, acme-web)" dag+    balancer <- theOne "application load balancer acme-lb" dag+    apiService <- theOne "deploys CloudRun service acme-api" dag+    webService <- theOne "deploys CloudRun service acme-web" dag+    subnet <- theOne "creates subnet acme-proxy for REGIONAL_MANAGED_PROXY" dag+    computeApi <- theOne "enables the compute.googleapis.com API" dag+    let parts = [rf | rf <- named "acme-lb" dag, rf /= balancer]+    assertBool "the balancer is made of resources" (length parts > 4)+    mapM_+        ( \part ->+            mapM_+                (\(what, rf) -> assertBool (what <> " under " <> show part) (rf `Set.member` below dag part))+                [("acme-api", apiService), ("acme-web", webService), ("the subnet", subnet), ("the compute API", computeApi)]+        )+        parts+    assertBool "the turnup is over the balancer" (balancer `Set.member` below dag root)+    -- a service the balancer does not route to is still the turnup's+    let apart = dagOf fuller{turnupLoadBalancer = fmap (\l -> l{lbHosts = []}) fuller.turnupLoadBalancer}+    root' <- theOne "Cloud Run turnup acme" apart+    lonely <- theOne "deploys CloudRun service acme-api" apart+    balancer' <- theOne "application load balancer acme-lb" apart+    assertBool "" (lonely `Set.member` below apart root')+    assertBool "" (not (lonely `Set.member` below apart balancer'))++accountUnderAll :: IO ()+accountUnderAll = do+    let dag = dagOf fuller+    account <- theOne "asserts the account gcloud acts as" dag+    assertEqual "" ["declared account: deployer@example.com"] (notesOf dag account)+    gcloud <- theOne "gcloud CLI on PATH" dag+    let exposed = [(rf, said) | (rf, said) <- texts dag, rf `notElem` [account, gcloud], not (account `Set.member` below dag rf)]+    assertEqual "nodes that could run before the account is asserted" [] (map snd exposed)+    -- and without one there is no such node+    assertEqual "" [] (named "asserts the account" (dagOf example))++noApis :: IO ()+noApis = do+    assertEqual "" 4 (length (named "enables the" (dagOf example)))+    assertEqual "" [] (named "enables the" (dagOf example{turnupEnableApis = False}))++keptNodes :: IO ()+keptNodes = do+    let dag = dagOf fuller+        kept words' = do+            rf <- theOne words' dag+            assertBool (show words' <> ": " <> show (notesOf dag rf)) (keptNote `elem` notesOf dag rf)+        notKept words' = do+            rf <- theOne words' dag+            assertBool (show words') (keptNote `notElem` notesOf dag rf)+    mapM_+        kept+        [ "creates service account acme-api"+        , "creates secret acme-db-password"+        , "creates subnet acme-proxy"+        ]+    mapM_ (\g -> assertBool "a grant" (keptNote `elem` notesOf dag g)) (named "grants roles/secretmanager.secretAccessor" dag)+    mapM_+        notKept+        [ "deploys CloudRun service acme-api"+        , "deploys CloudRun service acme-web"+        , "application load balancer acme-lb"+        , -- nothing of gcloud's own node moved, or it would no longer be the node everything else names+          "gcloud CLI on PATH"+        ]+    assertEqual+        "nodes still promising a deletion that does not happen"+        []+        [said | (_, said) <- texts dag, any ("destroys every version" `Text.isInfixOf`) said]+    root <- theOne "Cloud Run turnup acme" dag+    assertBool "the turnup says what goes" (any ("deletes the services carrying the label salmon-turnup=acme and the resources of the balancer acme-lb" `Text.isInfixOf`) (notesOf dag root))+    assertBool "and what stays" (any ("keeps the secrets" `Text.isInfixOf`) (notesOf dag root))++noSecretBytes :: IO ()+noSecretBytes =+    withSystemTempDirectory "salmon-cloudrun" $ \dir -> do+        let marker = "hunter2-not-for-any-report"+        writeFile (dir </> "db-password") marker+        writeFile (dir </> "turnup.json") (replace "/run/acme/db-password" "db-password" exampleJson)+        result <- loadTurnup (dir </> "turnup.json")+        case result of+            Left why -> assertFailure why+            Right t -> do+                assertBool "the directive" (not (marker `isInfixOf` LChar8.unpack (encode t)))+                assertEqual "nodes" [] [said | (_, said) <- texts (dagOf t), any (Text.pack marker `Text.isInfixOf`) said]++-------------------------------------------------------------------------------+-- What is deployed++deployArgv :: IO ()+deployArgv =+    assertEqual+        ""+        ( RawCommand+            "gcloud"+            [ "run"+            , "deploy"+            , "acme-api"+            , "--image"+            , "europe-west1-docker.pkg.dev/acme-prod/acme/api:1.4.2"+            , "--service-account"+            , "acme-api@acme-prod.iam.gserviceaccount.com"+            , "--ingress"+            , "internal-and-cloud-load-balancing"+            , "--set-env-vars"+            , "LOG_LEVEL=info"+            , "--set-secrets"+            , "DB_PASSWORD=acme-db-password:latest,/secrets/tls/key.pem=acme-tls-key:3"+            , "--no-invoker-iam-check"+            , "--update-labels"+            , "salmon-turnup=acme"+            , "--region"+            , "europe-west1"+            , "--project"+            , "acme-prod"+            , "--quiet"+            ]+        )+        (cmdspec (prepare CloudRun.cloudRunCommand (CloudRun.RunDeploy (cloudRunServiceOf example api))))++ownerLabels :: IO ()+ownerLabels = do+    assertEqual "" (CloudRun.OwnerLabel "salmon-turnup" "acme") (ownerLabel example)+    mapM_+        (\s -> assertEqual (show s.svcName) (Just (ownerLabel fuller)) (cloudRunServiceOf fuller s).crsOptions.croOwner)+        fuller.turnupServices+    let dag = dagOf fuller+    mapM_+        ( \name -> do+            rf <- theOne ("deploys CloudRun service " <> name) dag+            assertBool (show (notesOf dag rf)) (any ("owned through the label salmon-turnup=acme" `Text.isInfixOf`) (notesOf dag rf))+        )+        ["acme-api", "acme-web"]+    -- the knobs of the second service+    case [cloudRunServiceOf fuller s | s <- fuller.turnupServices, s.svcName == "acme-web"] of+        [web] -> do+            assertEqual "" "web@acme-prod.iam.gserviceaccount.com" web.crsServiceAccount+            assertEqual "" (True, False) (web.crsOptions.croAllowUnauthenticated, web.crsOptions.croInvokerIamCheckDisabled)+            assertEqual "" (Just 1, Just 4, True) (web.crsOptions.croMinInstances, web.crsMaxInstances, web.crsOptions.croCpuAlwaysAllocated)+        _ -> assertFailure "one acme-web"++balancerShape :: IO ()+balancerShape = do+    let lb = maybe (error "a balancer") id fuller.turnupLoadBalancer+        alb = balancerOf fuller lb+    assertEqual "the default backend" [LoadBalancing.CloudRunBackend "acme-web"] alb.albBackends+    assertEqual "one more, for the service a path names" [LoadBalancing.BackendService "acme-api" [LoadBalancing.CloudRunBackend "acme-api"] Nothing Nothing] alb.albServices+    assertEqual+        "the rules"+        [ LoadBalancing.HostRule+            ["app.example.com"]+            LoadBalancing.DefaultService+            [LoadBalancing.PathRule ["/api/*"] (LoadBalancing.NamedService "acme-api") LoadBalancing.KeepPath]+        ]+        alb.albHostRules+    assertEqual "the certificate is one that exists" [LoadBalancing.ComputeCertificate "acme-cert"] alb.albCertificates+    assertEqual "port 80" (LoadBalancing.RedirectToHttps LoadBalancing.MovedPermanently) alb.albHttp+    assertEqual "the network" (Just "acme-net") alb.albNetwork+    -- and the plain one is the balancer module's plain one+    assertEqual+        ""+        (LoadBalancing.httpLoadBalancer "acme-lb" (cloudRunServiceOf example api).crsProject (cloudRunServiceOf example api).crsRegion [LoadBalancing.CloudRunBackend "acme-api"] Nothing)+        (balancerOf example exampleBalancer)++_unused :: ()+_unused = const () (dynamics, notes, ref, help)