fix import cycle

2026-03-26 02:11:53 +00:00 · 2020-12-01 00:03:31 -07:00
parent d5b07f18a1
commit 38320e576e
4 changed files with 109 additions and 104 deletions
--- a/agent/src/Application.hs
+++ b/agent/src/Application.hs
@@ -206,7 +206,7 @@ startupSequence foundation = do
    waitForUpdateSignal foundation

 sleep :: Integer -> IO ()
-sleep n = let (full, r) = (n * 1_000_000) `divMod` (fromIntegral $ (maxBound :: Int)) in
+sleep n = let (full, r) = (n * 1_000_000) `divMod` fromIntegral (maxBound :: Int) in
    replicateM_ (fromIntegral full) (threadDelay maxBound) *> threadDelay (fromIntegral r)

 --------------------------------------------------------------
--- a/agent/src/Handler/Register/Nginx.hs
+++ b/agent/src/Handler/Register/Nginx.hs
@@ -22,7 +22,6 @@ import           Lib.Synchronizers
 import           Lib.SystemPaths
 import           Lib.Tor
 import           System.Posix                   ( removeLink )
-import           Lib.SystemCtl

 -- Left error, Right CA cert for hmac signing
 bootupSslNginx :: (HasFilesystemBase sig m, Has (Error S9Error) sig m, Has (Lift IO) sig m, MonadIO m)
@@ -157,73 +156,3 @@ writeSslKeyAndCert rsaKeyFileContents = do
        ExitFailure ec -> throwError $ OpenSslE "leaf" ec str1' str2'

    readSystemPath' rootCaCertPath
-
-replaceDerivativeCerts :: (HasFilesystemBase sig m, Has (Error S9Error) sig m, MonadIO m) => m ()
-replaceDerivativeCerts = do
-    hn             <- getStart9AgentHostname
-    tor            <- getAgentHiddenServiceUrl
-
-    caKeyPath      <- toS <$> getAbsoluteLocationFor rootCaKeyPath
-    caConfPath     <- toS <$> getAbsoluteLocationFor rootCaOpenSslConfPath
-    caCertPath     <- toS <$> getAbsoluteLocationFor rootCaCertPath
-
-    intCaKeyPath   <- toS <$> getAbsoluteLocationFor intermediateCaKeyPath
-    intCaConfPath  <- toS <$> getAbsoluteLocationFor intermediateCaOpenSslConfPath
-    intCaCertPath  <- toS <$> getAbsoluteLocationFor intermediateCaCertPath
-
-    sslDirTmp      <- toS <$> getAbsoluteLocationFor (agentTmpDirectory <> sslDirectory)
-    entKeyPathTmp  <- toS <$> getAbsoluteLocationFor (agentTmpDirectory <> entityKeyPath hn)
-    entConfPathTmp <- toS <$> getAbsoluteLocationFor (agentTmpDirectory <> entityConfPath hn)
-    entCertPathTmp <- toS <$> getAbsoluteLocationFor (agentTmpDirectory <> entityCertPath hn)
-    liftIO $ createDirectoryIfMissing True sslDirTmp
-    liftIO $ BS.writeFile entConfPathTmp (domain_CSR_CONF hn)
-
-    -- ensure duplicate certificates are acceptable
-    base <- Fused.ask @"filesystemBase"
-    liftIO $ BS.writeFile (toS $ (rootCaDirectory <> "index.txt.attr") `relativeTo` base) "unique_subject = no\n"
-    liftIO $ BS.writeFile (toS $ (intermediateCaDirectory <> "index.txt.attr") `relativeTo` base)
-                          "unique_subject = no\n"
-
-    (ec, out, err) <- writeIntermediateCert DeriveCertificate { applicantConfPath = intCaConfPath
-                                                              , applicantKeyPath  = intCaKeyPath
-                                                              , applicantCertPath = intCaCertPath
-                                                              , signingConfPath   = caConfPath
-                                                              , signingKeyPath    = caKeyPath
-                                                              , signingCertPath   = caCertPath
-                                                              , duration          = 3650
-                                                              }
-    liftIO $ do
-        putStrLn @Text "openssl logs"
-        putStrLn @Text "exit code: "
-        print ec
-        putStrLn @String $ "stdout: " <> out
-        putStrLn @String $ "stderr: " <> err
-    case ec of
-        ExitSuccess   -> pure ()
-        ExitFailure n -> throwError $ OpenSslE "leaf" n out err
-
-    (ec', out', err') <- writeLeafCert
-        DeriveCertificate { applicantConfPath = entConfPathTmp
-                          , applicantKeyPath  = entKeyPathTmp
-                          , applicantCertPath = entCertPathTmp
-                          , signingConfPath   = intCaConfPath
-                          , signingKeyPath    = intCaKeyPath
-                          , signingCertPath   = intCaCertPath
-                          , duration          = 365
-                          }
-        hn
-        tor
-    liftIO $ do
-        putStrLn @Text "openssl logs"
-        putStrLn @Text "exit code: "
-        print ec
-        putStrLn @String $ "stdout: " <> out'
-        putStrLn @String $ "stderr: " <> err'
-    case ec' of
-        ExitSuccess   -> pure ()
-        ExitFailure n -> throwError $ OpenSslE "leaf" n out' err'
-
-    sslDir <- toS <$> getAbsoluteLocationFor sslDirectory
-    liftIO $ removeDirectory sslDir
-    liftIO $ renameDirectory sslDirTmp sslDir
-    liftIO $ systemCtl RestartService "nginx" $> ()
--- a/agent/src/Lib/Error.hs
+++ b/agent/src/Lib/Error.hs
@@ -198,7 +198,7 @@ toStatus = \case
    NoCompliantAgentE _    -> status404
    PersistentE       _    -> status500
    WifiConnectionE        -> status500
-    AppMgrParseE _ _ _     -> status500
+    AppMgrParseE{}         -> status500
    AppMgrInvalidConfigE _ -> status400
    AppMgrE        _ _     -> status500
    AppMgrVersionE _ _     -> status500
@@ -220,28 +220,28 @@ toStatus = \case
        (AppStatusTmp    NeedsConfig, Start) -> status403
        (AppStatusTmp    NeedsConfig, Stop ) -> status200
        (AppStatusTmp    _          , _    ) -> status403
-    UpdateSelfE _ _             -> status500
-    InvalidSshKeyE _            -> status400
-    InvalidSsidE                -> status400
-    InvalidPskE                 -> status400
-    InvalidRequestE _ _         -> status400
-    NotFoundE       _ _         -> status404
-    UpdateInProgressE           -> status403
-    TemporarilyForbiddenE _ _ _ -> status403
-    TorServiceTimeoutE          -> status500
-    NginxSslE _                 -> status500
-    WifiOrphaningE              -> status403
-    ManifestParseE _ _          -> status500
-    NoPasswordExistsE           -> status401
-    MissingFileE        _       -> status500
-    ClientCryptographyE _       -> status401
-    TTLExpirationE      _       -> status403
-    EnvironmentValE     _       -> status500
-    HostsParamsE        _       -> status400
-    BackupE _ _                 -> status500
-    BackupPassInvalidE          -> status403
-    InternalE _                 -> status500
-    OpenSslE _ _ _ _            -> status500
+    UpdateSelfE _ _         -> status500
+    InvalidSshKeyE _        -> status400
+    InvalidSsidE            -> status400
+    InvalidPskE             -> status400
+    InvalidRequestE _ _     -> status400
+    NotFoundE       _ _     -> status404
+    UpdateInProgressE       -> status403
+    TemporarilyForbiddenE{} -> status403
+    TorServiceTimeoutE      -> status500
+    NginxSslE _             -> status500
+    WifiOrphaningE          -> status403
+    ManifestParseE _ _      -> status500
+    NoPasswordExistsE       -> status401
+    MissingFileE        _   -> status500
+    ClientCryptographyE _   -> status401
+    TTLExpirationE      _   -> status403
+    EnvironmentValE     _   -> status500
+    HostsParamsE        _   -> status400
+    BackupE _ _             -> status500
+    BackupPassInvalidE      -> status403
+    InternalE _             -> status500
+    OpenSslE{}              -> status500

 handleS9ErrC :: (MonadHandler m, MonadLogger m) => ErrorC S9Error m a -> m a
 handleS9ErrC action =
@@ -251,12 +251,11 @@ handleS9ErrC action =
    in  runErrorC action handleIt pure

 handleS9ErrT :: (MonadHandler m, MonadLogger m) => S9ErrT m a -> m a
-handleS9ErrT action = do
-    runExceptT action >>= \case
-        Left e -> do
-            $logError $ show e
-            toStatus >>= sendResponseStatus $ e
-        Right a -> pure a
+handleS9ErrT action = runExceptT action >>= \case
+    Left e -> do
+        $logError $ show e
+        toStatus >>= sendResponseStatus $ e
+    Right a -> pure a

 runS9ErrT :: MonadIO m => S9ErrT m a -> m (Either S9Error a)
 runS9ErrT = runExceptT
--- a/agent/src/Lib/Synchronizers.hs
+++ b/agent/src/Lib/Synchronizers.hs
@@ -5,7 +5,9 @@
 {-# LANGUAGE TemplateHaskell      #-}
 module Lib.Synchronizers where

-import           Startlude               hiding ( check )
+import           Startlude               hiding ( check
+                                                , err
+                                                )
 import qualified Startlude.ByteStream          as ByteStream
 import qualified Startlude.ByteStream.Char8    as ByteStream

@@ -62,7 +64,7 @@ import           Util.File
 import qualified Lib.Algebra.Domain.AppMgr     as AppMgr2
 import           Daemon.ZeroConf                ( getStart9AgentHostname )
 import qualified Data.Text                     as T
-import           Handler.Register.Nginx         ( replaceDerivativeCerts )
+import           Control.Effect.Error    hiding ( run )


 data Synchronizer = Synchronizer
@@ -451,7 +453,82 @@ syncConvertEcdsaCerts = SyncOp "Convert Intermediate Cert to ECDSA P256" check m
            pure $ case header of
                Nothing -> False
                Just y  -> "BEGIN RSA PRIVATE KEY" `T.isInfixOf` y
-        migrate = replaceDerivativeCerts
+        migrate = cantFail $ do
+            base <- asks $ appFilesystemBase . appSettings
+            (runM . runExceptT) (injectFilesystemBase base replaceDerivativeCerts) >>= \case
+                Left  e  -> failUpdate e
+                Right () -> pure ()
+
+
+replaceDerivativeCerts :: (HasFilesystemBase sig m, Fused.Has (Error S9Error) sig m, MonadIO m) => m ()
+replaceDerivativeCerts = do
+    hn             <- getStart9AgentHostname
+    tor            <- getAgentHiddenServiceUrl
+
+    caKeyPath      <- toS <$> getAbsoluteLocationFor rootCaKeyPath
+    caConfPath     <- toS <$> getAbsoluteLocationFor rootCaOpenSslConfPath
+    caCertPath     <- toS <$> getAbsoluteLocationFor rootCaCertPath
+
+    intCaKeyPath   <- toS <$> getAbsoluteLocationFor intermediateCaKeyPath
+    intCaConfPath  <- toS <$> getAbsoluteLocationFor intermediateCaOpenSslConfPath
+    intCaCertPath  <- toS <$> getAbsoluteLocationFor intermediateCaCertPath
+
+    sslDirTmp      <- toS <$> getAbsoluteLocationFor (agentTmpDirectory <> sslDirectory)
+    entKeyPathTmp  <- toS <$> getAbsoluteLocationFor (agentTmpDirectory <> entityKeyPath hn)
+    entConfPathTmp <- toS <$> getAbsoluteLocationFor (agentTmpDirectory <> entityConfPath hn)
+    entCertPathTmp <- toS <$> getAbsoluteLocationFor (agentTmpDirectory <> entityCertPath hn)
+    liftIO $ createDirectoryIfMissing True sslDirTmp
+    liftIO $ BS.writeFile entConfPathTmp (domain_CSR_CONF hn)
+
+    -- ensure duplicate certificates are acceptable
+    base <- Fused.ask @"filesystemBase"
+    liftIO $ BS.writeFile (toS $ (rootCaDirectory <> "index.txt.attr") `relativeTo` base) "unique_subject = no\n"
+    liftIO $ BS.writeFile (toS $ (intermediateCaDirectory <> "index.txt.attr") `relativeTo` base)
+                          "unique_subject = no\n"
+
+    (ec, out, err) <- writeIntermediateCert DeriveCertificate { applicantConfPath = intCaConfPath
+                                                              , applicantKeyPath  = intCaKeyPath
+                                                              , applicantCertPath = intCaCertPath
+                                                              , signingConfPath   = caConfPath
+                                                              , signingKeyPath    = caKeyPath
+                                                              , signingCertPath   = caCertPath
+                                                              , duration          = 3650
+                                                              }
+    liftIO $ do
+        putStrLn @Text "openssl logs"
+        putStrLn @Text "exit code: "
+        print ec
+        putStrLn @String $ "stdout: " <> out
+        putStrLn @String $ "stderr: " <> err
+    case ec of
+        ExitSuccess   -> pure ()
+        ExitFailure n -> throwError $ OpenSslE "leaf" n out err
+
+    (ec', out', err') <- writeLeafCert
+        DeriveCertificate { applicantConfPath = entConfPathTmp
+                          , applicantKeyPath  = entKeyPathTmp
+                          , applicantCertPath = entCertPathTmp
+                          , signingConfPath   = intCaConfPath
+                          , signingKeyPath    = intCaKeyPath
+                          , signingCertPath   = intCaCertPath
+                          , duration          = 365
+                          }
+        hn
+        tor
+    liftIO $ do
+        putStrLn @Text "openssl logs"
+        putStrLn @Text "exit code: "
+        print ec
+        putStrLn @String $ "stdout: " <> out'
+        putStrLn @String $ "stderr: " <> err'
+    case ec' of
+        ExitSuccess   -> pure ()
+        ExitFailure n -> throwError $ OpenSslE "leaf" n out' err'
+
+    sslDir <- toS <$> getAbsoluteLocationFor sslDirectory
+    liftIO $ removeDirectory sslDir
+    liftIO $ renameDirectory sslDirTmp sslDir
+    liftIO $ systemCtl RestartService "nginx" $> ()

 failUpdate :: S9Error -> ExceptT Void (ReaderT AgentCtx IO) ()
 failUpdate e = do